#if __GLASGOW_HASKELL__ >= 710
#endif
module Hackage.Security.Client (
checkForUpdates
, CheckExpiry(..)
, HasUpdates(..)
, downloadPackage
, getCabalFile
, requiresBootstrap
, bootstrap
, module Hackage.Security.TUF
, module Hackage.Security.Key
, Repository
, SomeRemoteError(..)
, LogMessage(..)
, uncheckClientErrors
, VerificationError(..)
, InvalidPackageException(..)
, InvalidFileInIndex(..)
, LocalFileCorrupted(..)
) where
import Prelude hiding (log)
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Cont
import Data.Maybe (isNothing)
import Data.Time
import Data.Traversable (for)
import Data.Typeable (Typeable)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS.L
import Distribution.Package (PackageIdentifier)
import Distribution.Text (display)
import Hackage.Security.Client.Repository
import Hackage.Security.Client.Formats
import Hackage.Security.JSON
import Hackage.Security.Key
import Hackage.Security.Key.Env (KeyEnv)
import Hackage.Security.Trusted
import Hackage.Security.Trusted.TCB
import Hackage.Security.TUF
import Hackage.Security.Util.Checked
import Hackage.Security.Util.Pretty
import Hackage.Security.Util.Stack
import Hackage.Security.Util.Some
import qualified Hackage.Security.Key.Env as KeyEnv
data CheckExpiry =
CheckExpiry
| DontCheckExpiry
deriving Show
data HasUpdates = HasUpdates | NoUpdates
deriving Show
checkForUpdates :: (Throws VerificationError, Throws SomeRemoteError)
=> Repository -> CheckExpiry -> IO HasUpdates
checkForUpdates rep checkExpiry =
withMirror rep $ limitIterations []
where
maxNumIterations :: Int
maxNumIterations = 5
limitIterations :: (Throws VerificationError, Throws SomeRemoteError)
=> VerificationHistory -> IO HasUpdates
limitIterations history | length history >= maxNumIterations =
throwChecked $ VerificationErrorLoop (reverse history)
limitIterations history = do
cachedInfo <- getCachedInfo rep
mNow <- case checkExpiry of
CheckExpiry -> Just <$> getCurrentTime
DontCheckExpiry -> return Nothing
mHasUpdates <- tryChecked
$ tryChecked
$ evalContT (go mNow isRetry cachedInfo)
case mHasUpdates of
Left ex -> do
log rep $ LogVerificationError ex
updateRoot rep mNow AfterVerificationError cachedInfo (Left ex)
limitIterations (Right ex : history)
Right (Left RootUpdated) -> do
log rep $ LogRootUpdated
limitIterations (Left RootUpdated : history)
Right (Right hasUpdates) ->
return hasUpdates
where
isRetry :: IsRetry
isRetry = if null history then FirstAttempt else AfterVerificationError
go :: Throws RootUpdated
=> Maybe UTCTime -> IsRetry -> CachedInfo -> ContT r IO HasUpdates
go mNow isRetry cachedInfo@CachedInfo{..} = do
newTS <- getRemoteFile' RemoteTimestamp
let newInfoSS = static timestampInfoSnapshot <$$> newTS
if not (fileChanged cachedInfoSnapshot newInfoSS)
then return NoUpdates
else do
newSS <- getRemoteFile' (RemoteSnapshot newInfoSS)
let newInfoRoot = static snapshotInfoRoot <$$> newSS
newInfoMirrors = static snapshotInfoMirrors <$$> newSS
newInfoTarGz = static snapshotInfoTarGz <$$> newSS
mNewInfoTar = trustSeq (static snapshotInfoTar <$$> newSS)
when (rootChanged cachedInfoRoot newInfoRoot) $ liftIO $ do
updateRoot rep mNow isRetry cachedInfo (Right newInfoRoot)
throwChecked RootUpdated
when (fileChanged cachedInfoMirrors newInfoMirrors) $
newMirrors =<< getRemoteFile' (RemoteMirrors newInfoMirrors)
when (fileChanged cachedInfoTarGz newInfoTarGz) $
updateIndex newInfoTarGz mNewInfoTar
return HasUpdates
where
getRemoteFile' :: ( VerifyRole a
, FromJSON ReadJSON_Keys_Layout (Signed a)
)
=> RemoteFile (f :- ()) -> ContT r IO (Trusted a)
getRemoteFile' = liftM fst . getRemoteFile rep cachedInfo isRetry mNow
updateIndex :: Trusted FileInfo
-> Maybe (Trusted FileInfo)
-> ContT r IO ()
updateIndex newInfoTarGz Nothing = do
(targetPath, tempPath) <- getRemote' rep isRetry $
RemoteIndex (HFZ FGz) (FsGz newInfoTarGz)
verifyFileInfo' (Just newInfoTarGz) targetPath tempPath
updateIndex newInfoTarGz (Just newInfoTar) = do
(format, targetPath, tempPath) <- getRemote rep isRetry $
RemoteIndex (HFS (HFZ FGz)) (FsUnGz newInfoTar newInfoTarGz)
case format of
Some FGz -> verifyFileInfo' (Just newInfoTarGz) targetPath tempPath
Some FUn -> verifyFileInfo' (Just newInfoTar) targetPath tempPath
rootChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool
rootChanged Nothing _ = False
rootChanged (Just old) new = not (trustedFileInfoEqual old new)
fileChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool
fileChanged Nothing _ = True
fileChanged (Just old) new = not (trustedFileInfoEqual old new)
newMirrors :: Trusted Mirrors -> ContT r IO ()
newMirrors _ = return ()
updateRoot :: (Throws VerificationError, Throws SomeRemoteError)
=> Repository
-> Maybe UTCTime
-> IsRetry
-> CachedInfo
-> Either VerificationError (Trusted FileInfo)
-> IO ()
updateRoot rep mNow isRetry cachedInfo eFileInfo = do
rootReallyChanged <- evalContT $ do
(_newRoot :: Trusted Root, rootTempFile) <- getRemoteFile
rep
cachedInfo
isRetry
mNow
(RemoteRoot (eitherToMaybe eFileInfo))
case eFileInfo of
Right _ ->
return True
Left _e -> liftIO $ do
oldRootFile <- repGetCachedRoot rep
oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile
not <$> verifyFileInfo rootTempFile oldRootInfo
when rootReallyChanged $ clearCache rep
data CachedInfo = CachedInfo {
cachedRoot :: Trusted Root
, cachedKeyEnv :: KeyEnv
, cachedTimestamp :: Maybe (Trusted Timestamp)
, cachedSnapshot :: Maybe (Trusted Snapshot)
, cachedMirrors :: Maybe (Trusted Mirrors)
, cachedInfoSnapshot :: Maybe (Trusted FileInfo)
, cachedInfoRoot :: Maybe (Trusted FileInfo)
, cachedInfoMirrors :: Maybe (Trusted FileInfo)
, cachedInfoTarGz :: Maybe (Trusted FileInfo)
}
cachedVersion :: CachedInfo -> RemoteFile fs -> Maybe FileVersion
cachedVersion CachedInfo{..} remoteFile =
case mustCache remoteFile of
CacheAs CachedTimestamp -> timestampVersion . trusted <$> cachedTimestamp
CacheAs CachedSnapshot -> snapshotVersion . trusted <$> cachedSnapshot
CacheAs CachedMirrors -> mirrorsVersion . trusted <$> cachedMirrors
CacheAs CachedRoot -> Just . rootVersion . trusted $ cachedRoot
CacheIndex -> Nothing
DontCache -> Nothing
getCachedInfo :: (Applicative m, MonadIO m) => Repository -> m CachedInfo
getCachedInfo rep = do
(cachedRoot, cachedKeyEnv) <- readLocalRoot rep
cachedTimestamp <- readLocalFile rep cachedKeyEnv CachedTimestamp
cachedSnapshot <- readLocalFile rep cachedKeyEnv CachedSnapshot
cachedMirrors <- readLocalFile rep cachedKeyEnv CachedMirrors
let cachedInfoSnapshot = fmap (static timestampInfoSnapshot <$$>) cachedTimestamp
cachedInfoRoot = fmap (static snapshotInfoRoot <$$>) cachedSnapshot
cachedInfoMirrors = fmap (static snapshotInfoMirrors <$$>) cachedSnapshot
cachedInfoTarGz = fmap (static snapshotInfoTarGz <$$>) cachedSnapshot
return CachedInfo{..}
readLocalRoot :: MonadIO m => Repository -> m (Trusted Root, KeyEnv)
readLocalRoot rep = do
cachedPath <- liftIO $ repGetCachedRoot rep
signedRoot <- throwErrorsUnchecked LocalFileCorrupted =<<
readJSON (repLayout rep) KeyEnv.empty cachedPath
return (trustLocalFile signedRoot, rootKeys (signed signedRoot))
readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a)
, MonadIO m, Applicative m
)
=> Repository -> KeyEnv -> CachedFile -> m (Maybe (Trusted a))
readLocalFile rep cachedKeyEnv file = do
mCachedPath <- liftIO $ repGetCached rep file
for mCachedPath $ \cachedPath -> do
signed <- throwErrorsUnchecked LocalFileCorrupted =<<
readJSON (repLayout rep) cachedKeyEnv cachedPath
return $ trustLocalFile signed
getRemoteFile :: ( Throws VerificationError
, Throws SomeRemoteError
, VerifyRole a
, FromJSON ReadJSON_Keys_Layout (Signed a)
)
=> Repository
-> CachedInfo
-> IsRetry
-> Maybe UTCTime
-> RemoteFile (f :- ())
-> ContT r IO (Trusted a, TempPath)
getRemoteFile rep cachedInfo@CachedInfo{..} isRetry mNow file = do
(targetPath, tempPath) <- getRemote' rep isRetry file
verifyFileInfo' (remoteFileDefaultInfo file) targetPath tempPath
signed <- throwErrorsChecked SomeRemoteError =<<
readJSON (repLayout rep) cachedKeyEnv tempPath
verified <- throwErrorsChecked id $ verifyRole
cachedRoot
targetPath
(cachedVersion cachedInfo file)
mNow
signed
return (trustVerified verified, tempPath)
downloadPackage :: ( Throws SomeRemoteError
, Throws VerificationError
, Throws InvalidPackageException
)
=> Repository -> PackageIdentifier -> (TempPath -> IO a) -> IO a
downloadPackage rep pkgId callback = withMirror rep $ evalContT $ do
(_cachedRoot, keyEnv) <- readLocalRoot rep
let trustIndex :: Signed a -> Trusted a
trustIndex = trustLocalFile
targets :: Trusted Targets <- do
let indexFile = IndexPkgMetadata pkgId
mRaw <- getFromIndex rep indexFile
case mRaw of
Nothing -> liftIO $ throwChecked $ InvalidPackageException pkgId
Just raw -> do
signed <- throwErrorsUnchecked (InvalidFileInIndex indexFile) $
parseJSON_Keys_NoLayout keyEnv raw
return $ trustIndex signed
let filePath :: TargetPath
filePath = TargetPathRepo $ repoLayoutPkgTarGz (repLayout rep) pkgId
let mTargetMetaData :: Maybe (Trusted FileInfo)
mTargetMetaData = trustSeq
$ trustStatic (static targetsLookup)
`trustApply` DeclareTrusted filePath
`trustApply` targets
targetMetaData :: Trusted FileInfo
<- case mTargetMetaData of
Nothing -> liftIO $
throwChecked $ VerificationErrorUnknownTarget filePath
Just nfo ->
return nfo
tarGz <- do
(targetPath, tempPath) <- getRemote' rep FirstAttempt $
RemotePkgTarGz pkgId targetMetaData
verifyFileInfo' (Just targetMetaData) targetPath tempPath
return tempPath
liftIO $ callback tarGz
getCabalFile :: Throws InvalidPackageException
=> Repository -> PackageIdentifier -> IO BS.ByteString
getCabalFile rep pkgId = do
mCabalFile <- repGetFromIndex rep (IndexPkgCabal pkgId)
case mCabalFile of
Just cabalFile -> return cabalFile
Nothing -> throwChecked $ InvalidPackageException pkgId
requiresBootstrap :: Repository -> IO Bool
requiresBootstrap rep = isNothing <$> repGetCached rep CachedRoot
bootstrap :: (Throws SomeRemoteError, Throws VerificationError)
=> Repository -> [KeyId] -> KeyThreshold -> IO ()
bootstrap rep trustedRootKeys keyThreshold = withMirror rep $ evalContT $ do
_newRoot :: Trusted Root <- do
(targetPath, tempPath) <- getRemote' rep FirstAttempt (RemoteRoot Nothing)
signed <- throwErrorsChecked SomeRemoteError =<<
readJSON (repLayout rep) KeyEnv.empty tempPath
verified <- throwErrorsChecked id $ verifyFingerprints
trustedRootKeys
keyThreshold
targetPath
signed
return $ trustVerified verified
clearCache rep
getRemote :: forall fs r. (Throws SomeRemoteError, Throws VerificationError)
=> Repository
-> IsRetry
-> RemoteFile fs
-> ContT r IO (Some Format, TargetPath, TempPath)
getRemote r isRetry file = ContT aux
where
aux :: ((Some Format, TargetPath, TempPath) -> IO r) -> IO r
aux k = repWithRemote r isRetry file (wrapK k)
wrapK :: ((Some Format, TargetPath, TempPath) -> IO r)
-> (forall f. HasFormat fs f -> TempPath -> IO r)
wrapK k format tempPath =
k (Some (hasFormatGet format), targetPath, tempPath)
where
targetPath :: TargetPath
targetPath = TargetPathRepo $ remoteRepoPath' (repLayout r) file format
getRemote' :: forall f r. (Throws SomeRemoteError, Throws VerificationError)
=> Repository
-> IsRetry
-> RemoteFile (f :- ())
-> ContT r IO (TargetPath, TempPath)
getRemote' r isRetry file = ignoreFormat <$> getRemote r isRetry file
where
ignoreFormat (_format, targetPath, tempPath) = (targetPath, tempPath)
clearCache :: MonadIO m => Repository -> m ()
clearCache r = liftIO $ repClearCache r
log :: MonadIO m => Repository -> LogMessage -> m ()
log r msg = liftIO $ repLog r msg
getFromIndex :: MonadIO m
=> Repository
-> IndexFile
-> m (Maybe BS.L.ByteString)
getFromIndex r file = liftIO $
fmap tr <$> repGetFromIndex r file
where
tr :: BS.ByteString -> BS.L.ByteString
tr = BS.L.fromChunks . (:[])
withMirror :: Repository -> IO a -> IO a
withMirror rep callback = do
mMirrors <- repGetCached rep CachedMirrors
mirrors <- case mMirrors of
Nothing -> return Nothing
Just fp -> filterMirrors <$>
(throwErrorsUnchecked LocalFileCorrupted =<<
readJSON_NoKeys_NoLayout fp)
repWithMirror rep mirrors $ callback
where
filterMirrors :: UninterpretedSignatures Mirrors -> Maybe [Mirror]
filterMirrors = Just
. filter (canUseMirror . mirrorContent)
. mirrorsMirrors
. uninterpretedSigned
canUseMirror :: MirrorContent -> Bool
canUseMirror MirrorFull = True
uncheckClientErrors :: ( ( Throws VerificationError
, Throws SomeRemoteError
, Throws InvalidPackageException
) => IO a )
-> IO a
uncheckClientErrors act = handleChecked rethrowVerificationError
$ handleChecked rethrowSomeRemoteError
$ handleChecked rethrowInvalidPackageException
$ act
where
rethrowVerificationError :: VerificationError -> IO a
rethrowVerificationError = throwIO
rethrowSomeRemoteError :: SomeRemoteError -> IO a
rethrowSomeRemoteError = throwIO
rethrowInvalidPackageException :: InvalidPackageException -> IO a
rethrowInvalidPackageException = throwIO
data InvalidPackageException = InvalidPackageException PackageIdentifier
deriving (Typeable)
data LocalFileCorrupted = LocalFileCorrupted DeserializationError
deriving (Typeable)
data InvalidFileInIndex = InvalidFileInIndex IndexFile DeserializationError
deriving (Typeable)
#if MIN_VERSION_base(4,8,0)
deriving instance Show InvalidPackageException
deriving instance Show LocalFileCorrupted
deriving instance Show InvalidFileInIndex
instance Exception InvalidPackageException where displayException = pretty
instance Exception LocalFileCorrupted where displayException = pretty
instance Exception InvalidFileInIndex where displayException = pretty
#else
instance Show InvalidPackageException where show = pretty
instance Show LocalFileCorrupted where show = pretty
instance Show InvalidFileInIndex where show = pretty
instance Exception InvalidPackageException
instance Exception LocalFileCorrupted
instance Exception InvalidFileInIndex
#endif
instance Pretty InvalidPackageException where
pretty (InvalidPackageException pkgId) = "Invalid package " ++ display pkgId
instance Pretty LocalFileCorrupted where
pretty (LocalFileCorrupted err) = "Local file corrupted: " ++ pretty err
instance Pretty InvalidFileInIndex where
pretty (InvalidFileInIndex file err) = "Invalid file " ++ pretty file
++ "in index: " ++ pretty err
trustLocalFile :: Signed a -> Trusted a
trustLocalFile Signed{..} = DeclareTrusted signed
verifyFileInfo' :: MonadIO m
=> Maybe (Trusted FileInfo)
-> TargetPath
-> TempPath
-> m ()
verifyFileInfo' Nothing _ _ = return ()
verifyFileInfo' (Just info) targetPath tempPath = liftIO $ do
verified <- verifyFileInfo tempPath info
unless verified $ throw $ VerificationErrorFileInfo targetPath
readJSON :: (MonadIO m, FromJSON ReadJSON_Keys_Layout a)
=> RepoLayout -> KeyEnv -> TempPath
-> m (Either DeserializationError a)
readJSON repoLayout keyEnv fpath = liftIO $
readJSON_Keys_Layout keyEnv repoLayout fpath
throwErrorsUnchecked :: ( MonadIO m
, Exception e'
)
=> (e -> e') -> Either e a -> m a
throwErrorsUnchecked f (Left err) = liftIO $ throwUnchecked (f err)
throwErrorsUnchecked _ (Right a) = return a
throwErrorsChecked :: ( Throws e'
, MonadIO m
, Exception e'
)
=> (e -> e') -> Either e a -> m a
throwErrorsChecked f (Left err) = liftIO $ throwChecked (f err)
throwErrorsChecked _ (Right a) = return a
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right b) = Just b