-- | Abstract definition of a Repository
--
-- Most clients should only need to import this module if they wish to define
-- their own Repository implementations.
{-# LANGUAGE CPP #-}
module Hackage.Security.Client.Repository (
    -- * Files
    Metadata  -- type index (really a kind)
  , Binary    -- type index (really a kind)
  , RemoteFile(..)
  , CachedFile(..)
  , IndexFile(..)
  , remoteFileDefaultFormat
  , remoteFileDefaultInfo
    -- * Repository proper
  , Repository(..)
  , AttemptNr(..)
  , LogMessage(..)
  , UpdateFailure(..)
  , SomeRemoteError(..)
    -- ** Downloaded files
  , DownloadedFile(..)
    -- ** Helpers
  , mirrorsUnsupported
    -- * Paths
  , remoteRepoPath
  , remoteRepoPath'
    -- * Utility
  , IsCached(..)
  , mustCache
  ) where

import MyPrelude
import Control.Exception
import Data.Typeable (Typeable)
import qualified Codec.Archive.Tar.Index as Tar
import qualified Data.ByteString.Lazy    as BS.L

import Distribution.Package
import Distribution.Text

import Hackage.Security.Client.Formats
import Hackage.Security.Client.Verify
import Hackage.Security.Trusted
import Hackage.Security.TUF
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Path
import Hackage.Security.Util.Pretty
import Hackage.Security.Util.Some
import Hackage.Security.Util.Stack

{-------------------------------------------------------------------------------
  Files
-------------------------------------------------------------------------------}

data Metadata
data Binary

-- | Abstract definition of files we might have to download
--
-- 'RemoteFile' is parametrized by the type of the formats that we can accept
-- from the remote repository, as well as with information on whether this file
-- is metadata actual binary content.
--
-- NOTE: Haddock lacks GADT support so constructors have only regular comments.
data RemoteFile :: * -> * -> * where
    -- Timestamp metadata (@timestamp.json@)
    --
    -- We never have (explicit) file length available for timestamps.
    RemoteTimestamp :: RemoteFile (FormatUn :- ()) Metadata

    -- Root metadata (@root.json@)
    --
    -- For root information we may or may not have the file info available:
    --
    -- - If during the normal update process the new snapshot tells us the root
    --   information has changed, we can use the file info from the snapshot.
    -- - If however we need to update the root metadata due to a verification
    --   exception we do not know the file info.
    -- - We also do not know the file info during bootstrapping.
    RemoteRoot :: Maybe (Trusted FileInfo) -> RemoteFile (FormatUn :- ()) Metadata

    -- Snapshot metadata (@snapshot.json@)
    --
    -- We get file info of the snapshot from the timestamp.
    RemoteSnapshot :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata

    -- Mirrors metadata (@mirrors.json@)
    --
    -- We get the file info from the snapshot.
    RemoteMirrors :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata

    -- Index
    --
    -- The index file length comes from the snapshot.
    --
    -- When we request that the index is downloaded, it is up to the repository
    -- to decide whether to download @00-index.tar@ or @00-index.tar.gz@.
    -- The callback is told which format was requested.
    --
    -- It is a bug to request a file that the repository does not provide
    -- (the snapshot should make it clear which files are available).
    RemoteIndex :: HasFormat fs FormatGz
                -> Formats fs (Trusted FileInfo)
                -> RemoteFile fs Binary

    -- Actual package
    --
    -- Package file length comes from the corresponding @targets.json@.
    RemotePkgTarGz :: PackageIdentifier
                   -> Trusted FileInfo
                   -> RemoteFile (FormatGz :- ()) Binary

deriving instance Show (RemoteFile fs typ)

instance Pretty (RemoteFile fs typ) where
  pretty :: RemoteFile fs typ -> String
pretty RemoteFile fs typ
RemoteTimestamp          = String
"timestamp"
  pretty (RemoteRoot Maybe (Trusted FileInfo)
_)           = String
"root"
  pretty (RemoteSnapshot Trusted FileInfo
_)       = String
"snapshot"
  pretty (RemoteMirrors Trusted FileInfo
_)        = String
"mirrors"
  pretty (RemoteIndex HasFormat fs FormatGz
_ Formats fs (Trusted FileInfo)
_)        = String
"index"
  pretty (RemotePkgTarGz PackageIdentifier
pkgId Trusted FileInfo
_) = String
"package " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
display PackageIdentifier
pkgId

-- | Files that we might request from the local cache
data CachedFile =
    -- | Timestamp metadata (@timestamp.json@)
    CachedTimestamp

    -- | Root metadata (@root.json@)
  | CachedRoot

    -- | Snapshot metadata (@snapshot.json@)
  | CachedSnapshot

    -- | Mirrors list (@mirrors.json@)
  | CachedMirrors
  deriving (CachedFile -> CachedFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CachedFile -> CachedFile -> Bool
$c/= :: CachedFile -> CachedFile -> Bool
== :: CachedFile -> CachedFile -> Bool
$c== :: CachedFile -> CachedFile -> Bool
Eq, Eq CachedFile
CachedFile -> CachedFile -> Bool
CachedFile -> CachedFile -> Ordering
CachedFile -> CachedFile -> CachedFile
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CachedFile -> CachedFile -> CachedFile
$cmin :: CachedFile -> CachedFile -> CachedFile
max :: CachedFile -> CachedFile -> CachedFile
$cmax :: CachedFile -> CachedFile -> CachedFile
>= :: CachedFile -> CachedFile -> Bool
$c>= :: CachedFile -> CachedFile -> Bool
> :: CachedFile -> CachedFile -> Bool
$c> :: CachedFile -> CachedFile -> Bool
<= :: CachedFile -> CachedFile -> Bool
$c<= :: CachedFile -> CachedFile -> Bool
< :: CachedFile -> CachedFile -> Bool
$c< :: CachedFile -> CachedFile -> Bool
compare :: CachedFile -> CachedFile -> Ordering
$ccompare :: CachedFile -> CachedFile -> Ordering
Ord, Int -> CachedFile -> ShowS
[CachedFile] -> ShowS
CachedFile -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CachedFile] -> ShowS
$cshowList :: [CachedFile] -> ShowS
show :: CachedFile -> String
$cshow :: CachedFile -> String
showsPrec :: Int -> CachedFile -> ShowS
$cshowsPrec :: Int -> CachedFile -> ShowS
Show)

