{-# LANGUAGE CPP #-}
-- | An implementation of Repository that talks to repositories over HTTP.
--
-- This implementation is itself parameterized over a 'HttpClient', so that it
-- it not tied to a specific library; for instance, 'HttpClient' can be
-- implemented with the @HTTP@ library, the @http-client@ libary, or others.
--
-- It would also be possible to give _other_ Repository implementations that
-- talk to repositories over HTTP, if you want to make other design decisions
-- than we did here, in particular:
--
-- * We attempt to do incremental downloads of the index when possible.
-- * We reuse the "Repository.Local"  to deal with the local cache.
-- * We download @timestamp.json@ and @snapshot.json@ together. This is
--   implemented here because:
--   - One level down (HttpClient) we have no access to the local cache
--   - One level up (Repository API) would require _all_ Repositories to
--     implement this optimization.
module Hackage.Security.Client.Repository.Remote (
    -- * Top-level API
    withRepository
  , RepoOpts(..)
  , defaultRepoOpts
  , RemoteTemp
     -- * File sizes
  , FileSize(..)
  , fileSizeWithinBounds
  ) where

import MyPrelude
import Control.Concurrent
import Control.Exception
import Control.Monad (when, unless)
import Control.Monad.IO.Class (MonadIO)
import Data.List (nub, intercalate)
import Data.Typeable
import Network.URI hiding (uriPath, path)
import System.IO ()
import qualified Data.ByteString      as BS
import qualified Data.ByteString.Lazy as BS.L

import Hackage.Security.Client.Formats
import Hackage.Security.Client.Repository
import Hackage.Security.Client.Repository.Cache (Cache)
import Hackage.Security.Client.Repository.HttpLib
import Hackage.Security.Client.Verify
import Hackage.Security.Trusted
import Hackage.Security.TUF
import Hackage.Security.Util.Checked
import Hackage.Security.Util.IO
import Hackage.Security.Util.Path
import Hackage.Security.Util.Pretty
import Hackage.Security.Util.Some
import Hackage.Security.Util.Exit
import qualified Hackage.Security.Client.Repository.Cache as Cache

{-------------------------------------------------------------------------------
  Server capabilities
-------------------------------------------------------------------------------}

-- | Server capabilities
--
-- As the library interacts with the server and receives replies, we may
-- discover more information about the server's capabilities; for instance,
-- we may discover that it supports incremental downloads.
newtype ServerCapabilities = SC (MVar ServerCapabilities_)

-- | Internal type recording the various server capabilities we support
data ServerCapabilities_ = ServerCapabilities {
      -- | Does the server support range requests?
      ServerCapabilities_ -> Bool
serverAcceptRangesBytes :: Bool
    }

newServerCapabilities :: IO ServerCapabilities
newServerCapabilities :: IO ServerCapabilities
newServerCapabilities = MVar ServerCapabilities_ -> ServerCapabilities
SC (MVar ServerCapabilities_ -> ServerCapabilities)
-> IO (MVar ServerCapabilities_) -> IO ServerCapabilities
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ServerCapabilities_ -> IO (MVar ServerCapabilities_)
forall a. a -> IO (MVar a)
newMVar ServerCapabilities {
      serverAcceptRangesBytes :: Bool
serverAcceptRangesBytes      = Bool
False
    }

updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities (SC MVar ServerCapabilities_
mv) [HttpResponseHeader]
responseHeaders = MVar ServerCapabilities_
-> (ServerCapabilities_ -> IO ServerCapabilities_) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ServerCapabilities_
mv ((ServerCapabilities_ -> IO ServerCapabilities_) -> IO ())
-> (ServerCapabilities_ -> IO ServerCapabilities_) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ServerCapabilities_
caps ->
    ServerCapabilities_ -> IO ServerCapabilities_
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerCapabilities_ -> IO ServerCapabilities_)
-> ServerCapabilities_ -> IO ServerCapabilities_
forall a b. (a -> b) -> a -> b
$ ServerCapabilities_
caps {
        serverAcceptRangesBytes = serverAcceptRangesBytes caps
          || HttpResponseAcceptRangesBytes `elem` responseHeaders
      }

checkServerCapability :: MonadIO m
                      => ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability :: forall (m :: * -> *) a.
