{-# 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar ServerCapabilities_
mv forall a b. (a -> b) -> a -> b
$ \ServerCapabilities_
caps ->
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerCapabilities_
caps {
        serverAcceptRangesBytes :: Bool
serverAcceptRangesBytes = ServerCapabilities_ -> Bool
serverAcceptRangesBytes ServerCapabilities_
caps
          Bool -> Bool -> Bool
|| HttpResponseHeader
HttpResponseAcceptRangesBytes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HttpResponseHeader]
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ServerCapabilities_
mv forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FileSize] -> ShowS
$cshowList :: [FileSize] -> ShowS
show :: FileSize -> String
$cshow :: FileSize -> String
showsPrec :: Int -> FileSize -> ShowS
$cshowsPrec :: Int -> FileSize -> ShowS
Show

fileSizeWithinBounds :: Int54 -> FileSize -> Bool
fileSizeWithinBounds :: Int54 -> FileSize -> Bool
fileSizeWithinBounds Int54
sz (FileSizeExact Int54
sz') = Int54
sz forall a. Ord a => a -> a -> Bool
<= Int54
sz'
fileSizeWithinBounds Int54
sz (FileSizeBound Int54
sz') = Int54
sz 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 <- forall a. a -> IO (MVar a)
newMVar 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   = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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     = 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     = 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    = 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 " forall a. [a] -> [a] -> [a]
++ 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 <- forall a. MVar a -> IO a
readMVar MVar (Maybe URI)
selectedMirror
     case Maybe URI
mBaseURI of
       Maybe URI
Nothing      -> forall a. String -> IO a
internalError String
"Internal error: no mirror selected"
       Just URI
baseURI -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall fs typ.
RemoteConfig
-> AttemptNr -> RemoteFile fs typ -> IO (DownloadMethod fs typ)
pickDownloadMethod RemoteConfig
cfg AttemptNr
attemptNr RemoteFile fs typ
remoteFile
    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 ()
cfgOpts :: RepoOpts
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: ServerCapabilities
cfgCache :: Cache
cfgBase :: URI
cfgHttpLib :: HttpLib
cfgLayout :: RepoLayout
cfgOpts :: RemoteConfig -> RepoOpts
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgCache :: RemoteConfig -> Cache
cfgBase :: RemoteConfig -> URI
cfgHttpLib :: RemoteConfig -> HttpLib
cfgLayout :: RemoteConfig -> RepoLayout
..} AttemptNr
attemptNr =
    if AttemptNr
attemptNr forall a. Eq a => a -> a -> Bool
== AttemptNr
0 then [HttpRequestHeader]
defaultHeaders
                      else HttpRequestHeader
HttpRequestMaxAge0 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
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
httpGetRange :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGet :: 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 [] = 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 forall a b. (a -> b) -> a -> b
$ String -> LogMessage
LogSelectedMirror (forall a. Show a => a -> String
show URI
m)
      URI -> IO a -> IO a
select URI
m 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 forall a b. (a -> b) -> a -> b
$ String -> LogMessage
LogSelectedMirror (forall a. Show a => a -> String
show URI
m)
      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) forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> do
        LogMessage -> IO ()
logger forall a b. (a -> b) -> a -> b
$ String -> SomeException -> LogMessage
LogMirrorFailed (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 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        [URI]
oobMirrors
      , if RepoOpts -> Bool
repoAllowAdditionalMirrors RepoOpts
repoOpts
          then forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (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 =
      forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe URI)
selectedMirror forall a b. (a -> b) -> a -> b
$ \Maybe URI
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just URI
uri)
               (forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Maybe URI)