instance Pretty CachedFile where
  pretty :: CachedFile -> String
pretty CachedFile
CachedTimestamp = String
"timestamp"
  pretty CachedFile
CachedRoot      = String
"root"
  pretty CachedFile
CachedSnapshot  = String
"snapshot"
  pretty CachedFile
CachedMirrors   = String
"mirrors"

-- | Default format for each file type
--
-- For most file types we don't have a choice; for the index the repository
-- is only required to offer the GZip-compressed format so that is the default.
remoteFileDefaultFormat :: RemoteFile fs typ -> Some (HasFormat fs)
remoteFileDefaultFormat :: forall fs typ. RemoteFile fs typ -> Some (HasFormat fs)
remoteFileDefaultFormat RemoteFile fs typ
RemoteTimestamp      = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn
remoteFileDefaultFormat (RemoteRoot Maybe (Trusted FileInfo)
_)       = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn
remoteFileDefaultFormat (RemoteSnapshot Trusted FileInfo
_)   = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn
remoteFileDefaultFormat (RemoteMirrors Trusted FileInfo
_)    = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn
remoteFileDefaultFormat (RemotePkgTarGz PackageIdentifier
_ Trusted FileInfo
_) = forall (f :: * -> *) a. f a -> Some f
Some forall a b. (a -> b) -> a -> b
$ forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatGz
FGz
remoteFileDefaultFormat (RemoteIndex HasFormat fs FormatGz
pf Formats fs (Trusted FileInfo)
_)   = forall (f :: * -> *) a. f a -> Some f
Some HasFormat fs FormatGz
pf