MonadIO m =>
ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability (SC MVar ServerCapabilities_
mv) ServerCapabilities_ -> a
f = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar ServerCapabilities_ -> (ServerCapabilities_ -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ServerCapabilities_
mv ((ServerCapabilities_ -> IO a) -> IO a)
-> (ServerCapabilities_ -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a)
-> (ServerCapabilities_ -> a) -> ServerCapabilities_ -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerCapabilities_ -> a
f

{-------------------------------------------------------------------------------
  File size
-------------------------------------------------------------------------------}

data FileSize =
    -- | For most files we download we know the exact size beforehand
    -- (because this information comes from the snapshot or delegated info)
    FileSizeExact Int54

    -- | For some files we might not know the size beforehand, but we might
    -- be able to provide an upper bound (timestamp, root info)
  | FileSizeBound Int54
  deriving Int -> FileSize -> ShowS
[FileSize] -> ShowS
FileSize -> String
(Int -> FileSize -> ShowS)
-> (FileSize -> String) -> ([FileSize] -> ShowS) -> Show FileSize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileSize -> ShowS
showsPrec :: Int -> FileSize -> ShowS
$cshow :: FileSize -> String
show :: FileSize -> String
$cshowList :: [FileSize] -> ShowS
showList :: [FileSize] -> ShowS
Show

fileSizeWithinBounds :: Int54 -> FileSize -> Bool
fileSizeWithinBounds :: Int54 -> FileSize -> Bool
fileSizeWithinBounds Int54
sz (FileSizeExact Int54
sz') = Int54
sz Int54 -> Int54 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int54
sz'
fileSizeWithinBounds Int54
sz (FileSizeBound Int54
sz') = Int54
sz Int54 -> Int54 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int54
sz'

{-------------------------------------------------------------------------------
  Top-level API
-------------------------------------------------------------------------------}

-- | Repository options with a reasonable default
--
-- Clients should use 'defaultRepositoryOpts' and override required settings.
data RepoOpts = RepoOpts {
      -- | Allow additional mirrors?
      --
      -- If this is set to True (default), in addition to the (out-of-band)
      -- specified mirrors we will also use mirrors reported by those
      -- out-of-band mirrors (that is, @mirrors.json@).
      RepoOpts -> Bool
repoAllowAdditionalMirrors :: Bool
    }

-- | Default repository options
defaultRepoOpts :: RepoOpts
defaultRepoOpts :: RepoOpts
defaultRepoOpts = RepoOpts {
      repoAllowAdditionalMirrors :: Bool
repoAllowAdditionalMirrors = Bool
True
    }

-- | Initialize the repository (and cleanup resources afterwards)
--
-- We allow to specify multiple mirrors to initialize the repository. These
-- are mirrors that can be found "out of band" (out of the scope of the TUF
-- protocol), for example in a @cabal.config@ file. The TUF protocol itself
-- will specify that any of these mirrors can serve a @mirrors.json@ file
-- that itself contains mirrors; we consider these as _additional_ mirrors
-- to the ones that are passed here.
--
-- NOTE: The list of mirrors should be non-empty (and should typically include
-- the primary server).
--
-- TODO: In the future we could allow finer control over precisely which
-- mirrors we use (which combination of the mirrors that are passed as arguments
-- here and the mirrors that we get from @mirrors.json@) as well as indicating
-- mirror preferences.
withRepository
  :: HttpLib                          -- ^ Implementation of the HTTP protocol
  -> [URI]                            -- ^ "Out of band" list of mirrors
  -> RepoOpts                         -- ^ Repository options
  -> Cache                            -- ^ Location of local cache
  -> RepoLayout                       -- ^ Repository layout
  -> IndexLayout                      -- ^ Index layout
  -> (LogMessage -> IO ())            -- ^ Logger
  -> (Repository RemoteTemp -> IO a)  -- ^ Callback
  -> IO a
withRepository :: forall a.
HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
withRepository HttpLib
httpLib
               [URI]
outOfBandMirrors
               RepoOpts
repoOpts
               Cache
cache
               RepoLayout
repLayout
               IndexLayout
repIndexLayout
               LogMessage -> IO ()
logger
               Repository RemoteTemp -> IO a
callback
               = do
    MVar (Maybe URI)
selectedMirror <- Maybe URI -> IO (MVar (Maybe URI))
forall a. a -> IO (MVar a)
newMVar Maybe URI
forall a. Maybe a
Nothing
    ServerCapabilities
caps <- IO ServerCapabilities
newServerCapabilities
    let remoteConfig :: URI -> RemoteConfig
remoteConfig URI
mirror = RemoteConfig {
                                  cfgLayout :: RepoLayout
cfgLayout   = RepoLayout
repLayout
                                , cfgHttpLib :: HttpLib
cfgHttpLib  = HttpLib
httpLib
                                , cfgBase :: URI
cfgBase     = URI
mirror
                                , cfgCache :: Cache
cfgCache    = Cache
cache
                                , cfgCaps :: ServerCapabilities
cfgCaps     = ServerCapabilities
caps
                                , cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger   = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (LogMessage -> IO ()) -> LogMessage -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> IO ()
logger
                                , cfgOpts :: RepoOpts
cfgOpts     = RepoOpts
repoOpts
                                }
    Repository RemoteTemp -> IO a
callback Repository {
        repGetRemote :: forall fs typ.
Throws SomeRemoteError =>
AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
repGetRemote     = (URI -> RemoteConfig)
-> MVar (Maybe URI)
-> AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
forall fs typ.
Throws SomeRemoteError =>
(URI -> RemoteConfig)
-> MVar (Maybe URI)
-> AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getRemote URI -> RemoteConfig
remoteConfig MVar (Maybe URI)
selectedMirror
      , repGetCached :: CachedFile -> IO (Maybe (Path Absolute))
repGetCached     = Cache -> CachedFile -> IO (Maybe (Path Absolute))
Cache.getCached     Cache
cache
      , repGetCachedRoot :: IO (Path Absolute)
repGetCachedRoot = Cache -> IO (Path Absolute)
Cache.getCachedRoot Cache
cache
      , repClearCache :: IO ()
repClearCache    = Cache -> IO ()
Cache.clearCache    Cache
cache
      , repWithIndex :: forall a. (Handle -> IO a) -> IO a
repWithIndex     = Cache -> (Handle -> IO a) -> IO a
forall a. Cache -> (Handle -> IO a) -> IO a
Cache.withIndex     Cache
cache
      , repGetIndexIdx :: IO TarIndex
repGetIndexIdx   = Cache -> IO TarIndex
Cache.getIndexIdx   Cache
cache
      , repLockCache :: IO () -> IO ()
repLockCache     = (LogMessage -> IO ()) -> Cache -> IO () -> IO ()
Cache.lockCacheWithLogger LogMessage -> IO ()
logger Cache
cache
      , repWithMirror :: forall a. Maybe [Mirror] -> IO a -> IO a
repWithMirror    = HttpLib
-> MVar (Maybe URI)
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
forall a.
HttpLib
-> MVar (Maybe URI)
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
withMirror HttpLib
httpLib
                                      MVar (Maybe URI)
selectedMirror
                                      LogMessage -> IO ()
logger
                                      [URI]
outOfBandMirrors
                                      RepoOpts
repoOpts
      , repLog :: LogMessage -> IO ()
repLog           = LogMessage -> IO ()
logger
      , repLayout :: RepoLayout
repLayout        = RepoLayout
repLayout
      , repIndexLayout :: IndexLayout
repIndexLayout   = IndexLayout
repIndexLayout
      , repDescription :: String
repDescription   = String
"Remote repository at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [URI] -> String
forall a. Show a => a -> String
show [URI]
outOfBandMirrors
      }

{-------------------------------------------------------------------------------
  Implementations of the various methods of Repository
-------------------------------------------------------------------------------}

-- | We select a mirror in 'withMirror' (the implementation of 'repWithMirror').
-- Outside the scope of 'withMirror' no mirror is selected, and a call to
-- 'getRemote' will throw an exception. If this exception is ever thrown its
-- a bug: calls to 'getRemote' ('repGetRemote') should _always_ be in the
-- scope of 'repWithMirror'.
type SelectedMirror = MVar (Maybe URI)

-- | Get the selected mirror
--
-- Throws an exception if no mirror was selected (this would be a bug in the
-- client code).
--
-- NOTE: Cannot use 'withMVar' here, because the callback would be inside the
-- scope of the withMVar, and there might be further calls to 'withRemote' made
-- by the callback argument to 'withRemote', leading to deadlock.
getSelectedMirror :: SelectedMirror -> IO URI
getSelectedMirror :: MVar (Maybe URI) -> IO URI
getSelectedMirror MVar (Maybe URI)
selectedMirror = do
     Maybe URI
mBaseURI <- MVar (Maybe URI) -> IO (Maybe URI)
forall a. MVar a -> IO a
readMVar MVar (Maybe URI)
selectedMirror
     case Maybe URI
mBaseURI of
       Maybe URI
Nothing      -> String -> IO URI
forall a. String -> IO a
internalError String
"Internal error: no mirror selected"
       Just URI
baseURI -> URI -> IO URI
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return URI
baseURI

-- | Get a file from the server
getRemote :: Throws SomeRemoteError
          => (URI -> RemoteConfig)
          -> SelectedMirror
          -> AttemptNr
          -> RemoteFile fs typ
          -> Verify (Some (HasFormat fs), RemoteTemp typ)
getRemote :: forall fs typ.
Throws SomeRemoteError =>
(URI -> RemoteConfig)
-> MVar (Maybe URI)
-> AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getRemote URI -> RemoteConfig
remoteConfig MVar (Maybe URI)
selectedMirror AttemptNr
attemptNr RemoteFile fs typ
remoteFile = do
    URI
baseURI <- IO URI -> Verify URI
forall a. IO a -> Verify a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO URI -> Verify URI) -> IO URI -> Verify URI
forall a b. (a -> b) -> a -> b
$ MVar (Maybe URI) -> IO URI
getSelectedMirror MVar (Maybe URI)
selectedMirror
    let cfg :: RemoteConfig
cfg = URI -> RemoteConfig
remoteConfig URI
baseURI
    DownloadMethod fs typ
downloadMethod <- IO (DownloadMethod fs typ) -> Verify (DownloadMethod fs typ)
forall a. IO a -> Verify a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DownloadMethod fs typ) -> Verify (DownloadMethod fs typ))
-> IO (DownloadMethod fs typ) -> Verify (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ RemoteConfig
-> AttemptNr -> RemoteFile fs typ -> IO (DownloadMethod fs typ)
forall fs typ.
RemoteConfig
-> AttemptNr -> RemoteFile fs typ -> IO (DownloadMethod fs typ)
pickDownloadMethod RemoteConfig
cfg AttemptNr
attemptNr RemoteFile fs typ
remoteFile
    RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
forall fs typ.
Throws SomeRemoteError =>
RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getFile RemoteConfig
cfg AttemptNr
attemptNr RemoteFile fs typ
remoteFile DownloadMethod fs typ
downloadMethod

-- | HTTP options
--
-- We want to make sure caches don't transform files in any way (as this will
-- mess things up with respect to hashes etc). Additionally, after a validation
-- error we want to make sure caches get files upstream in case the validation
-- error was because the cache updated files out of order.
httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader]
httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader]
httpRequestHeaders RemoteConfig{URI
RepoLayout
HttpLib
Cache
RepoOpts
ServerCapabilities
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLayout :: RemoteConfig -> RepoLayout
cfgHttpLib :: RemoteConfig -> HttpLib
cfgBase :: RemoteConfig -> URI
cfgCache :: RemoteConfig -> Cache
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RemoteConfig -> RepoOpts
cfgLayout :: RepoLayout
cfgHttpLib :: HttpLib
cfgBase :: URI
cfgCache :: Cache
cfgCaps :: ServerCapabilities
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RepoOpts
..} AttemptNr
attemptNr =
    if AttemptNr
