{-# LANGUAGE CPP #-}
module Hackage.Security.Client.Repository.Remote (
withRepository
, RepoOpts(..)
, defaultRepoOpts
, RemoteTemp
, FileSize(..)
, fileSizeWithinBounds
) where
import Control.Concurrent
import Control.Exception
import Control.Monad.Cont
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
newtype ServerCapabilities = SC (MVar ServerCapabilities_)
data ServerCapabilities_ = ServerCapabilities {
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 :: Bool -> ServerCapabilities_
ServerCapabilities {
serverAcceptRangesBytes :: Bool
serverAcceptRangesBytes = Bool
False
}
updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities (SC mv :: MVar ServerCapabilities_
mv) responseHeaders :: [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
$ \caps :: ServerCapabilities_
caps ->
ServerCapabilities_ -> IO ServerCapabilities_
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 :: Bool
serverAcceptRangesBytes = ServerCapabilities_ -> Bool
serverAcceptRangesBytes ServerCapabilities_
caps
Bool -> Bool -> Bool
|| HttpResponseHeader
HttpResponseAcceptRangesBytes HttpResponseHeader -> [HttpResponseHeader] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HttpResponseHeader]
responseHeaders
}
checkServerCapability :: MonadIO m
=> ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability :: ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability (SC mv :: MVar ServerCapabilities_
mv) f :: ServerCapabilities_ -> a
f = 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 (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
data FileSize =
FileSizeExact Int54
| 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
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 sz :: Int54
sz (FileSizeExact sz' :: Int54
sz') = Int54
sz Int54 -> Int54 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int54
sz'
fileSizeWithinBounds sz :: Int54
sz (FileSizeBound sz' :: Int54
sz') = Int54
sz Int54 -> Int54 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int54
sz'
data RepoOpts = RepoOpts {
RepoOpts -> Bool
repoAllowAdditionalMirrors :: Bool
}
defaultRepoOpts :: RepoOpts
defaultRepoOpts :: RepoOpts
defaultRepoOpts = RepoOpts :: Bool -> RepoOpts
RepoOpts {
repoAllowAdditionalMirrors :: Bool
repoAllowAdditionalMirrors = Bool
True
}
withRepository
:: HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
withRepository :: HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> IndexLayout
-> (LogMessage -> IO ())
-> (Repository RemoteTemp -> IO a)
-> IO a
withRepository httpLib :: HttpLib
httpLib
outOfBandMirrors :: [URI]
outOfBandMirrors
repoOpts :: RepoOpts
repoOpts
cache :: Cache
cache
repLayout :: RepoLayout
repLayout
repIndexLayout :: IndexLayout
repIndexLayout
logger :: LogMessage -> IO ()
logger
callback :: 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 mirror :: URI
mirror = RemoteConfig :: RepoLayout
-> HttpLib
-> URI
-> Cache
-> ServerCapabilities
-> (forall (m :: * -> *). MonadIO m => LogMessage -> m ())
-> RepoOpts
-> RemoteConfig
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 (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 :: forall (down :: * -> *).
DownloadedFile down =>
(forall fs typ.
Throws SomeRemoteError =>
AttemptNr
-> RemoteFile fs typ -> Verify (Some (HasFormat fs), down typ))
-> (CachedFile -> IO (Maybe (Path Absolute)))
-> IO (Path Absolute)
-> IO ()
-> (forall a. (Handle -> IO a) -> IO a)
-> IO TarIndex
-> (IO () -> IO ())
-> (forall a. Maybe [Mirror] -> IO a -> IO a)
-> (LogMessage -> IO ())
-> RepoLayout
-> IndexLayout
-> String
-> Repository down
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 = "Remote repository at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [URI] -> String
forall a. Show a => a -> String
show [URI]
outOfBandMirrors
}
type SelectedMirror = MVar (Maybe URI)
getSelectedMirror :: SelectedMirror -> IO URI
getSelectedMirror :: MVar (Maybe URI) -> IO URI
getSelectedMirror selectedMirror :: 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
Nothing -> String -> IO URI
forall a. String -> IO a
internalError "Internal error: no mirror selected"
Just baseURI :: URI
baseURI -> URI -> IO URI
forall (m :: * -> *) a. Monad m => a -> m a
return URI
baseURI
getRemote :: Throws SomeRemoteError
=> (URI -> RemoteConfig)
-> SelectedMirror
-> AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getRemote :: (URI -> RemoteConfig)
-> MVar (Maybe URI)
-> AttemptNr
-> RemoteFile fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getRemote remoteConfig :: URI -> RemoteConfig
remoteConfig selectedMirror :: MVar (Maybe URI)
selectedMirror attemptNr :: AttemptNr
attemptNr remoteFile :: RemoteFile fs typ
remoteFile = do
URI
baseURI <- IO URI -> Verify URI
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 (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
httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader]
RemoteConfig{..} attemptNr :: AttemptNr
attemptNr =
if AttemptNr
attemptNr AttemptNr -> AttemptNr -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then [HttpRequestHeader]
defaultHeaders
else HttpRequestHeader
HttpRequestMaxAge0 HttpRequestHeader -> [HttpRequestHeader] -> [HttpRequestHeader]
forall a. a -> [a] -> [a]
: [HttpRequestHeader]
defaultHeaders
where
defaultHeaders :: [HttpRequestHeader]
defaultHeaders :: [HttpRequestHeader]
defaultHeaders = [HttpRequestHeader
HttpRequestNoTransform]
withMirror :: forall a.
HttpLib
-> SelectedMirror
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
withMirror :: HttpLib
-> MVar (Maybe URI)
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
withMirror HttpLib{..}
selectedMirror :: MVar (Maybe URI)
selectedMirror
logger :: LogMessage -> IO ()
logger
oobMirrors :: [URI]
oobMirrors
repoOpts :: RepoOpts
repoOpts
tufMirrors :: Maybe [Mirror]
tufMirrors
callback :: IO a
callback
=
[URI] -> IO a
go [URI]
orderedMirrors
where
go :: [URI] -> IO a
go :: [URI] -> IO a
go [] = String -> IO a
forall a. String -> IO a
internalError "No mirrors configured"
go [m :: 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
go (m :: URI
m:ms :: [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
$ \ex :: 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
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
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 -> IO (Maybe URI)
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 -> IO (Maybe URI)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe URI
forall a. Maybe a
Nothing)
data DownloadMethod :: * -> * -> * where
NeverUpdated :: {
()
neverUpdatedFormat :: HasFormat fs f
} -> DownloadMethod fs typ
CannotUpdate :: {
()
cannotUpdateFormat :: HasFormat fs f
, DownloadMethod fs Binary -> UpdateFailure
cannotUpdateReason :: UpdateFailure
} -> DownloadMethod fs Binary
Update :: {
()
updateFormat :: HasFormat fs f
, DownloadMethod fs Binary -> Trusted FileInfo
updateInfo :: Trusted FileInfo
, DownloadMethod fs Binary -> Path Absolute
updateLocal :: Path Absolute
, DownloadMethod fs Binary -> Int54
updateTail :: Int54
} -> DownloadMethod fs Binary
pickDownloadMethod :: forall fs typ. RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> IO (DownloadMethod fs typ)
pickDownloadMethod :: RemoteConfig
-> AttemptNr -> RemoteFile fs typ -> IO (DownloadMethod fs typ)
pickDownloadMethod RemoteConfig{..} attemptNr :: AttemptNr
attemptNr remoteFile :: RemoteFile fs typ
remoteFile =
case RemoteFile fs typ
remoteFile of
RemoteTimestamp -> DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ))
-> DownloadMethod (FormatUn :- ()) typ
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat (FormatUn :- ()) FormatUn
-> DownloadMethod (FormatUn :- ()) typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn)
(RemoteRoot _) -> DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ))
-> DownloadMethod (FormatUn :- ()) typ
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat (FormatUn :- ()) FormatUn
-> DownloadMethod (FormatUn :- ()) typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn)
(RemoteSnapshot _) -> DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ))
-> DownloadMethod (FormatUn :- ()) typ
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat (FormatUn :- ()) FormatUn
-> DownloadMethod (FormatUn :- ()) typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn)
(RemoteMirrors _) -> DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod (FormatUn :- ()) typ -> IO (DownloadMethod fs typ))
-> DownloadMethod (FormatUn :- ()) typ
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat (FormatUn :- ()) FormatUn
-> DownloadMethod (FormatUn :- ()) typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatUn -> HasFormat (FormatUn :- ()) FormatUn
forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatUn
FUn)
(RemotePkgTarGz _ _) -> DownloadMethod (FormatGz :- ()) typ -> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => a -> m a
return (DownloadMethod (FormatGz :- ()) typ -> IO (DownloadMethod fs typ))
-> DownloadMethod (FormatGz :- ()) typ
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ HasFormat (FormatGz :- ()) FormatGz
-> DownloadMethod (FormatGz :- ()) typ
forall fs f typ. HasFormat fs f -> DownloadMethod fs typ
NeverUpdated (Format FormatGz -> HasFormat (FormatGz :- ()) FormatGz
forall f fs. Format f -> HasFormat (f :- fs) f
HFZ Format FormatGz
FGz)
(RemoteIndex hasGz :: HasFormat fs FormatGz
hasGz formats :: Formats fs (Trusted FileInfo)
formats) -> ExceptT (DownloadMethod fs Binary) IO (DownloadMethod fs Binary)
-> IO (DownloadMethod fs typ)
forall (m :: * -> *) a. Monad m => ExceptT a m a -> m a
multipleExitPoints (ExceptT (DownloadMethod fs Binary) IO (DownloadMethod fs Binary)
-> IO (DownloadMethod fs typ))
-> ExceptT (DownloadMethod fs Binary) IO (DownloadMethod fs Binary)
-> IO (DownloadMethod fs typ)
forall a b. (a -> b) -> a -> b
$ do
Bool
rangeSupport <- ServerCapabilities
-> (ServerCapabilities_ -> Bool)
-> ExceptT (DownloadMethod fs Binary) IO Bool
forall (m :: * -> *) a.
MonadIO m =>
ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability ServerCapabilities
cfgCaps ServerCapabilities_ -> Bool
serverAcceptRangesBytes
Bool
-> ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
rangeSupport (ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ())
-> ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ()
forall a b. (a -> b) -> a -> b
$ DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO ())
-> DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) 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
Maybe (Path Absolute)
mCachedIndex <- IO (Maybe (Path Absolute))
-> ExceptT (DownloadMethod fs Binary) IO (Maybe (Path Absolute))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe (Path Absolute))
-> ExceptT (DownloadMethod fs Binary) IO (Maybe (Path Absolute)))
-> IO (Maybe (Path Absolute))
-> ExceptT (DownloadMethod fs Binary) 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
Nothing -> DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO (Path Absolute)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO (Path Absolute))
-> DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) 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 fp :: Path Absolute
fp -> Path Absolute
-> ExceptT (DownloadMethod fs Binary) IO (Path Absolute)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Absolute
fp
Bool
-> ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AttemptNr
attemptNr AttemptNr -> AttemptNr -> Bool
forall a. Ord a => a -> a -> Bool
>= 2) (ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ())
-> ExceptT (DownloadMethod fs Binary) IO ()
-> ExceptT (DownloadMethod fs Binary) IO ()
forall a b. (a -> b) -> a -> b
$ DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
exit (DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO ())
-> DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) 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
DownloadMethod fs Binary
-> ExceptT (DownloadMethod fs Binary) IO (DownloadMethod fs Binary)
forall (m :: * -> *) a. Monad m => a -> m a
return $WUpdate :: forall fs f.
HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> DownloadMethod fs Binary
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 = 65536
}
getFile :: forall fs typ. Throws SomeRemoteError
=> RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getFile :: RemoteConfig
-> AttemptNr
-> RemoteFile fs typ
-> DownloadMethod fs typ
-> Verify (Some (HasFormat fs), RemoteTemp typ)
getFile cfg :: RemoteConfig
cfg@RemoteConfig{..} attemptNr :: AttemptNr
attemptNr remoteFile :: RemoteFile fs typ
remoteFile method :: 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{..} = 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{..} = 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{..} = 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
download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)
download format :: HasFormat fs f
format = do
(tempPath :: Path Absolute
tempPath, h :: 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 (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
$ \responseHeaders :: [HttpResponseHeader]
responseHeaders bodyReader :: 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
update :: (typ ~ Binary)
=> HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> Verify (Some (HasFormat fs), RemoteTemp typ)
update :: HasFormat fs f
-> Trusted FileInfo
-> Path Absolute
-> Int54
-> Verify (Some (HasFormat fs), RemoteTemp typ)
update format :: HasFormat fs f
format info :: Trusted FileInfo
info cachedFile :: Path Absolute
cachedFile fileTail :: Int54
fileTail = do
Int54
currentSz <- IO Int54 -> Verify Int54
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 = (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
(tempPath :: Path Absolute
tempPath, h :: 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 (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
$ \statusCode :: HttpStatus
statusCode responseHeaders :: [HttpResponseHeader]
responseHeaders bodyReader :: BodyReader
bodyReader -> do
ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities ServerCapabilities
cfgCaps [HttpResponseHeader]
responseHeaders
let expectedSize :: FileSize
expectedSize =
case HttpStatus
statusCode of
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)
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 (m :: * -> *) a. Monad m => a -> m a
return HttpStatus
statusCode
let downloaded :: RemoteTemp Binary
downloaded =
case HttpStatus
statusCode of
HttpStatus206PartialContent ->
$WDownloadedDelta :: Path Absolute -> Path Absolute -> Int54 -> RemoteTemp Binary
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
}
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 :: HasFormat fs f
-> RemoteTemp typ -> Verify (Some (HasFormat fs), RemoteTemp typ)
cacheIfVerified format :: HasFormat fs f
format remoteTemp :: 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 (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{..} = HttpLib
cfgHttpLib
execBodyReader :: Throws SomeRemoteError
=> TargetPath
-> FileSize
-> Handle
-> BodyReader
-> IO ()
execBodyReader :: TargetPath -> FileSize -> Handle -> BodyReader -> IO ()
execBodyReader file :: TargetPath
file mlen :: FileSize
mlen h :: Handle
h br :: BodyReader
br = Int54 -> IO ()
go 0
where
go :: Int54 -> IO ()
go :: Int54 -> IO ()
go sz :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()
else Handle -> ByteString -> IO ()
BS.hPut Handle
h ByteString
bs IO () -> IO () -> IO ()
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))
data FileTooLarge = FileTooLarge {
FileTooLarge -> TargetPath
fileTooLargePath :: TargetPath
, FileTooLarge -> FileSize
fileTooLargeExpected :: FileSize
}
deriving (Typeable)
instance Pretty FileTooLarge where
pretty :: FileTooLarge -> String
pretty FileTooLarge{..} = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
"file returned by server too large: "
, TargetPath -> String
forall a. Pretty a => a -> String
pretty TargetPath
fileTooLargePath
, " (expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ FileSize -> String
expected FileSize
fileTooLargeExpected String -> ShowS
forall a. [a] -> [a] -> [a]
++ " bytes)"
]
where
expected :: FileSize -> String
expected :: FileSize -> String
expected (FileSizeExact n :: Int54
n) = "exactly " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int54 -> String
forall a. Show a => a -> String
show Int54
n
expected (FileSizeBound n :: Int54
n) = "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
remoteFileURI :: RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI :: RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI
remoteFileURI repoLayout :: RepoLayout
repoLayout baseURI :: URI
baseURI = (RepoPath -> URI) -> Formats fs RepoPath -> Formats fs URI
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
repoPath = URI -> (Path Web -> Path Web) -> URI
modifyUriPath URI
baseURI (Path Web -> RepoPath -> Path Web
`anchorRepoPathRemotely` RepoPath
repoPath)
remoteFileSize :: RemoteFile fs typ -> Formats fs FileSize
remoteFileSize :: RemoteFile fs typ -> Formats fs FileSize
remoteFileSize (RemoteFile fs typ
RemoteTimestamp) =
FileSize -> Formats fs FileSize
forall a. a -> Formats (FormatUn :- ()) a
FsUn (FileSize -> Formats fs FileSize)
-> FileSize -> Formats fs FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeBound Int54
fileSizeBoundTimestamp
remoteFileSize (RemoteRoot mLen :: Maybe (Trusted FileInfo)
mLen) =
FileSize -> Formats fs FileSize
forall a. a -> Formats (FormatUn :- ()) a
FsUn (FileSize -> Formats fs FileSize)
-> FileSize -> Formats fs 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 len :: Trusted FileInfo
len) =
FileSize -> Formats fs FileSize
forall a. a -> Formats (FormatUn :- ()) a
FsUn (FileSize -> Formats fs FileSize)
-> FileSize -> Formats fs FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
remoteFileSize (RemoteMirrors len :: Trusted FileInfo
len) =
FileSize -> Formats fs FileSize
forall a. a -> Formats (FormatUn :- ()) a
FsUn (FileSize -> Formats fs FileSize)
-> FileSize -> Formats fs FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
remoteFileSize (RemoteIndex _ lens :: Formats fs (Trusted FileInfo)
lens) =
(Trusted FileInfo -> FileSize)
-> Formats fs (Trusted FileInfo) -> Formats fs FileSize
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 _pkgId :: PackageIdentifier
_pkgId len :: Trusted FileInfo
len) =
FileSize -> Formats fs FileSize
forall a. a -> Formats (FormatGz :- ()) a
FsGz (FileSize -> Formats fs FileSize)
-> FileSize -> Formats fs FileSize
forall a b. (a -> b) -> a -> b
$ Int54 -> FileSize
FileSizeExact (Trusted FileInfo -> Int54
fileLength' Trusted FileInfo
len)
fileSizeBoundTimestamp :: Int54
fileSizeBoundTimestamp :: Int54
fileSizeBoundTimestamp = 4096
fileSizeBoundRoot :: Int54
fileSizeBoundRoot :: Int54
fileSizeBoundRoot = 2 Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
* 1024 Int54 -> Int54 -> Int54
forall a. Num a => a -> a -> a
* 2014
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
}
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
data RemoteTemp :: * -> * where
DownloadedWhole :: {
RemoteTemp a -> Path Absolute
wholeTemp :: Path Absolute
} -> RemoteTemp a
DownloadedDelta :: {
RemoteTemp Binary -> Path Absolute
deltaTemp :: Path Absolute
, RemoteTemp Binary -> Path Absolute
deltaExisting :: Path Absolute
, RemoteTemp Binary -> Int54
deltaSeek :: Int54
} -> RemoteTemp Binary
instance Pretty (RemoteTemp typ) where
pretty :: RemoteTemp typ -> String
pretty DownloadedWhole{..} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
"DownloadedWhole"
, Path Absolute -> String
forall a. Pretty a => a -> String
pretty Path Absolute
wholeTemp
]
pretty DownloadedDelta{..} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
"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 :: 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 :: RemoteTemp a -> Path Absolute -> IO ()
downloadedCopyTo = \f :: RemoteTemp a
f dest :: Path Absolute
dest ->
case RemoteTemp a
f of
DownloadedWhole{..} ->
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{..} -> 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 "Assertion failure: deltaExisting /= dest"
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
$ \h :: 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
verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool
verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool
verifyRemoteFile remoteTemp :: RemoteTemp typ
remoteTemp trustedInfo :: 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 (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 :: RemoteTemp typ -> IO Int54
remoteSize DownloadedWhole{..} = Path Absolute -> IO Int54
forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path Absolute
wholeTemp
remoteSize DownloadedDelta{..} = 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 (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
withRemoteBS :: RemoteTemp typ -> (BS.L.ByteString -> Bool) -> IO Bool
withRemoteBS :: RemoteTemp typ -> (ByteString -> Bool) -> IO Bool
withRemoteBS DownloadedWhole{..} callback :: 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
$ \h :: 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{..} callback :: 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
$ \hExisting :: 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
$ \hTemp :: 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
]