-- | Default file info (see also 'remoteFileDefaultFormat')
remoteFileDefaultInfo :: RemoteFile fs typ -> Maybe (Trusted FileInfo)
remoteFileDefaultInfo :: forall fs typ. RemoteFile fs typ -> Maybe (Trusted FileInfo)
remoteFileDefaultInfo RemoteFile fs typ
RemoteTimestamp         = forall a. Maybe a
Nothing
remoteFileDefaultInfo (RemoteRoot Maybe (Trusted FileInfo)
info)       = Maybe (Trusted FileInfo)
info
remoteFileDefaultInfo (RemoteSnapshot Trusted FileInfo
info)   = forall a. a -> Maybe a
Just Trusted FileInfo
info
remoteFileDefaultInfo (RemoteMirrors Trusted FileInfo
info)    = forall a. a -> Maybe a
Just Trusted FileInfo
info
remoteFileDefaultInfo (RemotePkgTarGz PackageIdentifier
_ Trusted FileInfo
info) = forall a. a -> Maybe a
Just Trusted FileInfo
info
remoteFileDefaultInfo (RemoteIndex HasFormat fs FormatGz
pf Formats fs (Trusted FileInfo)
info)   = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall fs f a. HasFormat fs f -> Formats fs a -> a
formatsLookup HasFormat fs FormatGz
pf Formats fs (Trusted FileInfo)
info

{-------------------------------------------------------------------------------
  Repository proper
-------------------------------------------------------------------------------}

-- | Repository
--
-- This is an abstract representation of a repository. It simply provides a way
-- to download metafiles and target files, without specifying how this is done.
-- For instance, for a local repository this could just be doing a file read,
-- whereas for remote repositories this could be using any kind of HTTP client.
data Repository down = DownloadedFile down => Repository {
    -- | Get a file from the server
    --
    -- Responsibilies of 'repGetRemote':
    --
    -- * Download the file from the repository and make it available at a
    --   temporary location
    -- * Use the provided file length to protect against endless data attacks.
    --   (Repositories such as local repositories that are not susceptible to
    --   endless data attacks can safely ignore this argument.)
    -- * Move the file from its temporary location to its permanent location
    --   if verification succeeds.
    --
    -- NOTE: Calls to 'repGetRemote' should _always_ be in the scope of
    -- 'repWithMirror'.
    forall (down :: * -> *).
Repository down
-> forall fs typ.
   Throws SomeRemoteError =>
   AttemptNr
   -> RemoteFile fs typ -> Verify (Some (HasFormat fs), down typ)
repGetRemote :: forall fs typ. Throws SomeRemoteError
                 => AttemptNr
                 -> RemoteFile fs typ
                 -> Verify (Some (HasFormat fs), down typ)

    -- | Get a cached file (if available)
  , forall (down :: * -> *).
Repository down -> CachedFile -> IO (Maybe (Path Absolute))
repGetCached :: CachedFile -> IO (Maybe (Path Absolute))

    -- | Get the cached root
    --
    -- This is a separate method only because clients must ALWAYS have root
    -- information available.
  , forall (down :: * -> *). Repository down -> IO (Path Absolute)
repGetCachedRoot :: IO (Path Absolute)

    -- | Clear all cached data
    --
    -- In particular, this should remove the snapshot and the timestamp.
    -- It would also be okay, but not required, to delete the index.
  , forall (down :: * -> *). Repository down -> IO ()
repClearCache :: IO ()

    -- | Open the tarball for reading
    --
    -- This function has this shape so that:
    --
    -- * We can read multiple files from the tarball without having to open
    --   and close the handle each time
    -- * We can close the handle immediately when done.
  , forall (down :: * -> *).
Repository down -> forall a. (Handle -> IO a) -> IO a
repWithIndex :: forall a. (Handle -> IO a) -> IO a

    -- | Read the index index
  , forall (down :: * -> *). Repository down -> IO TarIndex
repGetIndexIdx :: IO Tar.TarIndex

    -- | Lock the cache (during updates)
  , forall (down :: * -> *). Repository down -> IO () -> IO ()
repLockCache :: IO () -> IO ()

    -- | Mirror selection
    --
    -- The purpose of 'repWithMirror' is to scope mirror selection. The idea
    -- is that if we have
    --
    -- > repWithMirror mirrorList $
    -- >   someCallback
    --
    -- then the repository may pick a mirror before calling @someCallback@,
    -- catch exceptions thrown by @someCallback@, and potentially try the
    -- callback again with a different mirror.
    --
    -- The list of mirrors may be @Nothing@ if we haven't yet downloaded the
    -- list of mirrors from the repository, or when our cached list of mirrors
    -- is invalid. Of course, if we did download it, then the list of mirrors
    -- may still be empty. In this case the repository must fall back to its
    -- primary download mechanism.
    --
    -- Mirrors as currently defined (in terms of a "base URL") are inherently a
    -- HTTP (or related) concept, so in repository implementations such as the
    -- local-repo 'repWithMirrors' is probably just an identity operation  (see
    -- 'ignoreMirrors').  Conversely, HTTP implementations of repositories may
    -- have other, out-of-band information (for example, coming from a cabal
    -- config file) that they may use to influence mirror selection.
  , forall (down :: * -> *).
Repository down -> forall a. Maybe [Mirror] -> IO a -> IO a
repWithMirror :: forall a. Maybe [Mirror] -> IO a -> IO a

    -- | Logging
  , forall (down :: * -> *). Repository down -> LogMessage -> IO ()
repLog :: LogMessage -> IO ()

    -- | Layout of this repository
  , forall (down :: * -> *). Repository down -> RepoLayout
repLayout :: RepoLayout

    -- | Layout of the index
    --
    -- Since the repository hosts the index, the layout of the index is
    -- not independent of the layout of the repository.
  , forall (down :: * -> *). Repository down -> IndexLayout
repIndexLayout :: IndexLayout

    -- | Description of the repository (used in the show instance)
  , forall (down :: * -> *). Repository down -> String
repDescription :: String
  }