attemptNr AttemptNr -> AttemptNr -> Bool
forall a. Eq a => a -> a -> Bool
== AttemptNr
0 then [HttpRequestHeader]
defaultHeaders
                      else HttpRequestHeader
HttpRequestMaxAge0 HttpRequestHeader -> [HttpRequestHeader] -> [HttpRequestHeader]
forall a. a -> [a] -> [a]
: [HttpRequestHeader]
defaultHeaders
  where
    -- Headers we provide for _every_ attempt, first or not
    defaultHeaders :: [HttpRequestHeader]
    defaultHeaders :: [HttpRequestHeader]
defaultHeaders = [HttpRequestHeader
HttpRequestNoTransform]

-- | Mirror selection
withMirror :: forall a.
              HttpLib                -- ^ HTTP client
           -> SelectedMirror         -- ^ MVar indicating currently mirror
           -> (LogMessage -> IO ())  -- ^ Logger
           -> [URI]                  -- ^ Out-of-band mirrors
           -> RepoOpts               -- ^ Repository options
           -> Maybe [Mirror]         -- ^ TUF mirrors
           -> IO a                   -- ^ Callback
           -> IO a
withMirror :: forall a.
HttpLib
-> MVar (Maybe URI)
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
withMirror HttpLib{forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange :: HttpLib
-> forall a.
   Throws SomeRemoteError =>
   [HttpRequestHeader]
   -> URI
   -> (Int, Int)
   -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
   -> IO a
httpGet :: HttpLib
-> forall a.
   Throws SomeRemoteError =>
   [HttpRequestHeader]
   -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
..}
           MVar (Maybe URI)
selectedMirror
           LogMessage -> IO ()
logger
           [URI]
oobMirrors
           RepoOpts
repoOpts
           Maybe [Mirror]
tufMirrors
           IO a
callback
           =
    [URI] -> IO a
go [URI]
orderedMirrors
  where
    go :: [URI] -> IO a
    -- Empty list of mirrors is a bug
    go :: [URI] -> IO a
go [] = String -> IO a
forall a. String -> IO a
internalError String
"No mirrors configured"
    -- If we only have a single mirror left, let exceptions be thrown up
    go [URI
m] = do
      LogMessage -> IO ()
logger (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LogMessage
LogSelectedMirror (URI -> String
forall a. Show a => a -> String
show URI
m)
      URI -> IO a -> IO a
select URI
m (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IO a
callback
    -- Otherwise, catch exceptions and if any were thrown, try with different
    -- mirror
    go (URI
m:[URI]
ms) = do
      LogMessage -> IO ()
logger (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> LogMessage
LogSelectedMirror (URI -> String
forall a. Show a => a -> String
show URI
m)
      (Throws SomeException => IO a) -> (SomeException -> IO a) -> IO a
forall a e.
Exception e =>
(Throws e => IO a) -> (e -> IO a) -> IO a
catchChecked (URI -> IO a -> IO a
select URI
m IO a
callback) ((SomeException -> IO a) -> IO a)
-> (SomeException -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> do
        LogMessage -> IO ()
logger (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SomeException -> LogMessage
LogMirrorFailed (URI -> String
forall a. Show a => a -> String
show URI
m) SomeException
ex
        [URI] -> IO a
go [URI]
ms

    -- TODO: We will want to make the construction of this list configurable.
    orderedMirrors :: [URI]
    orderedMirrors :: [URI]
orderedMirrors = [URI] -> [URI]
forall a. Eq a => [a] -> [a]
nub ([URI] -> [URI]) -> [URI] -> [URI]
forall a b. (a -> b) -> a -> b
$ [[URI]] -> [URI]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        [URI]
oobMirrors
      , if RepoOpts -> Bool
repoAllowAdditionalMirrors RepoOpts
repoOpts
          then [URI] -> ([Mirror] -> [URI]) -> Maybe [Mirror] -> [URI]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Mirror -> URI) -> [Mirror] -> [URI]
forall a b. (a -> b) -> [a] -> [b]
map Mirror -> URI
mirrorUrlBase) Maybe [Mirror]
tufMirrors
          else []
      ]

    select :: URI -> IO a -> IO a
    select :: URI -> IO a -> IO a
select URI
uri =
      IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (MVar (Maybe URI) -> (Maybe URI -> IO (Maybe URI)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe URI)
selectedMirror ((Maybe URI -> IO (Maybe URI)) -> IO ())
-> (Maybe URI -> IO (Maybe URI)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe URI
_ -> Maybe URI -> IO (Maybe URI)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URI -> IO (Maybe URI)) -> Maybe URI -> IO (Maybe URI)
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URI
forall a. a -> Maybe a
Just URI
uri)
               (MVar (Maybe URI) -> (Maybe URI -> IO (Maybe URI)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe URI)
selectedMirror ((Maybe URI -> IO (Maybe URI)) -> IO ())
-> (Maybe URI -> IO (Maybe URI)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe URI
_ -> Maybe URI -> IO (Maybe URI)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe URI
forall a. Maybe a
Nothing)

{-------------------------------------------------------------------------------
  Download methods
-------------------------------------------------------------------------------}

-- | Download method (downloading or updating)
data DownloadMethod :: * -> * -> * where
    -- Download this file (we never attempt to update this type of file)
    NeverUpdated :: {
        ()
neverUpdatedFormat :: HasFormat fs f
      } -> DownloadMethod fs typ

    -- Download this file (we cannot update this file right now)
    CannotUpdate :: {
        ()
cannotUpdateFormat :: HasFormat fs f
      , forall fs. DownloadMethod fs Binary -> UpdateFailure
cannotUpdateReason :: UpdateFailure
      } -> DownloadMethod fs Binary

    -- Attempt an (incremental) update of this file
    Update :: {
        ()
updateFormat :: HasFormat fs f
      , forall fs. DownloadMethod fs Binary -> Trusted FileInfo
updateInfo   :: Trusted FileInfo
      , forall fs. DownloadMethod fs Binary -> Path Absolute
updateLocal  :: Path Absolute
      , forall fs. DownloadMethod fs Binary -> Int54
updateTail   :: Int54
      } -> DownloadMethod fs Binary
--TODO: ^^ older haddock doesn't support GADT doc comments :-(

pickDownloadMethod :: forall fs typ. RemoteConfig
                   -> AttemptNr
                   -> RemoteFile fs typ
                   -> IO (DownloadMethod fs typ)
pickDownloadMethod :: forall fs typ.
RemoteConfig
-> AttemptNr -> RemoteFile fs typ -> IO (DownloadMethod fs typ)
pickDownloadMethod RemoteConfig{URI
RepoLayout
HttpLib
Cache
RepoOpts
ServerCapabilities
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLayout :: RemoteConfig -> RepoLayout
cfgHttpLib :: RemoteConfig -> HttpLib
cfgBase :: RemoteConfig -> URI
cfgCache :: RemoteConfig -> Cache
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RemoteConfig -> RepoOpts
cfgLayout :: RepoLayout
cfgHttpLib :: HttpLib
cfgBase :: URI
cfgCache :: Cache
cfgCaps :: ServerCapabilities
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RepoOpts
..} AttemptNr
attemptNr RemoteFile fs typ
remoteFile =
    case RemoteFile fs typ
remoteFile of
      RemoteFile fs typ
RemoteTimestamp        -> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod fs typ -> IO (DownloadMethod fs typ))
-> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatUn -> DownloadMethod fs typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall b fs. Format b -> HasFormat (b :- fs) b
HFZ Format FormatUn
FUn)
      (RemoteRoot Maybe (Trusted FileInfo)
_)         -> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod fs typ -> IO (DownloadMethod fs typ))
-> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatUn -> DownloadMethod fs typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall b fs. Format b -> HasFormat (b :- fs) b
HFZ Format FormatUn
FUn)
      (RemoteSnapshot Trusted FileInfo
_)     -> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod fs typ -> IO (DownloadMethod fs typ))
-> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatUn -> DownloadMethod fs typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall b fs. Format b -> HasFormat (b :- fs) b
HFZ Format FormatUn
FUn)
      (RemoteMirrors Trusted FileInfo
_)      -> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod fs typ -> IO (DownloadMethod fs typ))
-> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatUn -> DownloadMethod fs typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall b fs. Format b -> HasFormat (b :- fs) b
HFZ Format FormatUn
FUn)
      (RemotePkgTarGz PackageIdentifier
_ Trusted FileInfo
_)   -> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod fs typ -> IO (DownloadMethod fs typ))
-> DownloadMethod fs typ -> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatGz -> DownloadMethod fs typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatGz -> HasFormat (FormatGz :- ()) FormatGz
forall b fs. Format b -> HasFormat (b :- fs) b
HFZ Format FormatGz
FGz)
      (RemoteIndex HasFormat fs FormatGz
hasGz Formats fs (Trusted FileInfo)
formats) -> ExceptT (DownloadMethod fs typ) IO (DownloadMethod fs typ)
-> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => ExceptT a m a -> m a
multipleExitPoints (ExceptT (DownloadMethod fs typ) IO (DownloadMethod fs typ)
 -> IO (DownloadMethod fs typ))
