{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE StaticPointers #-} #endif -- | Main entry point into the Hackage Security framework for clients module Hackage.Security.Client ( -- * Checking for updates checkForUpdates , HasUpdates(..) -- * Downloading targets , downloadPackage , downloadPackage' -- * Access to the Hackage index , Directory(..) , DirectoryEntry(..) , getDirectory , IndexFile(..) , IndexEntry(..) , IndexCallbacks(..) , withIndex -- * Bootstrapping , requiresBootstrap , bootstrap -- * Re-exports , module Hackage.Security.TUF , module Hackage.Security.Key , trusted -- ** We only a few bits from .Repository -- TODO: Maybe this is a sign that these should be in a different module? , Repository -- opaque , DownloadedFile(..) , SomeRemoteError(..) , LogMessage(..) -- * Exceptions , uncheckClientErrors , VerificationError(..) , VerificationHistory , RootUpdated(..) , InvalidPackageException(..) , InvalidFileInIndex(..) , LocalFileCorrupted(..) ) where import Prelude hiding (log) import Control.Arrow (first) import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.List (sortBy) import Data.Maybe (isNothing) import Data.Ord (comparing) import Data.Time import Data.Traversable (for) import Data.Typeable (Typeable) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Data.ByteString.Lazy as BS.L import qualified Data.ByteString.Lazy.Char8 as BS.L.C8 import Distribution.Package (PackageIdentifier) import Distribution.Text (display) import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.Client.Verify 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.Path import Hackage.Security.Util.Pretty import Hackage.Security.Util.Some import Hackage.Security.Util.Stack import qualified Hackage.Security.Key.Env as KeyEnv {------------------------------------------------------------------------------- Checking for updates -------------------------------------------------------------------------------} data HasUpdates = HasUpdates | NoUpdates deriving (Show, Eq, Ord) -- | Generic logic for checking if there are updates -- -- This implements the logic described in Section 5.1, "The client application", -- of the TUF spec. It checks which of the server metadata has changed, and -- downloads all changed metadata to the local cache. (Metadata here refers -- both to the TUF security metadata as well as the Hackage packge index.) -- -- You should pass @Nothing@ for the UTCTime _only_ under exceptional -- circumstances (such as when the main server is down for longer than the -- expiry dates used in the timestamp files on mirrors). checkForUpdates :: (Throws VerificationError, Throws SomeRemoteError) => Repository down -> Maybe UTCTime -- ^ To check expiry times against (if using) -> IO HasUpdates checkForUpdates rep@Repository{..} mNow = withMirror rep $ limitIterations [] where -- More or less randomly chosen maximum iterations -- See . maxNumIterations :: Int maxNumIterations = 5 -- The spec stipulates that on a verification error we must download new -- root information and start over. However, in order to prevent DoS attacks -- we limit how often we go round this loop. -- See als . limitIterations :: VerificationHistory -> IO HasUpdates limitIterations history | length history >= maxNumIterations = throwChecked $ VerificationErrorLoop (reverse history) limitIterations history = do -- Get all cached info -- -- NOTE: Although we don't normally update any cached files until the -- whole verification process successfully completes, in case of a -- verification error, or in case of a regular update of the root info, -- we DO update the local files. Hence, we must re-read all local files -- on each iteration. cachedInfo <- getCachedInfo rep mHasUpdates <- tryChecked -- catch RootUpdated $ tryChecked -- catch VerificationError $ runVerify repLockCache $ go attemptNr cachedInfo case mHasUpdates of Left ex -> do -- NOTE: This call to updateRoot is not itself protected by an -- exception handler, and may therefore throw a VerificationError. -- This is intentional: if we get verification errors during the -- update process, _and_ we cannot update the main root info, then -- we cannot do anything. log rep $ LogVerificationError ex let history' = Right ex : history attemptNr' = attemptNr + 1 updateRoot rep mNow attemptNr' cachedInfo (Left ex) limitIterations history' Right (Left RootUpdated) -> do log rep $ LogRootUpdated let history' = Left RootUpdated : history limitIterations history' Right (Right hasUpdates) -> return hasUpdates where attemptNr :: AttemptNr attemptNr = fromIntegral $ length history -- The 'Verify' monad only caches the downloaded files after verification. -- See also . go :: Throws RootUpdated => AttemptNr -> CachedInfo -> Verify HasUpdates go attemptNr cachedInfo@CachedInfo{..} = do -- Get the new timestamp newTS <- getRemoteFile' RemoteTimestamp let newInfoSS = static timestampInfoSnapshot <$$> newTS -- Check if the snapshot has changed if not (fileChanged cachedInfoSnapshot newInfoSS) then return NoUpdates else do -- Get the new snapshot newSS <- getRemoteFile' (RemoteSnapshot newInfoSS) let newInfoRoot = static snapshotInfoRoot <$$> newSS newInfoMirrors = static snapshotInfoMirrors <$$> newSS newInfoTarGz = static snapshotInfoTarGz <$$> newSS mNewInfoTar = trustElems (static snapshotInfoTar <$$> newSS) -- If root metadata changed, download and restart when (rootChanged cachedInfoRoot newInfoRoot) $ liftIO $ do updateRoot rep mNow attemptNr cachedInfo (Right newInfoRoot) -- By throwing 'RootUpdated' as an exception we make sure that -- any files previously downloaded (to temporary locations) -- will not be cached. throwChecked RootUpdated -- If mirrors changed, download and verify when (fileChanged cachedInfoMirrors newInfoMirrors) $ newMirrors =<< getRemoteFile' (RemoteMirrors newInfoMirrors) -- If index changed, download and verify when (fileChanged cachedInfoTarGz newInfoTarGz) $ updateIndex newInfoTarGz mNewInfoTar return HasUpdates where getRemoteFile' :: ( VerifyRole a , FromJSON ReadJSON_Keys_Layout (Signed a) ) => RemoteFile (f :- ()) Metadata -> Verify (Trusted a) getRemoteFile' = liftM fst . getRemoteFile rep cachedInfo attemptNr mNow -- Update the index and check against the appropriate hash updateIndex :: Trusted FileInfo -- info about @.tar.gz@ -> Maybe (Trusted FileInfo) -- info about @.tar@ -> Verify () updateIndex newInfoTarGz Nothing = do (targetPath, tempPath) <- getRemote' rep attemptNr $ RemoteIndex (HFZ FGz) (FsGz newInfoTarGz) verifyFileInfo' (Just newInfoTarGz) targetPath tempPath updateIndex newInfoTarGz (Just newInfoTar) = do (format, targetPath, tempPath) <- getRemote rep attemptNr $ RemoteIndex (HFS (HFZ FGz)) (FsUnGz newInfoTar newInfoTarGz) case format of Some FGz -> verifyFileInfo' (Just newInfoTarGz) targetPath tempPath Some FUn -> verifyFileInfo' (Just newInfoTar) targetPath tempPath -- Unlike for other files, if we didn't have an old snapshot, consider the -- root info unchanged (otherwise we would loop indefinitely). -- See also rootChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool rootChanged Nothing _ = False rootChanged (Just old) new = not (trustedFileInfoEqual old new) -- For any file other than the root we consider the file to have changed -- if we do not yet have a local snapshot to tell us the old info. fileChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool fileChanged Nothing _ = True fileChanged (Just old) new = not (trustedFileInfoEqual old new) -- We don't actually _do_ anything with the mirrors file until the next call -- to 'checkUpdates', because we want to use a single server for a single -- check-for-updates request. If validation was successful the repository -- will have cached the mirrors file and it will be available on the next -- request. newMirrors :: Trusted Mirrors -> Verify () newMirrors _ = return () -- | Update the root metadata -- -- Note that the new root metadata is verified using the old root metadata, -- and only then trusted. -- -- We don't always have root file information available. If we notice during -- the normal update process that the root information has changed then the -- snapshot will give us the new file information; but if we need to update -- the root information due to a verification error we do not. -- -- We additionally delete the cached cached snapshot and timestamp. This is -- necessary for two reasons: -- -- 1. If during the normal update process we notice that the root info was -- updated (because the hash of @root.json@ in the new snapshot is different -- from the old snapshot) we download new root info and start over, without -- (yet) downloading a (potential) new index. This means it is important that -- we not overwrite our local cached snapshot, because if we did we would -- then on the next iteration conclude there were no updates and we would -- fail to notice that we should have updated the index. However, unless we -- do something, this means that we would conclude on the next iteration once -- again that the root info has changed (because the hash in the new shapshot -- still doesn't match the hash in the cached snapshot), and we would loop -- until we throw a 'VerificationErrorLoop' exception. By deleting the local -- snapshot we basically reset the client to its initial state, and we will -- not try to download the root info once again. The only downside of this is -- that we will also re-download the index after every root info change. -- However, this should be infrequent enough that this isn't an issue. -- See also . -- -- 2. Additionally, deleting the local timestamp and snapshot protects against -- an attack where an attacker has set the file version of the snapshot or -- timestamp to MAX_INT, thereby making further updates impossible. -- (Such an attack would require a timestamp/snapshot key compromise.) -- -- However, we _ONLY_ do this when the root information has actually changed. -- If we did this unconditionally it would mean that we delete the locally -- cached timestamp whenever the version on the remote timestamp is invalid, -- thereby rendering the file version on the timestamp and the snapshot useless. -- See updateRoot :: (Throws VerificationError, Throws SomeRemoteError) => Repository down -> Maybe UTCTime -> AttemptNr -> CachedInfo -> Either VerificationError (Trusted FileInfo) -> IO () updateRoot rep@Repository{..} mNow isRetry cachedInfo eFileInfo = do rootReallyChanged <- runVerify repLockCache $ do (_newRoot :: Trusted Root, rootTempFile) <- getRemoteFile rep cachedInfo isRetry mNow (RemoteRoot (eitherToMaybe eFileInfo)) -- NOTE: It is important that we do this check within the evalContT, -- because the temporary file will be deleted once we leave its scope. case eFileInfo of Right _ -> -- We are downloading the root info because the hash in the snapshot -- changed. In this case the root definitely changed. return True Left _e -> liftIO $ do -- We are downloading the root because of a verification error. In -- this case the root info may or may not have changed. In most cases -- it would suffice to compare the file version now; however, in the -- (exceptional) circumstance where the root info has changed but -- the file version has not, this would result in the same infinite -- loop described above. Hence, we must compare file hashes, and they -- must be computed on the raw file, not the parsed file. oldRootFile <- repGetCachedRoot oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile not <$> downloadedVerify rootTempFile oldRootInfo when rootReallyChanged $ clearCache rep {------------------------------------------------------------------------------- Convenience functions for downloading and parsing various files -------------------------------------------------------------------------------} 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 typ -> 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 -- | Get all cached info (if any) getCachedInfo :: #if __GLASGOW_HASKELL__ < 800 (Applicative m, MonadIO m) #else MonadIO m #endif => Repository down -> 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 down -> m (Trusted Root, KeyEnv) readLocalRoot rep = do cachedPath <- liftIO $ repGetCachedRoot rep signedRoot <- throwErrorsUnchecked LocalFileCorrupted =<< readCachedJSON rep KeyEnv.empty cachedPath return (trustLocalFile signedRoot, rootKeys (signed signedRoot)) readLocalFile :: ( FromJSON ReadJSON_Keys_Layout (Signed a), MonadIO m #if __GLASGOW_HASKELL__ < 800 , Applicative m #endif ) => Repository down -> KeyEnv -> CachedFile -> m (Maybe (Trusted a)) readLocalFile rep cachedKeyEnv file = do mCachedPath <- liftIO $ repGetCached rep file for mCachedPath $ \cachedPath -> do signed <- throwErrorsUnchecked LocalFileCorrupted =<< readCachedJSON rep cachedKeyEnv cachedPath return $ trustLocalFile signed getRemoteFile :: ( Throws VerificationError , Throws SomeRemoteError , VerifyRole a , FromJSON ReadJSON_Keys_Layout (Signed a) ) => Repository down -> CachedInfo -> AttemptNr -> Maybe UTCTime -> RemoteFile (f :- ()) Metadata -> Verify (Trusted a, down Metadata) getRemoteFile rep@Repository{..} cachedInfo@CachedInfo{..} isRetry mNow file = do (targetPath, tempPath) <- getRemote' rep isRetry file verifyFileInfo' (remoteFileDefaultInfo file) targetPath tempPath signed <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<< readDownloadedJSON rep cachedKeyEnv tempPath verified <- throwErrorsChecked id $ verifyRole cachedRoot targetPath (cachedVersion cachedInfo file) mNow signed return (trustVerified verified, tempPath) {------------------------------------------------------------------------------- Downloading target files -------------------------------------------------------------------------------} -- | Download a package downloadPackage :: ( Throws SomeRemoteError , Throws VerificationError , Throws InvalidPackageException ) => Repository down -- ^ Repository -> PackageIdentifier -- ^ Package to download -> Path Absolute -- ^ Destination (see also 'downloadPackage'') -> IO () downloadPackage rep@Repository{..} pkgId dest = withMirror rep $ withIndex rep $ \IndexCallbacks{..} -> runVerify repLockCache $ do -- Get the metadata (from the previously updated index) targetFileInfo <- liftIO $ indexLookupFileInfo pkgId -- TODO: should we check if cached package available? (spec says no) tarGz <- do (targetPath, downloaded) <- getRemote' rep (AttemptNr 0) $ RemotePkgTarGz pkgId targetFileInfo verifyFileInfo' (Just targetFileInfo) targetPath downloaded return downloaded -- If all checks succeed, copy file to its target location. liftIO $ downloadedCopyTo tarGz dest -- | Variation on 'downloadPackage' that takes a FilePath instead. downloadPackage' :: ( Throws SomeRemoteError , Throws VerificationError , Throws InvalidPackageException ) => Repository down -- ^ Repository -> PackageIdentifier -- ^ Package to download -> FilePath -- ^ Destination -> IO () downloadPackage' rep pkgId dest = downloadPackage rep pkgId =<< makeAbsolute (fromFilePath dest) {------------------------------------------------------------------------------- Access to the tar index (the API is exported and used internally) NOTE: The files inside the index as evaluated lazily. 1. The index tarball contains delegated target.json files for both unsigned and signed packages. We need to verify the signatures of all signed metadata (that is: the metadata for signed packages). 2. Since the tarball also contains the .cabal files, we should also verify the hashes of those .cabal files against the hashes recorded in signed metadata (there is no point comparing against hashes recorded in unsigned metadata because attackers could just change those). Since we don't have author signing yet, we don't have any additional signed metadata and therefore we currently don't have to do anything here. TODO: If we have explicit, author-signed, lists of versions for a package (as described in @README.md@), then evaluating these "middle-level" delegation files lazily opens us up to a rollback attack: if we've never downloaded the delegations for a package before, then we have nothing to compare the version number in the file that we downloaded against. One option is to always download and verify all these middle level files (strictly); other is to include the version number of all of these files in the snapshot. This is described in more detail in . TODO: Currently we hardcode the location of the package specific metadata. By rights we should read the global targets file and apply the delegation rules. Until we have author signing however this is unnecessary. -------------------------------------------------------------------------------} -- | Index directory data Directory = Directory { -- | The first entry in the dictionary directoryFirst :: DirectoryEntry -- | The next available (i.e., one after last) directory entry , directoryNext :: DirectoryEntry -- | Lookup an entry in the dictionary -- -- This is an efficient operation. , directoryLookup :: forall dec. IndexFile dec -> Maybe DirectoryEntry -- | An enumeration of all entries -- -- This field is lazily constructed, so if you don't need it, it does not -- incur a performance overhead. Moreover, the 'IndexFile' is also created -- lazily so if you only need the raw 'IndexPath' there is no parsing -- overhead. -- -- The entries are ordered by 'DirectoryEntry' so that the entries can -- efficiently be read in sequence. -- -- NOTE: This means that there are two ways to enumerate all entries in the -- tar file, since when lookup an entry using 'indexLookupEntry' the -- 'DirectoryEntry' of the next entry is also returned. However, this -- involves reading through the entire @tar@ file. If you only need to read -- /some/ files, it is significantly more efficient to enumerate the tar -- entries using 'directoryEntries' instead and only call 'indexLookupEntry' -- when required. , directoryEntries :: [(DirectoryEntry, IndexPath, Maybe (Some IndexFile))] } -- | Entry into the Hackage index. newtype DirectoryEntry = DirectoryEntry { -- | (Low-level) block number of the tar index entry -- -- Exposed for the benefit of clients who read the @.tar@ file directly. -- For this reason also the 'Show' and 'Read' instances for 'DirectoryEntry' -- just print and parse the underlying 'TarEntryOffset'. directoryEntryBlockNo :: Tar.TarEntryOffset } deriving (Eq, Ord) instance Show DirectoryEntry where show = show . directoryEntryBlockNo instance Read DirectoryEntry where readsPrec p = map (first DirectoryEntry) . readsPrec p -- | Read the Hackage index directory -- -- Should only be called after 'checkForUpdates'. getDirectory :: Repository down -> IO Directory getDirectory Repository{..} = mkDirectory <$> repGetIndexIdx where mkDirectory :: Tar.TarIndex -> Directory mkDirectory idx = Directory { directoryFirst = DirectoryEntry 0 , directoryNext = DirectoryEntry $ Tar.indexEndEntryOffset idx , directoryLookup = liftM dirEntry . Tar.lookup idx . filePath , directoryEntries = map mkEntry $ sortBy (comparing snd) (Tar.toList idx) } mkEntry :: (FilePath, Tar.TarEntryOffset) -> (DirectoryEntry, IndexPath, Maybe (Some IndexFile)) mkEntry (fp, off) = (DirectoryEntry off, path, indexFile path) where path = indexPath fp dirEntry :: Tar.TarIndexEntry -> DirectoryEntry dirEntry (Tar.TarFileEntry offset) = DirectoryEntry offset dirEntry (Tar.TarDir _) = error "directoryLookup: unexpected directory" indexFile :: IndexPath -> Maybe (Some IndexFile) indexFile = indexFileFromPath repIndexLayout indexPath :: FilePath -> IndexPath indexPath = rootPath . fromUnrootedFilePath filePath :: IndexFile dec -> FilePath filePath = toUnrootedFilePath . unrootPath . indexFileToPath repIndexLayout -- | Entry from the Hackage index; see 'withIndex'. data IndexEntry dec = IndexEntry { -- | The raw path in the tarfile indexEntryPath :: IndexPath -- | The parsed file (if recognised) , indexEntryPathParsed :: Maybe (IndexFile dec) -- | The raw contents -- -- Although this is a lazy bytestring, this is actually read into memory -- strictly (i.e., it can safely be used outside the scope of withIndex and -- friends). , indexEntryContent :: BS.L.ByteString -- | The parsed contents -- -- This field is lazily constructed; the parser is not unless you do a -- pattern match on this value. , indexEntryContentParsed :: Either SomeException dec -- | The time of the entry in the tarfile. , indexEntryTime :: Tar.EpochTime } -- | Various operations that we can perform on the index once its open -- -- Note that 'IndexEntry' contains a fields both for the raw file contents and -- the parsed file contents; clients can choose which to use. -- -- In principle these callbacks will do verification (once we have implemented -- author signing). Right now they don't need to do that, because the index as a -- whole will have been verified. data IndexCallbacks = IndexCallbacks { -- | Look up an entry by 'DirectoryEntry' -- -- Since these 'DirectoryEntry's must come from somewhere (probably from the -- 'Directory'), it is assumed that they are valid; if they are not, an -- (unchecked) exception will be thrown. -- -- This function also returns the 'DirectoryEntry' of the /next/ file in the -- index (if any) for the benefit of clients who wish to walk through the -- entire index. indexLookupEntry :: DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry) -- | Look up an entry by 'IndexFile' -- -- Returns 'Nothing' if the 'IndexFile' does not refer to an existing file. , indexLookupFile :: forall dec. IndexFile dec -> IO (Maybe (IndexEntry dec)) -- | Variation if both the 'DirectoryEntry' and the 'IndexFile' are known -- -- You might use this when scanning the index using 'directoryEntries'. , indexLookupFileEntry :: forall dec. DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec) -- | Get (raw) cabal file (wrapper around 'indexLookupFile') , indexLookupCabal :: Throws InvalidPackageException => PackageIdentifier -> IO (Trusted BS.L.ByteString) -- | Lookup package metadata (wrapper around 'indexLookupFile') -- -- This will throw an (unchecked) exception if the @targets.json@ file -- could not be parsed. , indexLookupMetadata :: Throws InvalidPackageException => PackageIdentifier -> IO (Trusted Targets) -- | Get file info (including hash) (wrapper around 'indexLookupFile') , indexLookupFileInfo :: ( Throws InvalidPackageException , Throws VerificationError ) => PackageIdentifier -> IO (Trusted FileInfo) -- | Get the SHA256 hash for a package (wrapper around 'indexLookupInfo') -- -- In addition to the exceptions thrown by 'indexLookupInfo', this will also -- throw an exception if the SHA256 is not listed in the 'FileMap' (again, -- this will not happen with a well-formed Hackage index.) , indexLookupHash :: ( Throws InvalidPackageException , Throws VerificationError ) => PackageIdentifier -> IO (Trusted Hash) -- | The 'Directory' for the index -- -- We provide this here because 'withIndex' will have read this anyway. , indexDirectory :: Directory } -- | Look up entries in the Hackage index -- -- This is in 'withFile' style so that clients can efficiently look up multiple -- files from the index. -- -- Should only be called after 'checkForUpdates'. withIndex :: Repository down -> (IndexCallbacks -> IO a) -> IO a withIndex rep@Repository{..} callback = do -- We need the cached root information in order to resolve key IDs and -- verify signatures. Note that whenever we read a JSON file, we verify -- signatures (even if we don't verify the keys); if this is a problem -- (for performance) we need to parameterize parseJSON. (_cachedRoot, keyEnv) <- readLocalRoot rep -- We need the directory to resolve 'IndexFile's and to know the index of -- the last entry. dir@Directory{..} <- getDirectory rep -- Open the index repWithIndex $ \h -> do let getEntry :: DirectoryEntry -> IO (Some IndexEntry, Maybe DirectoryEntry) getEntry entry = do (tarEntry, content, next) <- getTarEntry entry let path = indexPath tarEntry case indexFile path of Nothing -> return (Some (mkEntry tarEntry content Nothing), next) Just (Some file) -> return (Some (mkEntry tarEntry content (Just file)), next) getFile :: IndexFile dec -> IO (Maybe (IndexEntry dec)) getFile file = case directoryLookup file of Nothing -> return Nothing Just dirEntry -> Just <$> getFileEntry dirEntry file getFileEntry :: DirectoryEntry -> IndexFile dec -> IO (IndexEntry dec) getFileEntry dirEntry file = do (tarEntry, content, _next) <- getTarEntry dirEntry return $ mkEntry tarEntry content (Just file) mkEntry :: Tar.Entry -> BS.L.ByteString -> Maybe (IndexFile dec) -> IndexEntry dec mkEntry tarEntry content mFile = IndexEntry { indexEntryPath = indexPath tarEntry , indexEntryPathParsed = mFile , indexEntryContent = content , indexEntryContentParsed = parseContent mFile content , indexEntryTime = Tar.entryTime tarEntry } parseContent :: Maybe (IndexFile dec) -> BS.L.ByteString -> Either SomeException dec parseContent Nothing _ = Left pathNotRecognized parseContent (Just file) raw = case file of IndexPkgPrefs _ -> Right () -- We don't currently parse preference files IndexPkgCabal _ -> Right () -- We don't currently parse .cabal files IndexPkgMetadata _ -> let mkEx = either (Left . SomeException . InvalidFileInIndex file raw) Right in mkEx $ parseJSON_Keys_NoLayout keyEnv raw -- Read an entry from the tar file. Returns entry content separately, -- throwing an exception if the entry is not a regular file. -- Also throws an exception if the 'DirectoryEntry' is invalid. getTarEntry :: DirectoryEntry -> IO (Tar.Entry, BS.L.ByteString, Maybe DirectoryEntry) getTarEntry (DirectoryEntry offset) = do entry <- Tar.hReadEntry h offset content <- case Tar.entryContent entry of Tar.NormalFile content _sz -> return content _ -> throwIO $ userError "withIndex: unexpected entry" let next = DirectoryEntry $ Tar.nextEntryOffset entry offset mNext = guard (next < directoryNext) >> return next return (entry, content, mNext) -- Get cabal file getCabal :: Throws InvalidPackageException => PackageIdentifier -> IO (Trusted BS.L.ByteString) getCabal pkgId = do mCabal <- getFile $ IndexPkgCabal pkgId case mCabal of Nothing -> throwChecked $ InvalidPackageException pkgId Just IndexEntry{..} -> return $ DeclareTrusted indexEntryContent -- Get package metadata getMetadata :: Throws InvalidPackageException => PackageIdentifier -> IO (Trusted Targets) getMetadata pkgId = do mEntry <- getFile $ IndexPkgMetadata pkgId case mEntry of Nothing -> throwChecked $ InvalidPackageException pkgId Just IndexEntry{indexEntryContentParsed = Left ex} -> throwUnchecked $ ex Just IndexEntry{indexEntryContentParsed = Right signed} -> return $ trustLocalFile signed -- Get package info getFileInfo :: ( Throws InvalidPackageException , Throws VerificationError ) => PackageIdentifier -> IO (Trusted FileInfo) getFileInfo pkgId = do targets <- getMetadata pkgId let mTargetMetadata :: Maybe (Trusted FileInfo) mTargetMetadata = trustElems $ trustStatic (static targetsLookup) `trustApply` DeclareTrusted (targetPath pkgId) `trustApply` targets case mTargetMetadata of Nothing -> throwChecked $ VerificationErrorUnknownTarget (targetPath pkgId) Just info -> return info -- Get package SHA256 getHash :: ( Throws InvalidPackageException , Throws VerificationError ) => PackageIdentifier -> IO (Trusted Hash) getHash pkgId = do info <- getFileInfo pkgId let mTrustedHash :: Maybe (Trusted Hash) mTrustedHash = trustElems $ trustStatic (static fileInfoSHA256) `trustApply` info case mTrustedHash of Nothing -> throwChecked $ VerificationErrorMissingSHA256 (targetPath pkgId) Just hash -> return hash callback IndexCallbacks{ indexLookupEntry = getEntry , indexLookupFile = getFile , indexLookupFileEntry = getFileEntry , indexDirectory = dir , indexLookupCabal = getCabal , indexLookupMetadata = getMetadata , indexLookupFileInfo = getFileInfo , indexLookupHash = getHash } where indexPath :: Tar.Entry -> IndexPath indexPath = rootPath . fromUnrootedFilePath . Tar.fromTarPathToPosixPath . Tar.entryTarPath indexFile :: IndexPath -> Maybe (Some IndexFile) indexFile = indexFileFromPath repIndexLayout targetPath :: PackageIdentifier -> TargetPath targetPath = TargetPathRepo . repoLayoutPkgTarGz repLayout pathNotRecognized :: SomeException pathNotRecognized = SomeException (userError "Path not recognized") {------------------------------------------------------------------------------- Bootstrapping -------------------------------------------------------------------------------} -- | Check if we need to bootstrap (i.e., if we have root info) requiresBootstrap :: Repository down -> IO Bool requiresBootstrap rep = isNothing <$> repGetCached rep CachedRoot -- | Bootstrap the chain of trust -- -- New clients might need to obtain a copy of the root metadata. This however -- represents a chicken-and-egg problem: how can we verify the root metadata -- we downloaded? The only possibility is to be provided with a set of an -- out-of-band set of root keys and an appropriate threshold. -- -- Clients who provide a threshold of 0 can do an initial "unsafe" update -- of the root information, if they wish. -- -- The downloaded root information will _only_ be verified against the -- provided keys, and _not_ against previously downloaded root info (if any). -- It is the responsibility of the client to call `bootstrap` only when this -- is the desired behaviour. bootstrap :: (Throws SomeRemoteError, Throws VerificationError) => Repository down -> [KeyId] -> KeyThreshold -> IO () bootstrap rep@Repository{..} trustedRootKeys keyThreshold = withMirror rep $ runVerify repLockCache $ do _newRoot :: Trusted Root <- do (targetPath, tempPath) <- getRemote' rep (AttemptNr 0) (RemoteRoot Nothing) signed <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<< readDownloadedJSON rep KeyEnv.empty tempPath verified <- throwErrorsChecked id $ verifyFingerprints trustedRootKeys keyThreshold targetPath signed return $ trustVerified verified clearCache rep {------------------------------------------------------------------------------- Wrapper around the Repository functions -------------------------------------------------------------------------------} getRemote :: forall fs down typ. Throws SomeRemoteError => Repository down -> AttemptNr -> RemoteFile fs typ -> Verify (Some Format, TargetPath, down typ) getRemote r attemptNr file = do (Some format, downloaded) <- repGetRemote r attemptNr file let targetPath = TargetPathRepo $ remoteRepoPath' (repLayout r) file format return (Some (hasFormatGet format), targetPath, downloaded) -- | Variation on getRemote where we only expect one type of result getRemote' :: forall f down typ. Throws SomeRemoteError => Repository down -> AttemptNr -> RemoteFile (f :- ()) typ -> Verify (TargetPath, down typ) getRemote' r isRetry file = ignoreFormat <$> getRemote r isRetry file where ignoreFormat (_format, targetPath, tempPath) = (targetPath, tempPath) clearCache :: MonadIO m => Repository down -> m () clearCache r = liftIO $ repClearCache r log :: MonadIO m => Repository down -> LogMessage -> m () log r msg = liftIO $ repLog r msg -- Tries to load the cached mirrors file withMirror :: Repository down -> 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 -- Once we add support for partial mirrors, we wil need an additional -- argument to 'repWithMirror' (here, not in the Repository API itself) -- that tells us which files we will be requested from the mirror. -- We can then compare that against the specification of the partial mirror -- to see if all of those files are available from this mirror. canUseMirror :: MirrorContent -> Bool canUseMirror MirrorFull = True {------------------------------------------------------------------------------- Exceptions -------------------------------------------------------------------------------} -- | Re-throw all exceptions thrown by the client API as unchecked exceptions 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 = forall dec. InvalidFileInIndex { invalidFileInIndex :: IndexFile dec , invalidFileInIndexRaw :: BS.L.ByteString , invalidFileInIndexError :: 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 raw err) = unlines [ "Invalid file in index: " ++ pretty file , "Error: " ++ pretty err , "Unparsed file: " ++ BS.L.C8.unpack raw ] {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -- | Local files are assumed trusted -- -- There is no point tracking chain of trust for local files because that chain -- would necessarily have to start at an implicitly trusted (though unverified) -- file: the root metadata. trustLocalFile :: Signed a -> Trusted a trustLocalFile Signed{..} = DeclareTrusted signed -- | Just a simple wrapper around 'verifyFileInfo' -- -- Throws a VerificationError if verification failed. verifyFileInfo' :: (MonadIO m, DownloadedFile down) => Maybe (Trusted FileInfo) -> TargetPath -- ^ For error messages -> down typ -- ^ File to verify -> m () verifyFileInfo' Nothing _ _ = return () verifyFileInfo' (Just info) targetPath tempPath = liftIO $ do verified <- downloadedVerify tempPath info unless verified $ throw $ VerificationErrorFileInfo targetPath readCachedJSON :: (MonadIO m, FromJSON ReadJSON_Keys_Layout a) => Repository down -> KeyEnv -> Path Absolute -> m (Either DeserializationError a) readCachedJSON Repository{..} keyEnv fp = liftIO $ do bs <- readLazyByteString fp evaluate $ parseJSON_Keys_Layout keyEnv repLayout bs readDownloadedJSON :: (MonadIO m, FromJSON ReadJSON_Keys_Layout a) => Repository down -> KeyEnv -> down Metadata -> m (Either DeserializationError a) readDownloadedJSON Repository{..} keyEnv fp = liftIO $ do bs <- downloadedRead fp evaluate $ parseJSON_Keys_Layout keyEnv repLayout bs 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