instance Show (Repository down) where
  show :: Repository down -> String
show = forall (down :: * -> *). Repository down -> String
repDescription

-- | Helper function to implement 'repWithMirrors'.
mirrorsUnsupported :: Maybe [Mirror] -> IO a -> IO a
mirrorsUnsupported :: forall a. Maybe [Mirror] -> IO a -> IO a
mirrorsUnsupported Maybe [Mirror]
_ = forall a. a -> a
id

-- | Are we requesting this information because of a previous validation error?
--
-- Clients can take advantage of this to tell caches to revalidate files.
newtype AttemptNr = AttemptNr Int
  deriving (AttemptNr -> AttemptNr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttemptNr -> AttemptNr -> Bool
$c/= :: AttemptNr -> AttemptNr -> Bool
== :: AttemptNr -> AttemptNr -> Bool
$c== :: AttemptNr -> AttemptNr -> Bool
Eq, Eq AttemptNr
AttemptNr -> AttemptNr -> Bool
AttemptNr -> AttemptNr -> Ordering
AttemptNr -> AttemptNr -> AttemptNr
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AttemptNr -> AttemptNr -> AttemptNr
$cmin :: AttemptNr -> AttemptNr -> AttemptNr
max :: AttemptNr -> AttemptNr -> AttemptNr
$cmax :: AttemptNr -> AttemptNr -> AttemptNr
>= :: AttemptNr -> AttemptNr -> Bool
$c>= :: AttemptNr -> AttemptNr -> Bool
> :: AttemptNr -> AttemptNr -> Bool
$c> :: AttemptNr -> AttemptNr -> Bool
<= :: AttemptNr -> AttemptNr -> Bool
$c<= :: AttemptNr -> AttemptNr -> Bool
< :: AttemptNr -> AttemptNr -> Bool
$c< :: AttemptNr -> AttemptNr -> Bool
compare :: AttemptNr -> AttemptNr -> Ordering
$ccompare :: AttemptNr -> AttemptNr -> Ordering
Ord, Integer -> AttemptNr
AttemptNr -> AttemptNr
AttemptNr -> AttemptNr -> AttemptNr
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> AttemptNr
$cfromInteger :: Integer -> AttemptNr
signum :: AttemptNr -> AttemptNr
$csignum :: AttemptNr -> AttemptNr
abs :: AttemptNr -> AttemptNr
$cabs :: AttemptNr -> AttemptNr
negate :: AttemptNr -> AttemptNr
$cnegate :: AttemptNr -> AttemptNr
* :: AttemptNr -> AttemptNr -> AttemptNr
$c* :: AttemptNr -> AttemptNr -> AttemptNr
- :: AttemptNr -> AttemptNr -> AttemptNr
$c- :: AttemptNr -> AttemptNr -> AttemptNr
+ :: AttemptNr -> AttemptNr -> AttemptNr
$c+ :: AttemptNr -> AttemptNr -> AttemptNr
Num)