-> ExceptT (DownloadMethod fs typ) IO (DownloadMethod fs typ)
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ do
        -- Server must support @Range@ with a byte-range
        Bool
rangeSupport <- ServerCapabilities
-> (ServerCapabilities_ -> Bool)
-> ExceptT (DownloadMethod fs typ) IO Bool
forall (m :: * -> *) a.
MonadIO m =>
ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability ServerCapabilities
cfgCaps ServerCapabilities_ -> Bool
serverAcceptRangesBytes
        Bool
-> ExceptT (DownloadMethod fs typ) IO ()
-> ExceptT (DownloadMethod fs typ) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
rangeSupport (ExceptT (DownloadMethod fs typ) IO ()
 -> ExceptT (DownloadMethod fs typ) IO ())
-> ExceptT (DownloadMethod fs typ) IO ()
-> ExceptT (DownloadMethod fs typ) IO ()
forall a b. (a -> b) -> a -> b
$ DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ())
-> DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ()
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatGz -> UpdateFailure -> DownloadMethod fs Binary
forall fs f.
HasFormat fs f -> UpdateFailure -> DownloadMethod fs Binary
CannotUpdate HasFormat fs FormatGz
hasGz UpdateFailure
UpdateImpossibleUnsupported

        -- We must already have a local file to be updated
        Maybe (Path Absolute)
mCachedIndex <- IO (Maybe (Path Absolute))
-> ExceptT (DownloadMethod fs typ) IO (Maybe (Path Absolute))
forall a. IO a -> ExceptT (DownloadMethod fs typ) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Path Absolute))
 -> ExceptT (DownloadMethod fs typ) IO (Maybe (Path Absolute)))
-> IO (Maybe (Path Absolute))
-> ExceptT (DownloadMethod fs typ) IO (Maybe (Path Absolute))
forall a b. (a -> b) -> a -> b
$ Cache -> Format FormatGz -> IO (Maybe (Path Absolute))
forall f. Cache -> Format f -> IO (Maybe (Path Absolute))
Cache.getCachedIndex Cache
cfgCache (HasFormat fs FormatGz -> Format FormatGz
forall fs f. HasFormat fs f -> Format f
hasFormatGet HasFormat fs FormatGz
hasGz)
        Path Absolute
cachedIndex  <- case Maybe (Path Absolute)
mCachedIndex of
          Maybe (Path Absolute)
Nothing -> DownloadMethod fs typ
-> ExceptT (DownloadMethod fs typ) IO (Path Absolute)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs typ
 -> ExceptT (DownloadMethod fs typ) IO (Path Absolute))
-> DownloadMethod fs typ
-> ExceptT (DownloadMethod fs typ) IO (Path Absolute)
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatGz -> UpdateFailure -> DownloadMethod fs Binary
forall fs f.
HasFormat fs f -> UpdateFailure -> DownloadMethod fs Binary
CannotUpdate HasFormat fs FormatGz
hasGz UpdateFailure
UpdateImpossibleNoLocalCopy
          Just Path Absolute
fp -> Path Absolute -> ExceptT (DownloadMethod fs typ) IO (Path Absolute)
forall a. a -> ExceptT (DownloadMethod fs typ) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Path Absolute
fp

        -- We attempt an incremental update a maximum of 2 times
        -- See 'UpdateFailedTwice' for details.
        Bool
-> ExceptT (DownloadMethod fs typ) IO ()
-> ExceptT (DownloadMethod fs typ) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AttemptNr
attemptNr AttemptNr -> AttemptNr -> Bool
forall a. Ord a => a -> a -> Bool
>= AttemptNr
2) (ExceptT (DownloadMethod fs typ) IO ()
 -> ExceptT (DownloadMethod fs typ) IO ())
-> ExceptT (DownloadMethod fs typ) IO ()
-> ExceptT (DownloadMethod fs typ) IO ()
forall a b. (a -> b) -> a -> b
$ DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ())
-> DownloadMethod fs typ -> ExceptT (DownloadMethod fs typ) IO ()
forall a b. (a -> b) -> a -> b
$ HasFormat fs FormatGz -> UpdateFailure -> DownloadMethod fs Binary
forall fs f.
HasFormat fs f -> UpdateFailure -> DownloadMethod fs Binary
CannotUpdate HasFormat fs FormatGz
hasGz UpdateFailure
UpdateFailedTwice

        -- If all these checks pass try to do an incremental update.
        DownloadMethod fs typ
-> ExceptT (DownloadMethod fs typ) IO (DownloadMethod fs typ)
forall a. a -> ExceptT (DownloadMethod fs typ) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Update {
             updateFormat :: HasFormat fs FormatGz
updateFormat = HasFormat fs FormatGz
hasGz
           , updateInfo :: Trusted FileInfo
updateInfo   = HasFormat fs FormatGz
-> Formats fs (Trusted FileInfo) -> Trusted FileInfo
forall fs f a. HasFormat fs f -> Formats fs a -> a
formatsLookup HasFormat fs FormatGz
hasGz Formats fs (Trusted FileInfo)
formats
           , updateLocal :: Path Absolute
updateLocal  = Path Absolute
cachedIndex
           , updateTail :: Int54
updateTail   = Int54
65536 -- max gzip block size
           }

-- | Download the specified file using the given download method
getFile :: forall fs typ. Throws SomeRemoteError
        => RemoteConfig          -- ^ Internal configuration
        -> AttemptNr             -- ^ Did a security check previously fail?
        -> RemoteFile fs typ     -- ^ File to get
        -> DownloadMethod fs typ -- ^ Selected format
        -> Verify (Some (HasFormat fs), RemoteTemp typ)
getFile :: forall fs typ.
Throws SomeRemoteError =>
RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getFile cfg :: RemoteConfig
cfg@RemoteConfig{URI
RepoLayout
HttpLib
Cache
RepoOpts
ServerCapabilities
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLayout :: RemoteConfig -> RepoLayout
cfgHttpLib :: RemoteConfig -> HttpLib
cfgBase :: RemoteConfig -> URI
cfgCache :: RemoteConfig -> Cache
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RemoteConfig -> RepoOpts
cfgLayout :: RepoLayout
cfgHttpLib :: HttpLib
cfgBase :: URI
cfgCache :: Cache
cfgCaps :: ServerCapabilities
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgOpts :: RepoOpts
..} AttemptNr
attemptNr RemoteFile fs typ
remoteFile DownloadMethod fs typ
method =
    DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
