hackage-security-0.6.2.2: src/Hackage/Security/Client.hs
{-# 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 MyPrelude 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 package 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 <https://github.com/theupdateframework/tuf/issues/287>.
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 <https://github.com/theupdateframework/tuf/issues/287>.
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 <https://github.com/theupdateframework/tuf/issues/283>.
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 <https://github.com/theupdateframework/tuf/issues/286>
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 <https://github.com/theupdateframework/tuf/issues/285>.
--
-- 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 <https://github.com/theupdateframework/tuf/issues/283#issuecomment-115739521>
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
<https://github.com/theupdateframework/tuf/issues/282#issuecomment-102468421>.
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