-- | Log messages
--
-- We use a 'RemoteFile' rather than a 'RepoPath' here because we might not have
-- a 'RepoPath' for the file that we were trying to download (that is, for
-- example if the server does not provide an uncompressed tarball, it doesn't
-- make much sense to list the path to that non-existing uncompressed tarball).
data LogMessage =
    -- | Root information was updated
    --
    -- This message is issued when the root information is updated as part of
    -- the normal check for updates procedure. If the root information is
    -- updated because of a verification error WarningVerificationError is
    -- issued instead.
    LogRootUpdated

    -- | A verification error
    --
    -- Verification errors can be temporary, and may be resolved later; hence
    -- these are just warnings. (Verification errors that cannot be resolved
    -- are thrown as exceptions.)
  | LogVerificationError VerificationError

    -- | Download a file from a repository
  | forall fs typ. LogDownloading (RemoteFile fs typ)

    -- | Incrementally updating a file from a repository
  | forall fs. LogUpdating (RemoteFile fs Binary)

    -- | Selected a particular mirror
  | LogSelectedMirror MirrorDescription

    -- | Updating a file failed
    -- (we will instead download it whole)
  | forall fs. LogCannotUpdate (RemoteFile fs Binary) UpdateFailure

    -- | We got an exception with a particular mirror
    -- (we will try with a different mirror if any are available)
  | LogMirrorFailed MirrorDescription SomeException

    -- | This log event is triggered before invoking a filesystem lock
    -- operation that may block for a significant amount of time; once
    -- the possibly blocking call completes successfully,
    -- 'LogLockWaitDone' will be emitted.
    --
    -- @since 0.6.0
  | LogLockWait (Path Absolute)

    -- | Denotes completion of the operation that advertised a
    -- 'LogLockWait' event
    --
    -- @since 0.6.0
  | LogLockWaitDone (Path Absolute)

    -- | Denotes the filesystem lock previously acquired (signaled by
    -- 'LogLockWait') has been released.
    --
    -- @since 0.6.0
  | LogUnlock (Path Absolute)


-- | Records why we are downloading a file rather than updating it.
data UpdateFailure =
    -- | Server does not support incremental downloads
    UpdateImpossibleUnsupported

    -- | We don't have a local copy of the file to update
  | UpdateImpossibleNoLocalCopy

    -- | Update failed twice
    --
    -- If we attempt an incremental update the first time, and it fails,  we let
    -- it go round the loop, update local security information, and try again.
    -- But if an incremental update then fails _again_, we  instead attempt a
    -- regular download.
  | UpdateFailedTwice

    -- | Update failed (for example: perhaps the local file got corrupted)
  | UpdateFailed SomeException

{-------------------------------------------------------------------------------
  Downloaded files
-------------------------------------------------------------------------------}

class DownloadedFile (down :: * -> *) where
  -- | Verify a download file
  downloadedVerify :: down a -> Trusted FileInfo -> IO Bool

  -- | Read the file we just downloaded into memory
  --
  -- We never read binary data, only metadata.
  downloadedRead :: down Metadata -> IO BS.L.ByteString

  -- | Copy a downloaded file to its destination
  downloadedCopyTo :: down a -> Path Absolute -> IO ()

{-------------------------------------------------------------------------------
  Exceptions thrown by specific Repository implementations
-------------------------------------------------------------------------------}