go DownloadMethod fs typ
method
  where
    go :: DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
    go :: DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
go NeverUpdated{HasFormat fs f
neverUpdatedFormat :: ()
neverUpdatedFormat :: HasFormat fs f
..} = do
        LogMessage -> Verify ()
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger (LogMessage -> Verify ()) -> LogMessage -> Verify ()
forall a b. (a -> b) -> a -> b
$ RemoteFile fs typ -> LogMessage
forall fs typ. RemoteFile fs typ -> LogMessage
LogDownloading RemoteFile fs typ
remoteFile
        HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
forall f.
HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download HasFormat fs f
neverUpdatedFormat
    go CannotUpdate{HasFormat fs f
UpdateFailure
cannotUpdateFormat :: ()
cannotUpdateReason :: forall fs. DownloadMethod fs Binary -> UpdateFailure
cannotUpdateFormat :: HasFormat fs f
cannotUpdateReason :: UpdateFailure
..} = do
        LogMessage -> Verify ()
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger (LogMessage -> Verify ()) -> LogMessage -> Verify ()
forall a b. (a -> b) -> a -> b
$ RemoteFile fs Binary -> UpdateFailure -> LogMessage
forall fs. RemoteFile fs Binary -> UpdateFailure -> LogMessage
LogCannotUpdate RemoteFile fs typ
RemoteFile fs Binary
remoteFile UpdateFailure
cannotUpdateReason
        LogMessage -> Verify ()
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger (LogMessage -> Verify ()) -> LogMessage -> Verify ()
forall a b. (a -> b) -> a -> b
$ RemoteFile fs typ -> LogMessage
forall fs typ. RemoteFile fs typ -> LogMessage
LogDownloading RemoteFile fs typ
remoteFile
        HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
forall f.
HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download HasFormat fs f
cannotUpdateFormat
    go Update{Path Absolute
HasFormat fs f
Int54
Trusted FileInfo
updateFormat :: ()
updateInfo :: forall fs. DownloadMethod fs Binary -> Trusted FileInfo
updateLocal :: forall fs. DownloadMethod fs Binary -> Path Absolute
updateTail :: forall fs. DownloadMethod fs Binary -> Int54
updateFormat :: HasFormat fs f
updateInfo :: Trusted FileInfo
updateLocal :: Path Absolute
updateTail :: Int54
..} = do
        LogMessage -> Verify ()
forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger (LogMessage -> Verify ()) -> LogMessage -> Verify ()
forall a b. (a -> b) -> a -> b
$ RemoteFile fs Binary -> LogMessage
forall fs. RemoteFile fs Binary -> LogMessage
LogUpdating RemoteFile fs typ
RemoteFile fs Binary
remoteFile
        HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> Verify (Some (HasFormat fs), RemoteTemp typ)
forall f.
(typ ~ Binary) =>
HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> Verify (Some (HasFormat fs), RemoteTemp typ)
update HasFormat fs f
updateFormat Trusted FileInfo
updateInfo Path Absolute
updateLocal Int54
updateTail

    headers :: [HttpRequestHeader]
    headers :: [HttpRequestHeader]
headers = RemoteConfig -> AttemptNr -> [HttpRequestHeader]
httpRequestHeaders RemoteConfig
cfg AttemptNr
attemptNr

    -- Get any file from the server, without using incremental updates
    download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
    download :: forall f.
HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download HasFormat fs f
format = do
        (Path Absolute
tempPath, Handle
h) <- Path Absolute -> String -> Verify (Path Absolute, Handle)
forall root.
FsRoot root =>
Path root -> String -> Verify (Path Absolute, Handle)
openTempFile (Cache -> Path Absolute
Cache.cacheRoot Cache
cfgCache) (URI -> String
uriTemplate URI
uri)
        IO () -> Verify ()
forall a. IO a -> Verify a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Verify ()) -> IO () -> Verify ()
forall a b. (a -> b) -> a -> b
$ do
          [HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO ()) -> IO ()
forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet [HttpRequestHeader]
headers URI
uri (([HttpResponseHeader] -> BodyReader -> IO ()) -> IO ())
-> ([HttpResponseHeader] -> BodyReader -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[HttpResponseHeader]
responseHeaders BodyReader
bodyReader -> do
            ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities ServerCapabilities
cfgCaps [HttpResponseHeader]
responseHeaders
            Throws SomeRemoteError =>
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
execBodyReader TargetPath
targetPath FileSize
sz Handle
h BodyReader
bodyReader
          Handle -> IO ()
hClose Handle
h
        HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
forall f.
HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified HasFormat fs f
format (RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ))
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
forall a b. (a -> b) -> a -> b
$ Path Absolute -> RemoteTemp typ
forall a. Path Absolute -> RemoteTemp a
DownloadedWhole Path Absolute
tempPath
      where
        targetPath :: TargetPath
targetPath = RepoPath -> TargetPath
TargetPathRepo (RepoPath -> TargetPath) -> RepoPath -> TargetPath
forall a b. (a -> b) -> a -> b
$ RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
forall fs typ f.
RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
remoteRepoPath' RepoLayout
cfgLayout RemoteFile fs typ
remoteFile HasFormat fs f
format
        uri :: URI
uri = HasFormat fs f -> Formats fs URI -> URI
forall fs f a. HasFormat fs f -> Formats fs a -> a
formatsLookup HasFormat fs f
format (Formats fs URI -> URI) -> Formats fs URI -> URI
forall a b. (a -> b) -> a -> b
$ RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
forall fs typ.
RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI RepoLayout
cfgLayout URI
cfgBase RemoteFile fs typ
remoteFile
        sz :: FileSize
sz  = HasFormat fs f -> Formats fs FileSize -> FileSize
forall fs f a. HasFormat fs f -> Formats fs a -> a
formatsLookup HasFormat fs f
format (Formats fs FileSize -> FileSize)
-> Formats fs FileSize -> FileSize
forall a b. (a -> b) -> a -> b
$ RemoteFile fs typ -> Formats fs FileSize
forall fs typ. RemoteFile fs typ -> Formats fs FileSize
remoteFileSize RemoteFile fs typ
remoteFile

    -- Get a file incrementally
    update :: (typ ~ Binary)
           => HasFormat fs f    -- ^ Selected format
           -> Trusted FileInfo  -- ^ Expected info
           -> Path Absolute     -- ^ Location of cached file (after callback)
           -> Int54             -- ^ How much of the tail to overwrite
           -> Verify (Some (HasFormat fs), RemoteTemp typ)
    update :: forall f.
(typ ~ Binary) =>
HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> Verify (Some (HasFormat fs), RemoteTemp typ)
update HasFormat fs f
format Trusted FileInfo
info Path Absolute
cachedFile Int54
fileTail = do
        Int54
currentSz <- IO Int54 -> Verify Int54
forall a. IO a -> Verify a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int54 -> Verify Int54) -> IO Int54 -> Verify Int54
forall a b. (a -> b) -> a -> b
$ Path Absolute -> IO Int54
forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
cachedFile
        let fileSz :: Int54
fileSz    = Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
info
            range :: (Int54, Int54)
range     = (Int54
0 Int54 -> Int54 -> Int54
forall a. Ord a => a -> a -> a
`max` (Int54
currentSz Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
- Int54
fileTail), Int54
fileSz)
            range' :: (Int, Int)
range'    = (Int54 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int54, Int54) -> Int54
forall a b. (a, b) -> a
fst (Int54, Int54)
range), Int54 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int54, Int54) -> Int54
forall a b. (a, b) -> b
snd (Int54, Int54)
range))
            cacheRoot :: Path Absolute