selectedMirror forall a b. (a -> b) -> a -> b
$ \Maybe URI
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 ()
cfgOpts :: RepoOpts
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: ServerCapabilities
cfgCache :: Cache
cfgBase :: URI
cfgHttpLib :: HttpLib
cfgLayout :: RepoLayout
cfgOpts :: RemoteConfig -> RepoOpts
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgCache :: RemoteConfig -> Cache
cfgBase :: RemoteConfig -> URI
cfgHttpLib :: RemoteConfig -> HttpLib
cfgLayout :: RemoteConfig -> RepoLayout
..} AttemptNr
attemptNr RemoteFile fs typ
remoteFile =
    case RemoteFile fs typ
remoteFile of
      RemoteFile fs typ
RemoteTimestamp        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall fs e typ. HasFormat fs e -> DownloadMethod fs typ
NeverUpdated (forall f e. Format f -> HasFormat (f :- e) f
HFZ Format FormatUn
FUn)
      (RemoteRoot Maybe (Trusted FileInfo)
_)         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall fs e typ. HasFormat fs e -> DownloadMethod fs typ
NeverUpdated (forall f e. Format f -> HasFormat (f :- e) f
HFZ Format FormatUn
FUn)
      (RemoteSnapshot Trusted FileInfo
_)     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall fs e typ. HasFormat fs e -> DownloadMethod fs typ
NeverUpdated (forall f e. Format f -> HasFormat (f :- e) f
HFZ Format FormatUn
FUn)
      (RemoteMirrors Trusted FileInfo
_)      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall fs e typ. HasFormat fs e -> DownloadMethod fs typ
NeverUpdated (forall f e. Format f -> HasFormat (f :- e) f
HFZ Format FormatUn
FUn)
      (RemotePkgTarGz PackageIdentifier
_ Trusted FileInfo
_)   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall fs e typ. HasFormat fs e -> DownloadMethod fs typ
NeverUpdated (forall f e. Format f -> HasFormat (f :- e) f
HFZ Format FormatGz
FGz)
      (RemoteIndex HasFormat fs FormatGz
hasGz Formats fs (Trusted FileInfo)
formats) -> forall (m :: * -> *) a. Monad m => ExceptT a m a -> m a
multipleExitPoints forall a b. (a -> b) -> a -> b
$ do
        -- Server must support @Range@ with a byte-range
        Bool
rangeSupport <- forall (m :: * -> *) a.
MonadIO m =>
ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability ServerCapabilities
cfgCaps ServerCapabilities_ -> Bool
serverAcceptRangesBytes
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
rangeSupport forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit forall a b. (a -> b) -> a -> b
$ forall fs e.
HasFormat fs e -> 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall f. Cache -> Format f -> IO (Maybe (Path Absolute))
Cache.getCachedIndex Cache
cfgCache (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 -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit forall a b. (a -> b) -> a -> b
$ forall fs e.
HasFormat fs e -> UpdateFailure -> DownloadMethod fs Binary
CannotUpdate HasFormat fs FormatGz
hasGz UpdateFailure
UpdateImpossibleNoLocalCopy
          Just Path Absolute
fp -> 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.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AttemptNr
attemptNr forall a. Ord a => a -> a -> Bool
>= AttemptNr
2) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit forall a b. (a -> b) -> a -> b
$ forall fs e.
HasFormat fs e -> UpdateFailure -> DownloadMethod fs Binary
CannotUpdate HasFormat fs FormatGz
hasGz UpdateFailure
UpdateFailedTwice

        -- If all these checks pass try to do an incremental update.
        forall (m :: * -> *) a. Monad m => a -> m a
return Update {
             updateFormat :: HasFormat fs FormatGz
updateFormat = HasFormat fs FormatGz
hasGz
           , updateInfo :: Trusted FileInfo
updateInfo   = 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 ()
cfgOpts :: RepoOpts
cfgLogger :: forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: ServerCapabilities
cfgCache :: Cache
cfgBase :: URI
cfgHttpLib :: HttpLib
cfgLayout :: RepoLayout
cfgOpts :: RemoteConfig -> RepoOpts
cfgLogger :: RemoteConfig
-> forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgCaps :: RemoteConfig -> ServerCapabilities
cfgCache :: RemoteConfig -> Cache
cfgBase :: RemoteConfig -> URI
cfgHttpLib :: RemoteConfig -> HttpLib
cfgLayout :: RemoteConfig -> RepoLayout
..} 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 :: HasFormat fs f
neverUpdatedFormat :: ()
..} = do
        forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger forall a b. (a -> b) -> a -> b