-- | Repository-specific exceptions
--
-- For instance, for repositories using HTTP this might correspond to a 404;
-- for local repositories this might correspond to file-not-found, etc.
data SomeRemoteError :: * where
    SomeRemoteError :: Exception e => e -> SomeRemoteError
  deriving (Typeable)

#if MIN_VERSION_base(4,8,0)
deriving instance Show SomeRemoteError
instance Exception SomeRemoteError where displayException :: SomeRemoteError -> String
displayException = forall a. Pretty a => a -> String
pretty
#else
instance Exception SomeRemoteError
instance Show SomeRemoteError where show = pretty
#endif

instance Pretty SomeRemoteError where
    pretty :: SomeRemoteError -> String
pretty (SomeRemoteError e
ex) = forall e. Exception e => e -> String
displayException e
ex

{-------------------------------------------------------------------------------
  Paths
-------------------------------------------------------------------------------}

remoteRepoPath :: RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath
remoteRepoPath :: forall fs typ.
RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath
remoteRepoPath RepoLayout{RepoPath
PackageIdentifier -> RepoPath
repoLayoutPkgTarGz :: RepoLayout -> PackageIdentifier -> RepoPath
repoLayoutIndexTar :: RepoLayout -> RepoPath
repoLayoutIndexTarGz :: RepoLayout -> RepoPath
repoLayoutMirrors :: RepoLayout -> RepoPath
repoLayoutSnapshot :: RepoLayout -> RepoPath
repoLayoutTimestamp :: RepoLayout -> RepoPath
repoLayoutRoot :: RepoLayout -> RepoPath
repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath
repoLayoutIndexTar :: RepoPath
repoLayoutIndexTarGz :: RepoPath
repoLayoutMirrors :: RepoPath
repoLayoutSnapshot :: RepoPath
repoLayoutTimestamp :: RepoPath
repoLayoutRoot :: RepoPath
..} = forall fs typ. RemoteFile fs typ -> Formats fs RepoPath
go
  where
    go :: RemoteFile fs typ -> Formats fs RepoPath
    go :: forall fs typ. RemoteFile fs typ -> Formats fs RepoPath
go RemoteFile fs typ
RemoteTimestamp        = forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ RepoPath
repoLayoutTimestamp
    go (RemoteRoot Maybe (Trusted FileInfo)
_)         = forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ RepoPath
repoLayoutRoot
    go (RemoteSnapshot Trusted FileInfo
_)     = forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ RepoPath
repoLayoutSnapshot
    go (RemoteMirrors Trusted FileInfo
_)      = forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ RepoPath
repoLayoutMirrors
    go (RemotePkgTarGz PackageIdentifier
pId Trusted FileInfo
_) = forall a. a -> Formats (FormatGz :- ()) a
FsGz forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> RepoPath
repoLayoutPkgTarGz PackageIdentifier
pId
    go (RemoteIndex HasFormat fs FormatGz
_ Formats fs (Trusted FileInfo)
lens)   = forall a b fs.
(forall f. Format f -> a -> b) -> Formats fs a -> Formats fs b
formatsMap forall f a. Format f -> a -> RepoPath
goIndex Formats fs (Trusted FileInfo)
lens

    goIndex :: Format f -> a -> RepoPath
    goIndex :: forall f a. Format f -> a -> RepoPath
goIndex Format f
FUn a
_ = RepoPath
repoLayoutIndexTar
    goIndex Format f
FGz a
_ = RepoPath
repoLayoutIndexTarGz

remoteRepoPath' :: RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
remoteRepoPath' :: forall fs typ f.
RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
remoteRepoPath' RepoLayout
repoLayout RemoteFile fs typ
file HasFormat fs f
format =
    forall fs f a. HasFormat fs f -> Formats fs a -> a
formatsLookup HasFormat fs f
format forall a b. (a -> b) -> a -> b
$ forall fs typ.
RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath
remoteRepoPath RepoLayout
repoLayout RemoteFile fs typ
file

{-------------------------------------------------------------------------------
  Utility
-------------------------------------------------------------------------------}