cacheRoot = Cache -> Path Absolute
Cache.cacheRoot Cache
cfgCache
        (Path Absolute
tempPath, Handle
h) <- Path Absolute -> String -> Verify (Path Absolute, Handle)
forall root.
FsRoot root =>
Path root -> String -> Verify (Path Absolute, Handle)
openTempFile Path Absolute
cacheRoot (URI -> String
uriTemplate URI
uri)
        HttpStatus
statusCode <- IO HttpStatus -> Verify HttpStatus
forall a. IO a -> Verify a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HttpStatus -> Verify HttpStatus)
-> IO HttpStatus -> Verify HttpStatus
forall a b. (a -> b) -> a -> b
$
          [HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus
    -> [HttpResponseHeader] -> BodyReader -> IO HttpStatus)
-> IO HttpStatus
forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange [HttpRequestHeader]
headers URI
uri (Int, Int)
range' ((HttpStatus
  -> [HttpResponseHeader] -> BodyReader -> IO HttpStatus)
 -> IO HttpStatus)
-> (HttpStatus
    -> [HttpResponseHeader] -> BodyReader -> IO HttpStatus)
-> IO HttpStatus
forall a b. (a -> b) -> a -> b
$ \HttpStatus
statusCode [HttpResponseHeader]
responseHeaders BodyReader
bodyReader -> do
            ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities ServerCapabilities
cfgCaps [HttpResponseHeader]
responseHeaders
            let expectedSize :: FileSize
expectedSize =
                  case HttpStatus
statusCode of
                    HttpStatus
HttpStatus206PartialContent ->
                      Int54 -> FileSize
FileSizeExact ((Int54, Int54) -> Int54
forall a b. (a, b) -> b
snd (Int54, Int54)
range Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
- (Int54, Int54) -> Int54
forall a b. (a, b) -> a
fst (Int54, Int54)
range)
                    HttpStatus
HttpStatus200OK ->
                      Int54 -> FileSize
FileSizeExact Int54
fileSz
            Throws SomeRemoteError =>
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
execBodyReader TargetPath
targetPath FileSize
expectedSize Handle
h BodyReader
bodyReader
            Handle -> IO ()
hClose Handle
h
            HttpStatus -> IO HttpStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HttpStatus
statusCode
        let downloaded :: RemoteTemp Binary
downloaded =
              case HttpStatus
statusCode of
                HttpStatus
HttpStatus206PartialContent ->
                  DownloadedDelta {
                      deltaTemp :: Path Absolute
deltaTemp     = Path Absolute
tempPath
                    , deltaExisting :: Path Absolute
deltaExisting = Path Absolute
cachedFile
                    , deltaSeek :: Int54
deltaSeek     = (Int54, Int54) -> Int54
forall a b. (a, b) -> a
fst (Int54, Int54)
range
                    }
                HttpStatus
HttpStatus200OK ->
                  Path Absolute -> RemoteTemp Binary
forall a. Path Absolute -> RemoteTemp a
DownloadedWhole Path Absolute
tempPath
        HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
forall f.
HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified HasFormat fs f
format RemoteTemp typ
RemoteTemp Binary
downloaded
      where
        targetPath :: TargetPath
targetPath = RepoPath -> TargetPath
TargetPathRepo RepoPath
repoPath
        uri :: URI
uri        = URI -> (Path Web -> Path Web) -> URI
modifyUriPath URI
cfgBase (Path Web -> RepoPath -> Path Web
`anchorRepoPathRemotely` RepoPath
repoPath)
        repoPath :: RepoPath
repoPath   = RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
forall fs typ f.
RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath
remoteRepoPath' RepoLayout
cfgLayout RemoteFile fs typ
remoteFile HasFormat fs f
format

    cacheIfVerified :: HasFormat fs f -> RemoteTemp typ
                    -> Verify (Some (HasFormat fs), RemoteTemp typ)
    cacheIfVerified :: forall f.
HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified HasFormat fs f
format RemoteTemp typ
remoteTemp = do
        IO () -> Verify ()
ifVerified (IO () -> Verify ()) -> IO () -> Verify ()
forall a b. (a -> b) -> a -> b
$
          Cache -> RemoteTemp typ -> Format f -> IsCached typ -> IO ()
forall (down :: * -> *) typ f.
DownloadedFile down =>
Cache -> down typ -> Format f -> IsCached typ -> IO ()
Cache.cacheRemoteFile Cache
cfgCache
                                RemoteTemp typ
remoteTemp
                                (HasFormat fs f -> Format f
forall fs f. HasFormat fs f -> Format f
hasFormatGet HasFormat fs f
format)
                                (RemoteFile fs typ -> IsCached typ
forall fs typ. RemoteFile fs typ -> IsCached typ
mustCache RemoteFile fs typ
remoteFile)
        (Some (HasFormat fs), RemoteTemp typ)
-> Verify (Some (HasFormat fs), RemoteTemp typ)
forall a. a -> Verify a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasFormat fs f -> Some (HasFormat fs)
forall (f :: * -> *) a. f a -> Some f
Some HasFormat fs f
format, RemoteTemp typ
remoteTemp)

    httpGetRange :: forall a. Throws SomeRemoteError
                 => [HttpRequestHeader]
                 -> URI
                 -> (Int, Int)
                 -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
                 -> IO a
    HttpLib{forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGetRange :: HttpLib
-> forall a.
   Throws SomeRemoteError =>
   [HttpRequestHeader]
   -> URI
   -> (Int, Int)
   -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
   -> IO a
httpGet :: HttpLib
-> forall a.
   Throws SomeRemoteError =>
   [HttpRequestHeader]
   -> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
..} = HttpLib
cfgHttpLib

{-------------------------------------------------------------------------------
  Execute body reader
-------------------------------------------------------------------------------}

-- | Execute a body reader
--
-- TODO: Deal with minimum download rate.
execBodyReader :: Throws SomeRemoteError
               => TargetPath  -- ^ File source (for error msgs only)
               -> FileSize    -- ^ Maximum file size
               -> Handle      -- ^ Handle to write data too
               -> BodyReader  -- ^ The action to give us blocks from the file
               -> IO ()
execBodyReader :: Throws SomeRemoteError =>
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
execBodyReader TargetPath
file FileSize
mlen Handle
h BodyReader
br = Int54 -> IO ()
go Int54
0
  where
    go :: Int54 -> IO ()
    go :: Int54 -> IO ()
go Int54
sz = do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int54
sz Int54 -> FileSize -> Bool
`fileSizeWithinBounds` FileSize
mlen) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        SomeRemoteError -> IO ()
forall e a. (Exception e, Throws e) => e -> IO a
throwChecked (SomeRemoteError -> IO ()) -> SomeRemoteError -> IO ()
forall a b. (a -> b) -> a -> b
$ FileTooLarge -> SomeRemoteError
forall e. Exception e => e -> SomeRemoteError
SomeRemoteError (FileTooLarge -> SomeRemoteError)
-> FileTooLarge -> SomeRemoteError
forall a b. (a -> b) -> a -> b
$ TargetPath -> FileSize -> FileTooLarge
FileTooLarge TargetPath
file FileSize
mlen
      ByteString
bs <- BodyReader
br
      if ByteString -> Bool
BS.null ByteString
bs
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int54 -> IO ()
go (Int54
sz Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
+ Int -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs))

-- | The file we requested from the server was larger than expected
-- (potential endless data attack)
data FileTooLarge = FileTooLarge {
    FileTooLarge -> TargetPath
fileTooLargePath     :: TargetPath
  , FileTooLarge -> FileSize
fileTooLargeExpected :: FileSize
  }
  deriving (Typeable)

instance Pretty FileTooLarge where
  pretty :: FileTooLarge -> String
pretty FileTooLarge{TargetPath
FileSize
fileTooLargePath :: FileTooLarge -> TargetPath
fileTooLargeExpected :: FileTooLarge -> FileSize
fileTooLargePath :: TargetPath
fileTooLargeExpected :: FileSize
..} = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      String
"file returned by server too large: "
    , TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
fileTooLargePath
    , String