$ forall fs typ. RemoteFile fs typ -> LogMessage
LogDownloading RemoteFile fs typ
remoteFile
        forall f.
HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download HasFormat fs f
neverUpdatedFormat
    go CannotUpdate{HasFormat fs f
UpdateFailure
cannotUpdateReason :: UpdateFailure
cannotUpdateFormat :: HasFormat fs f
cannotUpdateReason :: forall fs. DownloadMethod fs Binary -> UpdateFailure
cannotUpdateFormat :: ()
..} = do
        forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger forall a b. (a -> b) -> a -> b
$ forall fs. RemoteFile fs Binary -> UpdateFailure -> LogMessage
LogCannotUpdate RemoteFile fs typ
remoteFile UpdateFailure
cannotUpdateReason
        forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger forall a b. (a -> b) -> a -> b
$ forall fs typ. RemoteFile fs typ -> LogMessage
LogDownloading RemoteFile fs typ
remoteFile
        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
updateTail :: Int54
updateLocal :: Path Absolute
updateInfo :: Trusted FileInfo
updateFormat :: HasFormat fs f
updateTail :: forall fs. DownloadMethod fs Binary -> Int54
updateLocal :: forall fs. DownloadMethod fs Binary -> Path Absolute
updateInfo :: forall fs. DownloadMethod fs Binary -> Trusted FileInfo
updateFormat :: ()
..} = do
        forall (m :: * -> *). MonadIO m => LogMessage -> m ()
cfgLogger forall a b. (a -> b) -> a -> b
$ forall fs. RemoteFile fs Binary -> LogMessage
LogUpdating RemoteFile fs typ
remoteFile
        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) <- forall root.
FsRoot root =>
Path root -> String -> Verify (Path Absolute, Handle)
openTempFile (Cache -> Path Absolute
Cache.cacheRoot Cache
cfgCache) (URI -> String
uriTemplate URI
uri)
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI -> ([HttpResponseHeader] -> BodyReader -> IO a) -> IO a
httpGet [HttpRequestHeader]
headers URI
uri 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 ()
execBodyReader TargetPath
targetPath FileSize
sz Handle
h BodyReader
bodyReader
          Handle -> IO ()
hClose Handle
h
        forall f.
HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified HasFormat fs f
format forall a b. (a -> b) -> a -> b
$ forall a. Path Absolute -> RemoteTemp a
DownloadedWhole Path Absolute
tempPath
      where
        targetPath :: TargetPath
targetPath = RepoPath -> TargetPath
TargetPathRepo forall a b. (a -> b) -> a -> b
$ 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 = 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 -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI RepoLayout
cfgLayout URI
cfgBase RemoteFile fs typ
remoteFile
        sz :: FileSize
sz  = 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. 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> a
`max` (Int54
currentSz forall a. Num a => a -> a -> a
- Int54
fileTail), Int54
fileSz)
            range' :: (Int, Int)
range'    = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (a, b) -> a
fst (Int54, Int54)
range), forall a b. (Integral a, Num b) => a -> b
fromIntegral (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) <- forall root.
FsRoot root =>
Path root -> String -> Verify (Path Absolute, Handle)
openTempFile Path Absolute
cacheRoot (URI -> String
uriTemplate URI
uri)
        HttpStatus
statusCode <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGetRange [HttpRequestHeader]
headers URI
uri (Int, Int)
range' 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 (forall a b. (a, b) -> b
snd (Int54, Int54)
range forall a. Num a => a -> a -> a
- forall a b. (a, b) -> a
fst (Int54, Int54)
range)
                    HttpStatus