-- | Is a particular remote file cached?
data IsCached :: * -> * where
    -- This remote file should be cached, and we ask for it by name
    CacheAs :: CachedFile -> IsCached Metadata

    -- We don't cache this remote file
    --
    -- This doesn't mean a Repository should not feel free to cache the file
    -- if desired, but it does mean the generic algorithms will never ask for
    -- this file from the cache.
    DontCache :: IsCached Binary

    -- The index is somewhat special: it should be cached, but we never
    -- ask for it directly.
    --
    -- Instead, we will ask the Repository for files _from_ the index, which it
    -- can serve however it likes. For instance, some repositories might keep
    -- the index in uncompressed form, others in compressed form; some might
    -- keep an index tarball index for quick access, others may scan the tarball
    -- linearly, etc.
    CacheIndex :: IsCached Binary
--TODO: ^^ older haddock doesn't support GADT doc comments :-(

deriving instance Eq   (IsCached typ)
deriving instance Show (IsCached typ)

-- | Which remote files should we cache locally?
mustCache :: RemoteFile fs typ -> IsCached typ
mustCache :: forall fs typ. RemoteFile fs typ -> IsCached typ
mustCache RemoteFile fs typ
RemoteTimestamp      = CachedFile -> IsCached Metadata
CacheAs CachedFile
CachedTimestamp
mustCache (RemoteRoot Maybe (Trusted FileInfo)
_)       = CachedFile -> IsCached Metadata
CacheAs CachedFile
CachedRoot
mustCache (RemoteSnapshot Trusted FileInfo
_)   = CachedFile -> IsCached Metadata
CacheAs CachedFile
CachedSnapshot
mustCache (RemoteMirrors Trusted FileInfo
_)    = CachedFile -> IsCached Metadata
CacheAs CachedFile
CachedMirrors
mustCache (RemoteIndex {})     = IsCached Binary
CacheIndex
mustCache (RemotePkgTarGz PackageIdentifier
_ Trusted FileInfo
_) = IsCached Binary
DontCache

instance Pretty LogMessage where
  pretty :: LogMessage -> String
pretty LogMessage
LogRootUpdated =
      String
"Root info updated"
  pretty (LogVerificationError VerificationError
err) =
      String
"Verification error: " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty VerificationError
err
  pretty (LogDownloading RemoteFile fs typ
file) =
      String
"Downloading " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty RemoteFile fs typ
file
  pretty (LogUpdating RemoteFile fs Binary
file) =
      String
"Updating " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty RemoteFile fs Binary
file
  pretty (LogSelectedMirror String
mirror) =
      String
"Selected mirror " forall a. [a] -> [a] -> [a]
++ String
mirror
  pretty (LogCannotUpdate RemoteFile fs Binary
file UpdateFailure
ex) =
      String
"Cannot update " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty RemoteFile fs Binary
file forall a. [a] -> [a] -> [a]
++ String
" (" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty UpdateFailure
ex forall a. [a] -> [a] -> [a]
++ String
")"
  pretty (LogMirrorFailed String
mirror SomeException
ex) =
      String
"Exception " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException SomeException
ex forall a. [a] -> [a] -> [a]
++ String
" when using mirror " forall a. [a] -> [a] -> [a]
++ String
mirror
  pretty (LogLockWait Path Absolute
file) =
      String
"Waiting to acquire cache lock on " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty Path Absolute
file
  pretty (LogLockWaitDone Path Absolute
file) =
      String
"Acquired cache lock on " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty Path Absolute
file
  pretty (LogUnlock Path Absolute
file) =
      String
"Released cache lock on " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
pretty Path Absolute
file

instance Pretty UpdateFailure where
  pretty :: UpdateFailure -> String
pretty UpdateFailure
UpdateImpossibleUnsupported =
      String
"server does not provide incremental downloads"
  pretty UpdateFailure
UpdateImpossibleNoLocalCopy =
      String
"no local copy"
  pretty UpdateFailure
UpdateFailedTwice =
      String
"update failed twice"
  pretty (UpdateFailed SomeException
ex) =
      forall e. Exception e => e -> String
displayException SomeException
ex