" (expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FileSize -> String
expected FileSize
fileTooLargeExpected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)"
    ]
    where
      expected :: FileSize -> String
      expected :: FileSize -> String
expected (FileSizeExact Int54
n) = String
"exactly " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int54 -> String
forall a. Show a => a -> String
show Int54
n
      expected (FileSizeBound Int54
n) = String
"at most " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int54 -> String
forall a. Show a => a -> String
show Int54
n

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

{-------------------------------------------------------------------------------
  Information about remote files
-------------------------------------------------------------------------------}

remoteFileURI :: RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI :: forall fs typ.
RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI RepoLayout
repoLayout URI
baseURI = (RepoPath -> URI) -> Formats fs RepoPath -> Formats fs URI
forall a b. (a -> b) -> Formats fs a -> Formats fs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RepoPath -> URI
aux (Formats fs RepoPath -> Formats fs URI)
-> (RemoteFile fs typ -> Formats fs RepoPath)
-> RemoteFile fs typ
-> Formats fs URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath
forall fs typ.
RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath
remoteRepoPath RepoLayout
repoLayout
  where
    aux :: RepoPath -> URI
    aux :: RepoPath -> URI
aux RepoPath
repoPath = URI -> (Path Web -> Path Web) -> URI
modifyUriPath URI
baseURI (Path Web -> RepoPath -> Path Web
`anchorRepoPathRemotely` RepoPath
repoPath)

-- | Extracting or estimating file sizes
remoteFileSize :: RemoteFile fs typ -> Formats fs FileSize
remoteFileSize :: forall fs typ. RemoteFile fs typ -> Formats fs FileSize
remoteFileSize (RemoteFile fs typ
RemoteTimestamp) =
    FileSize -> Formats (FormatUn :- ()) FileSize
forall b. b -> Formats (FormatUn :- ()) b
FsUn (FileSize -> Formats (FormatUn :- ()) FileSize)
-> FileSize -> Formats (FormatUn :- ()) FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeBound Int54
fileSizeBoundTimestamp
remoteFileSize (RemoteRoot Maybe (Trusted FileInfo)
mLen) =
    FileSize -> Formats (FormatUn :- ()) FileSize
forall b. b -> Formats (FormatUn :- ()) b
FsUn (FileSize -> Formats (FormatUn :- ()) FileSize)
-> FileSize -> Formats (FormatUn :- ()) FileSize
forall a b. (a -> b) -> a -> b
$ FileSize
-> (Trusted FileInfo -> FileSize)
-> Maybe (Trusted FileInfo)
-> FileSize
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int54 -> FileSize
FileSizeBound Int54
fileSizeBoundRoot)
                 (Int54 -> FileSize
FileSizeExact (Int54 -> FileSize)
-> (Trusted FileInfo -> Int54) -> Trusted FileInfo -> FileSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trusted FileInfo -> Int54
fileLength')
                 Maybe (Trusted FileInfo)
mLen
remoteFileSize (RemoteSnapshot Trusted FileInfo
len) =
    FileSize -> Formats (FormatUn :- ()) FileSize
forall b. b -> Formats (FormatUn :- ()) b
FsUn (FileSize -> Formats (FormatUn :- ()) FileSize)
-> FileSize -> Formats (FormatUn :- ()) FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
remoteFileSize (RemoteMirrors Trusted FileInfo
len) =
    FileSize -> Formats (FormatUn :- ()) FileSize
forall b. b -> Formats (FormatUn :- ()) b
FsUn (FileSize -> Formats (FormatUn :- ()) FileSize)
-> FileSize -> Formats (FormatUn :- ()) FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
remoteFileSize (RemoteIndex HasFormat fs FormatGz
_ Formats fs (Trusted FileInfo)
lens) =
    (Trusted FileInfo -> FileSize)
-> Formats fs (Trusted FileInfo) -> Formats fs FileSize
forall a b. (a -> b) -> Formats fs a -> Formats fs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int54 -> FileSize
FileSizeExact (Int54 -> FileSize)
-> (Trusted FileInfo -> Int54) -> Trusted FileInfo -> FileSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trusted FileInfo -> Int54
fileLength') Formats fs (Trusted FileInfo)
lens
remoteFileSize (RemotePkgTarGz PackageIdentifier
_pkgId Trusted FileInfo
len) =
    FileSize -> Formats (FormatGz :- ()) FileSize
forall b. b -> Formats (FormatGz :- ()) b
FsGz (FileSize -> Formats (FormatGz :- ()) FileSize)
-> FileSize -> Formats (FormatGz :- ()) FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)

-- | Bound on the size of the timestamp
--
-- This is intended as a permissive rather than tight bound.
--
-- The timestamp signed with a single key is 420 bytes; the signature makes up
-- just under 200 bytes of that. So even if the timestamp is signed with 10
-- keys it would still only be 2420 bytes. Doubling this amount, an upper bound
-- of 4kB should definitely be sufficient.
fileSizeBoundTimestamp :: Int54
fileSizeBoundTimestamp :: Int54
fileSizeBoundTimestamp = Int54
4096

-- | Bound on the size of the root
--
-- This is intended as a permissive rather than tight bound.
--
-- The variable parts of the root metadata are
--
-- * Signatures, each of which are about 200 bytes
-- * A key environment (mapping from key IDs to public keys), each is of
--   which is also about 200 bytes
-- * Mirrors, root, snapshot, targets, and timestamp role specifications.
--   These contains key IDs, each of which is about 80 bytes.
--
-- A skeleton root metadata is about 580 bytes. Allowing for
--
-- * 100 signatures
-- * 100 mirror keys, 1000 root keys, 100 snapshot keys, 1000 target keys,
--   100 timestamp keys
-- * the corresponding 2300 entries in the key environment
--
-- We end up with a bound of about 665,000 bytes. Doubling this amount, an
-- upper bound of 2MB should definitely be sufficient.
fileSizeBoundRoot :: Int54
fileSizeBoundRoot :: Int54
fileSizeBoundRoot = Int54
2 Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
* Int54
1024 Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
* Int54
2014

{-------------------------------------------------------------------------------
  Configuration
-------------------------------------------------------------------------------}

-- | Remote repository configuration
--
-- This is purely for internal convenience.
data RemoteConfig = RemoteConfig {
      RemoteConfig -> RepoLayout
cfgLayout   :: RepoLayout
    , RemoteConfig -> HttpLib
cfgHttpLib  :: HttpLib
    , RemoteConfig -> URI
cfgBase     :: URI
    , RemoteConfig -> Cache
cfgCache    :: Cache
    , RemoteConfig -> ServerCapabilities
cfgCaps     :: ServerCapabilities
    , RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger   :: forall m. MonadIO m => LogMessage -> m ()
    , RemoteConfig -> RepoOpts
cfgOpts     :: RepoOpts
    }

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Template for the local file we use to download a URI to
uriTemplate :: URI -> String
uriTemplate :: URI -> String
uriTemplate = Path Web -> String
forall a. Path a -> String
takeFileName (Path Web -> String) -> (URI -> Path Web) -> URI -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Path Web
uriPath

fileLength' :: Trusted FileInfo -> Int54
fileLength' :: Trusted FileInfo -> Int54
fileLength' = FileLength -> Int54
fileLength (FileLength -> Int54)
-> (Trusted FileInfo -> FileLength) -> Trusted FileInfo -> Int54
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> FileLength
fileInfoLength (FileInfo -> FileLength)
-> (Trusted FileInfo -> FileInfo) -> Trusted FileInfo -> FileLength
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trusted FileInfo -> FileInfo
forall a. Trusted a -> a
trusted

{-------------------------------------------------------------------------------
  Files downloaded from the remote repository
-------------------------------------------------------------------------------}