HttpStatus200OK ->
                      Int54 -> FileSize
FileSizeExact Int54
fileSz
            Throws SomeRemoteError =>
TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
execBodyReader TargetPath
targetPath FileSize
expectedSize Handle
h BodyReader
bodyReader
            Handle -> IO ()
hClose Handle
h
            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     = forall a b. (a, b) -> a
fst (Int54, Int54)
range
                    }
                HttpStatus
HttpStatus200OK ->
                  forall a. Path Absolute -> RemoteTemp a
DownloadedWhole Path Absolute
tempPath
        forall f.
HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified HasFormat fs f
format 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   = 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 forall a b. (a -> b) -> a -> b
$
          forall (down :: * -> *) typ f.
DownloadedFile down =>
Cache -> down typ -> Format f -> IsCached typ -> IO ()
Cache.cacheRemoteFile Cache
cfgCache
                                RemoteTemp typ
remoteTemp
                                (forall fs f. HasFormat fs f -> Format f
hasFormatGet HasFormat fs f
format)
                                (forall fs typ. RemoteFile fs typ -> IsCached typ
mustCache RemoteFile fs typ
remoteFile)
        forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: forall a.
Throws SomeRemoteError =>
[HttpRequestHeader]
-> URI
-> (Int, Int)
-> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)
-> IO a
httpGet :: 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
..} = 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int54
sz Int54 -> FileSize -> Bool
`fileSizeWithinBounds` FileSize
mlen) forall a b. (a -> b) -> a -> b
$
        forall e a. (Exception e, Throws e) => e -> IO a
throwChecked forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeRemoteError
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 forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int54 -> IO ()
go (Int54
sz forall a. Num a => a -> a -> a
+ 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
fileTooLargeExpected :: FileSize
fileTooLargePath :: TargetPath
fileTooLargeExpected :: FileTooLarge -> FileSize
fileTooLargePath :: FileTooLarge -> TargetPath
..} = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
      String
"file returned by server too large: "
    , forall a. Pretty a => a -> String
pretty TargetPath
fileTooLargePath
    , String
" (expected " forall a. [a] -> [a] -> [a]
++ FileSize -> String
expected FileSize
fileTooLargeExpected forall a. [a] -> [a] -> [a]
++ String
" bytes)"
    ]
    where
      expected :: FileSize -> String
      expected :: FileSize -> String
expected (FileSizeExact Int54
n) = String
"exactly " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int54
n
      expected (FileSizeBound Int54
n) = String
"at most " forall a. [a] -> [a] -> [a]
++ 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 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RepoPath -> URI
aux forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeBound Int54
fileSizeBoundTimestamp
remoteFileSize (RemoteRoot Maybe (Trusted FileInfo)
mLen) =
    forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Int54 -> FileSize
FileSizeBound Int54
fileSizeBoundRoot)
                 (Int54 -> FileSize
FileSizeExact forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trusted FileInfo -> Int54
fileLength')
                 Maybe (Trusted FileInfo)
mLen
remoteFileSize (RemoteSnapshot Trusted FileInfo
len) =
    forall a. a -> Formats (FormatUn :- ()) a
FsUn forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
remoteFileSize (RemoteMirrors Trusted FileInfo
len) =
    forall a. a -> Formats (FormatUn :- ()) a
FsUn 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) =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int54 -> FileSize
FileSizeExact 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) =
    forall a. a -> Formats (FormatGz :- ()) a
