module Hackage.Security.Client.Repository.Remote (
withRepository
, RepoOpts(..)
, defaultRepoOpts
, FileSize(..)
, fileSizeWithinBounds
) where
import Control.Concurrent
import Control.Exception
import Control.Monad.Cont
import Control.Monad.Except
import Data.List (nub)
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.Trusted
import Hackage.Security.TUF
import Hackage.Security.Util.Checked
import Hackage.Security.Util.IO
import Hackage.Security.Util.Path
import Hackage.Security.Util.Some
import qualified Hackage.Security.Client.Repository.Cache as Cache
newtype ServerCapabilities = SC (MVar ServerCapabilities_)
data ServerCapabilities_ = ServerCapabilities {
serverAcceptRangesBytes :: Bool
}
newServerCapabilities :: IO ServerCapabilities
newServerCapabilities = SC <$> newMVar ServerCapabilities {
serverAcceptRangesBytes = False
}
updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO ()
updateServerCapabilities (SC mv) responseHeaders = modifyMVar_ mv $ \caps ->
return $ caps {
serverAcceptRangesBytes = serverAcceptRangesBytes caps
|| HttpResponseAcceptRangesBytes `elem` responseHeaders
}
checkServerCapability :: MonadIO m
=> ServerCapabilities -> (ServerCapabilities_ -> a) -> m a
checkServerCapability (SC mv) f = liftIO $ withMVar mv $ return . f
data FileSize =
FileSizeExact Int
| FileSizeBound Int
fileSizeWithinBounds :: Int -> FileSize -> Bool
fileSizeWithinBounds sz (FileSizeExact sz') = sz <= sz'
fileSizeWithinBounds sz (FileSizeBound sz') = sz <= sz'
data RepoOpts = RepoOpts {
repoAllowContentCompression :: Bool
, repoWantCompressedIndex :: Bool
, repoAllowAdditionalMirrors :: Bool
}
defaultRepoOpts :: RepoOpts
defaultRepoOpts = RepoOpts {
repoAllowContentCompression = True
, repoWantCompressedIndex = False
, repoAllowAdditionalMirrors = True
}
withRepository
:: HttpLib
-> [URI]
-> RepoOpts
-> Cache
-> RepoLayout
-> (LogMessage -> IO ())
-> (Repository -> IO a)
-> IO a
withRepository httpLib
outOfBandMirrors
repoOpts
cache
repLayout
logger
callback
= do
selectedMirror <- newMVar Nothing
caps <- newServerCapabilities
let remoteConfig mirror = RemoteConfig {
cfgLayout = repLayout
, cfgHttpLib = httpLib
, cfgBase = mirror
, cfgCache = cache
, cfgCaps = caps
, cfgLogger = logger
, cfgOpts = repoOpts
}
callback Repository {
repWithRemote = withRemote remoteConfig selectedMirror
, repGetCached = Cache.getCached cache
, repGetCachedRoot = Cache.getCachedRoot cache
, repClearCache = Cache.clearCache cache
, repGetFromIndex = Cache.getFromIndex cache (repoIndexLayout repLayout)
, repWithMirror = withMirror httpLib
selectedMirror
logger
outOfBandMirrors
repoOpts
, repLog = logger
, repLayout = repLayout
, repDescription = "Remote repository at " ++ show outOfBandMirrors
}
type SelectedMirror = MVar (Maybe URI)
getSelectedMirror :: SelectedMirror -> IO URI
getSelectedMirror selectedMirror = do
mBaseURI <- readMVar selectedMirror
case mBaseURI of
Nothing -> internalError "Internal error: no mirror selected"
Just baseURI -> return baseURI
withRemote :: (Throws VerificationError, Throws SomeRemoteError)
=> (URI -> RemoteConfig)
-> SelectedMirror
-> IsRetry
-> RemoteFile fs
-> (forall f. HasFormat fs f -> TempPath -> IO a)
-> IO a
withRemote remoteConfig selectedMirror isRetry remoteFile callback = do
baseURI <- getSelectedMirror selectedMirror
withRemote' (remoteConfig baseURI) isRetry remoteFile callback
withRemote' :: (Throws VerificationError, Throws SomeRemoteError)
=> RemoteConfig
-> IsRetry
-> RemoteFile fs
-> (forall f. HasFormat fs f -> TempPath -> IO a)
-> IO a
withRemote' cfg isRetry remoteFile callback =
getFile cfg isRetry remoteFile callback =<< pickDownloadMethod cfg remoteFile
httpRequestHeaders :: RemoteConfig
-> IsRetry
-> DownloadMethod fs
-> [HttpRequestHeader]
httpRequestHeaders RemoteConfig{..} isRetry method =
case isRetry of
FirstAttempt -> defaultHeaders
AfterVerificationError -> HttpRequestMaxAge0 : defaultHeaders
where
defaultHeaders :: [HttpRequestHeader]
defaultHeaders = concat [
[ HttpRequestNoTransform ]
, [ HttpRequestContentCompression
| repoAllowContentCompression cfgOpts && not (isRangeRequest method)
]
]
isRangeRequest :: DownloadMethod fs -> Bool
isRangeRequest NeverUpdated{} = False
isRangeRequest CannotUpdate{} = False
isRangeRequest Update{} = True
withMirror :: forall a.
HttpLib
-> SelectedMirror
-> (LogMessage -> IO ())
-> [URI]
-> RepoOpts
-> Maybe [Mirror]
-> IO a
-> IO a
withMirror HttpLib{..}
selectedMirror
logger
oobMirrors
repoOpts
tufMirrors
callback
=
go orderedMirrors
where
go :: [URI] -> IO a
go [] = internalError "No mirrors configured"
go [m] = do
logger $ LogSelectedMirror (show m)
select m $ callback
go (m:ms) = do
logger $ LogSelectedMirror (show m)
catchChecked (select m callback) $ \ex -> do
logger $ LogMirrorFailed (show m) ex
go ms
orderedMirrors :: [URI]
orderedMirrors = nub $ concat [
oobMirrors
, if repoAllowAdditionalMirrors repoOpts
then maybe [] (map mirrorUrlBase) tufMirrors
else []
]
select :: URI -> IO a -> IO a
select uri =
bracket_ (modifyMVar_ selectedMirror $ \_ -> return $ Just uri)
(modifyMVar_ selectedMirror $ \_ -> return Nothing)
data DownloadMethod fs =
forall f. NeverUpdated {
downloadFormat :: HasFormat fs f
}
| forall f. CannotUpdate {
downloadFormat :: HasFormat fs f
, downloadReason :: UpdateFailure
}
| forall f f'. Update {
updateFormat :: HasFormat fs f
, updateInfo :: Trusted FileInfo
, updateLocal :: AbsolutePath
, updateTrailer :: Integer
, downloadFormat :: HasFormat fs f'
}
pickDownloadMethod :: RemoteConfig
-> RemoteFile fs
-> IO (DownloadMethod fs)
pickDownloadMethod RemoteConfig{..} remoteFile = multipleExitPoints $ do
(hasGz, formats) <- case remoteFile of
RemoteTimestamp -> exit $ NeverUpdated (HFZ FUn)
(RemoteRoot _) -> exit $ NeverUpdated (HFZ FUn)
(RemoteSnapshot _) -> exit $ NeverUpdated (HFZ FUn)
(RemoteMirrors _) -> exit $ NeverUpdated (HFZ FUn)
(RemotePkgTarGz _ _) -> exit $ NeverUpdated (HFZ FGz)
(RemoteIndex pf fs) -> return (pf, fs)
when (repoWantCompressedIndex cfgOpts) $
exit $ CannotUpdate hasGz UpdateNotUsefulWantsCompressed
hasUn <- case formatsMember FUn formats of
Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleOnlyCompressed
Just hasUn -> return hasUn
rangeSupport <- checkServerCapability cfgCaps serverAcceptRangesBytes
unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported
mCachedIndex <- lift $ Cache.getCachedIndex cfgCache
cachedIndex <- case mCachedIndex of
Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy
Just fp -> return fp
let trailerLength = 1024
localSize <- liftIO $ getFileSize cachedIndex
let infoGz = formatsLookup hasGz formats
infoUn = formatsLookup hasUn formats
updateSize = fileLength' infoUn fromIntegral localSize
unless (updateSize < fileLength' infoGz) $
exit $ CannotUpdate hasGz UpdateTooLarge
return Update {
updateFormat = hasUn
, updateInfo = infoUn
, updateLocal = cachedIndex
, updateTrailer = trailerLength
, downloadFormat = hasGz
}
getFile :: forall fs a. (Throws VerificationError, Throws SomeRemoteError)
=> RemoteConfig
-> IsRetry
-> RemoteFile fs
-> (forall f. HasFormat fs f -> TempPath -> IO a)
-> DownloadMethod fs
-> IO a
getFile cfg@RemoteConfig{..} isRetry remoteFile callback method =
go method
where
go :: (Throws VerificationError, Throws SomeRemoteError)
=> DownloadMethod fs -> IO a
go NeverUpdated{..} = do
cfgLogger $ LogDownloading (Some remoteFile)
download downloadFormat
go CannotUpdate{..} = do
cfgLogger $ LogCannotUpdate (Some remoteFile) downloadReason
cfgLogger $ LogDownloading (Some remoteFile)
download downloadFormat
go Update{..} = do
cfgLogger $ LogUpdating (Some remoteFile)
let updateFailed :: SomeException -> IO a
updateFailed = go . CannotUpdate downloadFormat . UpdateFailed
handleVerificationError :: VerificationError -> IO a
handleVerificationError ex =
case isRetry of
FirstAttempt -> throwChecked ex
_otherwise -> updateFailed $ SomeException ex
handleHttpException :: SomeRemoteError -> IO a
handleHttpException = updateFailed . SomeException
handleChecked handleVerificationError $
handleChecked handleHttpException $
update updateFormat updateInfo updateLocal updateTrailer
headers :: [HttpRequestHeader]
headers = httpRequestHeaders cfg isRetry method
download :: Throws SomeRemoteError => HasFormat fs f -> IO a
download format =
withTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri) $ \tempPath h -> do
httpGet headers uri $ \responseHeaders bodyReader -> do
updateServerCapabilities cfgCaps responseHeaders
execBodyReader targetPath sz h bodyReader
hClose h
verifyAndCache format tempPath
where
targetPath = TargetPathRepo $ remoteRepoPath' cfgLayout remoteFile format
uri = formatsLookup format $ remoteFileURI cfgLayout cfgBase remoteFile
sz = formatsLookup format $ remoteFileSize remoteFile
update :: HasFormat fs f
-> Trusted FileInfo
-> AbsolutePath
-> Integer
-> IO a
update format info cachedFile trailer = do
currentSize <- getFileSize cachedFile
let currentMinusTrailer = currentSize trailer
fileSz = fileLength' info
range = (fromInteger currentMinusTrailer, fileSz)
rangeSz = FileSizeExact (snd range fst range)
withTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri) $ \tempPath h -> do
BS.L.hPut h =<< readLazyByteString cachedFile
hSeek h AbsoluteSeek currentMinusTrailer
httpGetRange headers uri range $ \responseHeaders bodyReader -> do
updateServerCapabilities cfgCaps responseHeaders
execBodyReader targetPath rangeSz h bodyReader
hClose h
verifyAndCache format tempPath
where
targetPath = TargetPathRepo repoLayoutIndexTar
uri = modifyUriPath cfgBase (`anchorRepoPathRemotely` repoLayoutIndexTar)
RepoLayout{repoLayoutIndexTar} = cfgLayout
verifyAndCache :: HasFormat fs f -> AbsolutePath -> IO a
verifyAndCache format tempPath = do
result <- callback format tempPath
Cache.cacheRemoteFile cfgCache
tempPath
(hasFormatGet format)
(mustCache remoteFile)
return result
HttpLib{..} = cfgHttpLib
execBodyReader :: Throws VerificationError
=> TargetPath
-> FileSize
-> Handle
-> BodyReader
-> IO ()
execBodyReader file mlen h br = go 0
where
go :: Int -> IO ()
go sz = do
unless (sz `fileSizeWithinBounds` mlen) $
throwChecked $ VerificationErrorFileTooLarge file
bs <- br
if BS.null bs
then return ()
else BS.hPut h bs >> go (sz + BS.length bs)
remoteFileURI :: RepoLayout -> URI -> RemoteFile fs -> Formats fs URI
remoteFileURI repoLayout baseURI = fmap aux . remoteRepoPath repoLayout
where
aux :: RepoPath -> URI
aux repoPath = modifyUriPath baseURI (`anchorRepoPathRemotely` repoPath)
remoteFileSize :: RemoteFile fs -> Formats fs FileSize
remoteFileSize (RemoteTimestamp) =
FsUn $ FileSizeBound fileSizeBoundTimestamp
remoteFileSize (RemoteRoot mLen) =
FsUn $ maybe (FileSizeBound fileSizeBoundRoot)
(FileSizeExact . fileLength')
mLen
remoteFileSize (RemoteSnapshot len) =
FsUn $ FileSizeExact (fileLength' len)
remoteFileSize (RemoteMirrors len) =
FsUn $ FileSizeExact (fileLength' len)
remoteFileSize (RemoteIndex _ lens) =
fmap (FileSizeExact . fileLength') lens
remoteFileSize (RemotePkgTarGz _pkgId len) =
FsGz $ FileSizeExact (fileLength' len)
fileSizeBoundTimestamp :: Int
fileSizeBoundTimestamp = 4096
fileSizeBoundRoot :: Int
fileSizeBoundRoot = 2 * 1024 * 2014
data RemoteConfig = RemoteConfig {
cfgLayout :: RepoLayout
, cfgHttpLib :: HttpLib
, cfgBase :: URI
, cfgCache :: Cache
, cfgCaps :: ServerCapabilities
, cfgLogger :: LogMessage -> IO ()
, cfgOpts :: RepoOpts
}
uriTemplate :: URI -> String
uriTemplate = unFragment . takeFileName . uriPath
fileLength' :: Trusted FileInfo -> Int
fileLength' = fileLength . fileInfoLength . trusted
multipleExitPoints :: Monad m => ExceptT a m a -> m a
multipleExitPoints = liftM aux . runExceptT
where
aux :: Either a a -> a
aux (Left a) = a
aux (Right a) = a
exit :: Monad m => e -> ExceptT e m a
exit = throwError