data RemoteTemp :: * -> * where
    DownloadedWhole :: {
        forall a. RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
      } -> RemoteTemp a

    -- If we download only the delta, we record both the path to where the
    -- "old" file is stored and the path to the temp file containing the delta.
    -- Then:
    --
    --   When we verify the file, we need both of these paths if we compute
    --   the hash from scratch, or only the path to the delta if we attempt
    --   to compute the hash incrementally (TODO: incremental verification
    --   not currently implemented).
    --
    --   When we copy a file over, we are additionally given a destination
    --   path. In this case, we expect that destination path to be equal to
    --   the path to the old file (and assert this to be the case).
    DownloadedDelta :: {
        RemoteTemp Binary -> Path Absolute
deltaTemp     :: Path Absolute
      , RemoteTemp Binary -> Path Absolute
deltaExisting :: Path Absolute
      , RemoteTemp Binary -> Int54
deltaSeek     :: Int54       -- ^ How much of the existing file to keep
      } -> RemoteTemp Binary
--TODO: ^^ older haddock doesn't support GADT doc comments :-(
--      and add the '*' bullet points back in

instance Pretty (RemoteTemp typ) where
    pretty :: RemoteTemp typ -> String
pretty DownloadedWhole{Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
..} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
        String
"DownloadedWhole"
      , Path Absolute -> String
forall a. Pretty a => a -> String
pretty Path Absolute
wholeTemp
      ]
    pretty DownloadedDelta{Path Absolute
Int54
deltaTemp :: RemoteTemp Binary -> Path Absolute
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaTemp :: Path Absolute
deltaExisting :: Path Absolute
deltaSeek :: Int54
..} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
        String
"DownloadedDelta"
      , Path Absolute -> String
forall a. Pretty a => a -> String
pretty Path Absolute
deltaTemp
      , Path Absolute -> String
forall a. Pretty a => a -> String
pretty Path Absolute
deltaExisting
      , Int54 -> String
forall a. Show a => a -> String
show Int54
deltaSeek
      ]

instance DownloadedFile RemoteTemp where
  downloadedVerify :: forall a. RemoteTemp a -> Trusted FileInfo -> IO Bool
downloadedVerify = RemoteTemp a -> Trusted FileInfo -> IO Bool
forall a. RemoteTemp a -> Trusted FileInfo -> IO Bool
verifyRemoteFile
  downloadedRead :: RemoteTemp Metadata -> IO ByteString
downloadedRead   = Path Absolute -> IO ByteString
forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString (Path Absolute -> IO ByteString)
-> (RemoteTemp Metadata -> Path Absolute)
-> RemoteTemp Metadata
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteTemp Metadata -> Path Absolute
forall a. RemoteTemp a -> Path Absolute
wholeTemp
  downloadedCopyTo :: forall a. RemoteTemp a -> Path Absolute -> IO ()
downloadedCopyTo = \RemoteTemp a
f Path Absolute
dest ->
    case RemoteTemp a
f of
      DownloadedWhole{Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
..} ->
        Path Absolute -> Path Absolute -> IO ()
forall root root'.
(FsRoot root, FsRoot root') =>
Path root -> Path root' -> IO ()
renameFile Path Absolute
wholeTemp Path Absolute
dest
      DownloadedDelta{Path Absolute
Int54
deltaTemp :: RemoteTemp Binary -> Path Absolute
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaTemp :: Path Absolute
deltaExisting :: Path Absolute
deltaSeek :: Int54
..} -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Absolute
deltaExisting Path Absolute -> Path Absolute -> Bool
forall a. Eq a => a -> a -> Bool
== Path Absolute
dest) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO ()) -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Assertion failure: deltaExisting /= dest"
        -- We need ReadWriteMode in order to be able to seek
        Path Absolute -> IOMode -> (Handle -> IO ()) -> IO ()
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaExisting IOMode
ReadWriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (Int54 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
deltaSeek)
          Handle -> ByteString -> IO ()
BS.L.hPut Handle
h (ByteString -> IO ()) -> IO ByteString -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Path Absolute -> IO ByteString
forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString Path Absolute
deltaTemp

-- | Verify a file downloaded from the remote repository
--
-- TODO: This currently still computes the hash for the whole file. If we cached
-- the state of the hash generator we could compute the hash incrementally.
-- However, profiling suggests that this would only be a minor improvement.
verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool
verifyRemoteFile :: forall a. RemoteTemp a -> Trusted FileInfo -> IO Bool
verifyRemoteFile RemoteTemp typ
remoteTemp Trusted FileInfo
trustedInfo = do
    FileLength
sz <- Int54 -> FileLength
FileLength (Int54 -> FileLength) -> IO Int54 -> IO FileLength
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RemoteTemp typ -> IO Int54
forall typ. RemoteTemp typ -> IO Int54
remoteSize RemoteTemp typ
remoteTemp
    if FileLength
sz FileLength -> FileLength -> Bool
forall a. Eq a => a -> a -> Bool
/= FileInfo -> FileLength
fileInfoLength (Trusted FileInfo -> FileInfo
forall a. Trusted a -> a
trusted Trusted FileInfo
trustedInfo)
      then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else RemoteTemp typ -> (ByteString -> Bool) -> IO Bool
forall typ. RemoteTemp typ -> (ByteString -> Bool) -> IO Bool
withRemoteBS RemoteTemp typ
remoteTemp ((ByteString -> Bool) -> IO Bool)
-> (ByteString -> Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$
             FileInfo -> FileInfo -> Bool
compareTrustedFileInfo (Trusted FileInfo -> FileInfo
forall a. Trusted a -> a
trusted Trusted FileInfo
trustedInfo) (FileInfo -> Bool)
-> (ByteString -> FileInfo) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FileInfo
fileInfo
  where
    remoteSize :: RemoteTemp typ -> IO Int54
    remoteSize :: forall typ. RemoteTemp typ -> IO Int54
remoteSize DownloadedWhole{Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
..} = Path Absolute -> IO Int54
forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
wholeTemp
    remoteSize DownloadedDelta{Path Absolute
Int54
deltaTemp :: RemoteTemp Binary -> Path Absolute
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaTemp :: Path Absolute
deltaExisting :: Path Absolute
deltaSeek :: Int54
..} = do
        Int54
deltaSize <- Path Absolute -> IO Int54
forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
deltaTemp
        Int54 -> IO Int54
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int54 -> IO Int54) -> Int54 -> IO Int54
forall a b. (a -> b) -> a -> b
$ Int54
deltaSeek Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
+ Int54
deltaSize

    -- It is important that we close the file handles when we're done
    -- (esp. since we may not read the whole file)
    withRemoteBS :: RemoteTemp typ -> (BS.L.ByteString -> Bool) -> IO Bool
    withRemoteBS :: forall typ. RemoteTemp typ -> (ByteString -> Bool) -> IO Bool
withRemoteBS DownloadedWhole{Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
..} ByteString -> Bool
callback = do
        Path Absolute -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
wholeTemp IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          ByteString
bs <- Handle -> IO ByteString
BS.L.hGetContents Handle
h
          Bool -> IO Bool
forall a. a -> IO a
evaluate (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
callback ByteString
bs
    withRemoteBS DownloadedDelta{Path Absolute
Int54
deltaTemp :: RemoteTemp Binary -> Path Absolute
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaTemp :: Path Absolute
deltaExisting :: Path Absolute
deltaSeek :: Int54
..} ByteString -> Bool
callback =
        Path Absolute -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaExisting IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
hExisting ->
          Path Absolute -> IOMode -> (Handle -> IO Bool) -> IO Bool
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaTemp IOMode
ReadMode ((Handle -> IO Bool) -> IO Bool) -> (Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Handle
hTemp -> do
            ByteString
existing <- Handle -> IO ByteString
BS.L.hGetContents Handle
hExisting
            ByteString
temp     <- Handle -> IO ByteString
BS.L.hGetContents Handle
hTemp
            Bool -> IO Bool
forall a. a -> IO a
evaluate (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
callback (ByteString -> Bool) -> ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.L.concat [
                Int64 -> ByteString -> ByteString
BS.L.take (Int54 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
deltaSeek) ByteString
existing
              , ByteString
temp
              ]