FsGz 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 forall a. Num a => a -> a -> a
* Int54
1024 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 = forall a. Path a -> String
takeFileName 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> FileLength
fileInfoLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
..} = forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ [
        String
"DownloadedWhole"
      , forall a. Pretty a => a -> String
pretty Path Absolute
wholeTemp
      ]
    pretty DownloadedDelta{Path Absolute
Int54
deltaSeek :: Int54
deltaExisting :: Path Absolute
deltaTemp :: Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaTemp :: RemoteTemp Binary -> Path Absolute
..} = forall a. [a] -> [[a]] -> [a]
intercalate String
" " forall a b. (a -> b) -> a -> b
$ [
        String
"DownloadedDelta"
      , forall a. Pretty a => a -> String
pretty Path Absolute
deltaTemp
      , forall a. Pretty a => a -> String
pretty Path Absolute
deltaExisting
      , forall a. Show a => a -> String
show Int54
deltaSeek
      ]

instance DownloadedFile RemoteTemp where
  downloadedVerify :: forall a. RemoteTemp a -> Trusted FileInfo -> IO Bool
downloadedVerify = forall a. RemoteTemp a -> Trusted FileInfo -> IO Bool
verifyRemoteFile
  downloadedRead :: RemoteTemp Metadata -> IO ByteString
downloadedRead   = forall root. FsRoot root => Path root -> IO ByteString
readLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
..} ->
        forall root root'.
(FsRoot root, FsRoot root') =>
Path root -> Path root' -> IO ()
renameFile Path Absolute
wholeTemp Path Absolute
dest
      DownloadedDelta{Path Absolute
Int54
deltaSeek :: Int54
deltaExisting :: Path Absolute
deltaTemp :: Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaTemp :: RemoteTemp Binary -> Path Absolute
..} -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path Absolute
deltaExisting forall a. Eq a => a -> a -> Bool
== Path Absolute
dest) forall a b. (a -> b) -> a -> b
$
          forall e a. Exception e => e -> IO a
throwIO 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
        forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaExisting IOMode
ReadWriteMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
AbsoluteSeek (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
deltaSeek)
          Handle -> ByteString -> IO ()
BS.L.hPut Handle
h forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall typ. RemoteTemp typ -> IO Int54
remoteSize RemoteTemp typ
remoteTemp
    if FileLength
sz forall a. Eq a => a -> a -> Bool
/= FileInfo -> FileLength
fileInfoLength (forall a. Trusted a -> a
trusted Trusted FileInfo
trustedInfo)
      then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else forall typ. RemoteTemp typ -> (ByteString -> Bool) -> IO Bool
withRemoteBS RemoteTemp typ
remoteTemp forall a b. (a -> b) -> a -> b
$
             FileInfo -> FileInfo -> Bool
compareTrustedFileInfo (forall a. Trusted a -> a
trusted Trusted FileInfo
trustedInfo) 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 :: Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
..} = forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
wholeTemp
    remoteSize DownloadedDelta{Path Absolute
Int54
deltaSeek :: Int54
deltaExisting :: Path Absolute
deltaTemp :: Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaTemp :: RemoteTemp Binary -> Path Absolute
..} = do
        Int54
deltaSize <- forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
deltaTemp
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int54
deltaSeek 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 :: Path Absolute
wholeTemp :: forall a. RemoteTemp a -> Path Absolute
..} ByteString -> Bool
callback = do
        forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
wholeTemp IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
          ByteString
bs <- Handle -> IO ByteString
BS.L.hGetContents Handle
h
          forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
callback ByteString
bs
    withRemoteBS DownloadedDelta{Path Absolute
Int54
deltaSeek :: Int54
deltaExisting :: Path Absolute
deltaTemp :: Path Absolute
deltaSeek :: RemoteTemp Binary -> Int54
deltaExisting :: RemoteTemp Binary -> Path Absolute
deltaTemp :: RemoteTemp Binary -> Path Absolute
..} ByteString -> Bool
callback =
        forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaExisting IOMode
ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
hExisting ->
          forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path Absolute
deltaTemp IOMode
ReadMode 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
            forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ ByteString -> Bool
callback forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.L.concat [
                Int64 -> ByteString -> ByteString
BS.L.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int54
deltaSeek) ByteString
existing
              , ByteString
temp
              ]