diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,35 @@ +0.5.0.0 +------- +* Treat deserialization errors as verification errors (#108, #75) +* Avoid `Content-Length: 0` in GET requests (#103) +* Fix bug in Trusted +* Build tar-index incrementally (#22) +* Generalize 'Repository' over the representation of downloaded remote files. +* Update index incrementally by downloading delta of `.tar.gz` and writing only + tail of local `.tar` file (#101). Content compression no longer used. +* Take a lock on the cache directory before updating it, and no longer use + atomic file ops (pointless since we now update some files incrementally) +* Code refactoring/simplification. +* Support for ed25519 >= 0.0.4 +* `downloadPackage` no longer takes a callback. +* API for accessing the Hackage index contents changed; it should now be + easier for clients to do their own incremental updates should they wish + to do so. +* Relies on tar >= 0.4.4 +* Removed obsolete option for downloading the compressed index (we now _always_ + download the compressed index) +* Path module now works on Windows (#118) +* Dropped support for ghc 7.2 +* Replaced uses of Int with Int54, to make sure canonical JSON really is + canonical (#141). + +0.4.0.0 +------- +* Allow clients to pass in their own time for expiry verification + (this is an API change hence the major version bump) +* Export .Client.Formats (necessary to define new Repositories) +* Start work on basic test framework + 0.3.0.0 ------- * Don't use compression for range requests (#101) diff --git a/hackage-security.cabal b/hackage-security.cabal --- a/hackage-security.cabal +++ b/hackage-security.cabal @@ -1,5 +1,5 @@ name: hackage-security -version: 0.3.0.0 +version: 0.5.0.0 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server @@ -26,12 +26,18 @@ maintainer: edsko@well-typed.com copyright: Copyright 2015 Well-Typed LLP category: Distribution +homepage: https://github.com/well-typed/hackage-security +bug-reports: https://github.com/well-typed/hackage-security/issues build-type: Simple cabal-version: >=1.10 extra-source-files: ChangeLog.md +source-repository head + type: git + location: https://github.com/well-typed/hackage-security.git + flag base48 description: Are we using base 4.8 or later? manual: False @@ -44,14 +50,17 @@ -- Most functionality is exported through the top-level entry points .Client -- and .Server; the other exported modules are intended for qualified imports. exposed-modules: Hackage.Security.Client + Hackage.Security.Client.Formats Hackage.Security.Client.Repository Hackage.Security.Client.Repository.Cache Hackage.Security.Client.Repository.Local Hackage.Security.Client.Repository.Remote Hackage.Security.Client.Repository.HttpLib + Hackage.Security.Client.Verify Hackage.Security.JSON Hackage.Security.Key.Env Hackage.Security.Server + Hackage.Security.Trusted Hackage.Security.TUF.FileMap Hackage.Security.Util.Checked Hackage.Security.Util.IO @@ -60,16 +69,17 @@ Hackage.Security.Util.Pretty Hackage.Security.Util.Some Text.JSON.Canonical - other-modules: Hackage.Security.Client.Formats - Hackage.Security.Key - Hackage.Security.Trusted + other-modules: Hackage.Security.Key Hackage.Security.Trusted.TCB Hackage.Security.TUF Hackage.Security.TUF.Common Hackage.Security.TUF.FileInfo Hackage.Security.TUF.Header - Hackage.Security.TUF.Layout + Hackage.Security.TUF.Layout.Cache + Hackage.Security.TUF.Layout.Index + Hackage.Security.TUF.Layout.Repo Hackage.Security.TUF.Mirrors + Hackage.Security.TUF.Paths Hackage.Security.TUF.Patterns Hackage.Security.TUF.Root Hackage.Security.TUF.Signed @@ -81,28 +91,31 @@ Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded Prelude - -- We support ghc 7.2 (bundled with Cabal 1.12) and up - build-depends: base >= 4.4 && < 5, - base64-bytestring >= 1.0 && < 1.1, + -- We support ghc 7.4 (bundled with Cabal 1.14) and up + build-depends: base >= 4.5 && < 5, + base64-bytestring >= 1.0 && < 1.1, -- we need Data.ByteString.Builder to build tar indices, -- which is only available from bytestring-0.10.2 and up -- TODO: We should probably fix that upstream (in tar) -- so that we can compile with the version of bytestring -- that comes with ghc for ghc < 7.8 - bytestring >= 0.10.2 && < 0.11, - Cabal >= 1.12 && < 1.25, - containers >= 0.4 && < 0.6, - directory >= 1.1 && < 1.3, - ed25519 >= 0.0 && < 0.1, - filepath >= 1.2 && < 1.5, - mtl >= 2.2 && < 2.3, - parsec >= 3.1 && < 3.2, - cryptohash >= 0.11 && < 0.12, + bytestring >= 0.10.2 && < 0.11, + Cabal >= 1.14 && < 1.25, + containers >= 0.4 && < 0.6, + -- directory 1.2.2.0 introduced makeAbsolute + directory >= 1.2.2.0 && < 1.3, + ed25519 >= 0.0 && < 0.1, + filepath >= 1.2 && < 1.5, + mtl >= 2.2 && < 2.3, + parsec >= 3.1 && < 3.2, + cryptohash >= 0.11 && < 0.12, -- version 0.4.2 of tar introduces TarIndex - tar >= 0.4.2 && < 0.5, - time >= 1.2 && < 1.6, - transformers >= 0.4 && < 0.5, - zlib >= 0.5 && < 0.7, + -- version 0.4.2.2 contains a crucial bugfix + -- version 0.4.4 introduces some more Index functionality + tar >= 0.4.4 && < 0.5, + time >= 1.2 && < 1.6, + transformers >= 0.4 && < 0.5, + zlib >= 0.5 && < 0.7, -- whatever versions are bundled with ghc: template-haskell, ghc-prim @@ -187,3 +200,34 @@ -- StaticPointers -- ^^^ Temporarily disabled because Hackage doesn't know yet about this -- extension and will therefore reject this package. + +test-suite TestSuite + type: exitcode-stdio-1.0 + main-is: TestSuite.hs + other-modules: TestSuite.InMemCache + TestSuite.InMemRepo + TestSuite.InMemRepository + TestSuite.PrivateKeys + TestSuite.Util.StrictMVar + build-depends: base, + Cabal, + containers, + HUnit, + bytestring, + hackage-security, + network-uri, + tar, + tasty, + tasty-hunit, + temporary, + time, + zlib + hs-source-dirs: tests + default-language: Haskell2010 + default-extensions: FlexibleContexts + GADTs + KindSignatures + RankNTypes + RecordWildCards + ScopedTypeVariables + ghc-options: -Wall diff --git a/src/Hackage/Security/Client.hs b/src/Hackage/Security/Client.hs --- a/src/Hackage/Security/Client.hs +++ b/src/Hackage/Security/Client.hs @@ -6,47 +6,64 @@ module Hackage.Security.Client ( -- * Checking for updates checkForUpdates - , CheckExpiry(..) , HasUpdates(..) -- * Downloading targets , downloadPackage - , getCabalFile + , 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 Control.Monad.Trans.Cont +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 Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS.L +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.Repository 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) @@ -54,30 +71,18 @@ 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.Stack import Hackage.Security.Util.Some -import qualified Hackage.Security.Key.Env as KeyEnv +import Hackage.Security.Util.Stack +import qualified Hackage.Security.Key.Env as KeyEnv {------------------------------------------------------------------------------- Checking for updates -------------------------------------------------------------------------------} --- | Should we check expiry dates? -data CheckExpiry = - -- | Yes, check expiry dates - CheckExpiry - - -- | No, don't check expiry dates. - -- - -- This should ONLY be used in exceptional circumstances (such as when - -- the main server is down for longer than the expiry dates used in the - -- timestamp files on mirrors). - | DontCheckExpiry - deriving Show - data HasUpdates = HasUpdates | NoUpdates - deriving Show + deriving (Show, Eq, Ord) -- | Generic logic for checking if there are updates -- @@ -85,9 +90,15 @@ -- 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 -> CheckExpiry -> IO HasUpdates -checkForUpdates rep checkExpiry = + => 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 @@ -113,14 +124,10 @@ -- on each iteration. cachedInfo <- getCachedInfo rep - -- Get current time for timestamp verification, if requested - mNow <- case checkExpiry of - CheckExpiry -> Just <$> getCurrentTime - DontCheckExpiry -> return Nothing - mHasUpdates <- tryChecked -- catch RootUpdated $ tryChecked -- catch VerificationError - $ evalContT (go mNow isRetry cachedInfo) + $ runVerify repLockCache + $ go attemptNr cachedInfo case mHasUpdates of Left ex -> do -- NOTE: This call to updateRoot is not itself protected by an @@ -129,24 +136,24 @@ -- update process, _and_ we cannot update the main root info, then -- we cannot do anything. log rep $ LogVerificationError ex - updateRoot rep mNow AfterVerificationError cachedInfo (Left ex) - limitIterations (Right ex : history) + let history' = Right ex : history + attemptNr' = attemptNr + 1 + updateRoot rep mNow attemptNr' cachedInfo (Left ex) + limitIterations history' Right (Left RootUpdated) -> do log rep $ LogRootUpdated - limitIterations (Left RootUpdated : history) + let history' = Left RootUpdated : history + limitIterations history' Right (Right hasUpdates) -> return hasUpdates where - isRetry :: IsRetry - isRetry = if null history then FirstAttempt else AfterVerificationError + attemptNr :: AttemptNr + attemptNr = fromIntegral $ length history - -- NOTE: We use the ContT monad transformer to make sure that none of the - -- downloaded files will be cached until the entire check for updates check - -- completes successfully. + -- The 'Verify' monad only caches the downloaded files after verification. -- See also . - go :: Throws RootUpdated - => Maybe UTCTime -> IsRetry -> CachedInfo -> ContT r IO HasUpdates - go mNow isRetry cachedInfo@CachedInfo{..} = do + go :: Throws RootUpdated => AttemptNr -> CachedInfo -> Verify HasUpdates + go attemptNr cachedInfo@CachedInfo{..} = do -- Get the new timestamp newTS <- getRemoteFile' RemoteTimestamp let newInfoSS = static timestampInfoSnapshot <$$> newTS @@ -160,11 +167,11 @@ let newInfoRoot = static snapshotInfoRoot <$$> newSS newInfoMirrors = static snapshotInfoMirrors <$$> newSS newInfoTarGz = static snapshotInfoTarGz <$$> newSS - mNewInfoTar = trustSeq (static snapshotInfoTar <$$> newSS) + mNewInfoTar = trustElems (static snapshotInfoTar <$$> newSS) -- If root metadata changed, download and restart when (rootChanged cachedInfoRoot newInfoRoot) $ liftIO $ do - updateRoot rep mNow isRetry cachedInfo (Right newInfoRoot) + 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. @@ -183,19 +190,19 @@ getRemoteFile' :: ( VerifyRole a , FromJSON ReadJSON_Keys_Layout (Signed a) ) - => RemoteFile (f :- ()) -> ContT r IO (Trusted a) - getRemoteFile' = liftM fst . getRemoteFile rep cachedInfo isRetry mNow + => 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@ - -> ContT r IO () + -> Verify () updateIndex newInfoTarGz Nothing = do - (targetPath, tempPath) <- getRemote' rep isRetry $ + (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 isRetry $ + (format, targetPath, tempPath) <- getRemote rep attemptNr $ RemoteIndex (HFS (HFZ FGz)) (FsUnGz newInfoTar newInfoTarGz) case format of Some FGz -> verifyFileInfo' (Just newInfoTarGz) targetPath tempPath @@ -219,7 +226,7 @@ -- 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 -> ContT r IO () + newMirrors :: Trusted Mirrors -> Verify () newMirrors _ = return () -- | Update the root metadata @@ -263,14 +270,14 @@ -- thereby rendering the file version on the timestamp and the snapshot useless. -- See updateRoot :: (Throws VerificationError, Throws SomeRemoteError) - => Repository + => Repository down -> Maybe UTCTime - -> IsRetry + -> AttemptNr -> CachedInfo -> Either VerificationError (Trusted FileInfo) -> IO () -updateRoot rep mNow isRetry cachedInfo eFileInfo = do - rootReallyChanged <- evalContT $ do +updateRoot rep@Repository{..} mNow isRetry cachedInfo eFileInfo = do + rootReallyChanged <- runVerify repLockCache $ do (_newRoot :: Trusted Root, rootTempFile) <- getRemoteFile rep cachedInfo @@ -293,9 +300,9 @@ -- 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 rep + oldRootFile <- repGetCachedRoot oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile - not <$> verifyFileInfo rootTempFile oldRootInfo + not <$> downloadedVerify rootTempFile oldRootInfo when rootReallyChanged $ clearCache rep @@ -315,7 +322,7 @@ , cachedInfoTarGz :: Maybe (Trusted FileInfo) } -cachedVersion :: CachedInfo -> RemoteFile fs -> Maybe FileVersion +cachedVersion :: CachedInfo -> RemoteFile fs typ -> Maybe FileVersion cachedVersion CachedInfo{..} remoteFile = case mustCache remoteFile of CacheAs CachedTimestamp -> timestampVersion . trusted <$> cachedTimestamp @@ -326,7 +333,7 @@ DontCache -> Nothing -- | Get all cached info (if any) -getCachedInfo :: (Applicative m, MonadIO m) => Repository -> m CachedInfo +getCachedInfo :: (Applicative m, MonadIO m) => Repository down -> m CachedInfo getCachedInfo rep = do (cachedRoot, cachedKeyEnv) <- readLocalRoot rep cachedTimestamp <- readLocalFile rep cachedKeyEnv CachedTimestamp @@ -340,22 +347,22 @@ return CachedInfo{..} -readLocalRoot :: MonadIO m => Repository -> m (Trusted Root, KeyEnv) +readLocalRoot :: MonadIO m => Repository down -> m (Trusted Root, KeyEnv) readLocalRoot rep = do cachedPath <- liftIO $ repGetCachedRoot rep signedRoot <- throwErrorsUnchecked LocalFileCorrupted =<< - readJSON (repLayout rep) KeyEnv.empty cachedPath + readCachedJSON 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)) + => 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 =<< - readJSON (repLayout rep) cachedKeyEnv cachedPath + readCachedJSON rep cachedKeyEnv cachedPath return $ trustLocalFile signed getRemoteFile :: ( Throws VerificationError @@ -363,17 +370,17 @@ , VerifyRole a , FromJSON ReadJSON_Keys_Layout (Signed a) ) - => Repository + => Repository down -> CachedInfo - -> IsRetry + -> AttemptNr -> Maybe UTCTime - -> RemoteFile (f :- ()) - -> ContT r IO (Trusted a, TempPath) -getRemoteFile rep cachedInfo@CachedInfo{..} isRetry mNow file = do + -> 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 SomeRemoteError =<< - readJSON (repLayout rep) cachedKeyEnv tempPath + signed <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<< + readDownloadedJSON rep cachedKeyEnv tempPath verified <- throwErrorsChecked id $ verifyRole cachedRoot targetPath @@ -387,117 +394,431 @@ -------------------------------------------------------------------------------} -- | Download a package --- --- It is the responsibility of the callback to move the package from its --- temporary location to a permanent location (if desired). The callback will --- only be invoked once the chain of trust has been verified. --- --- NOTE: Unlike the check for updates, downloading a package never triggers an --- update of the root information (even if verification of the package fails). downloadPackage :: ( Throws SomeRemoteError , Throws VerificationError , Throws InvalidPackageException ) - => Repository -> PackageIdentifier -> (TempPath -> IO a) -> IO a -downloadPackage rep pkgId callback = withMirror rep $ evalContT $ 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 + => 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 - -- NOTE: The files inside the index as evaluated lazily. + -- 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 -- - -- 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). + -- This is an efficient operation. + , directoryLookup :: forall dec. IndexFile dec -> Maybe DirectoryEntry + + -- | An enumeration of all entries -- - -- 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). + -- 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. -- - -- 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. + -- The entries are ordered by 'DirectoryEntry' so that the entries can + -- efficiently be read in sequence. -- - -- 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 - -- . - let trustIndex :: Signed a -> Trusted a - trustIndex = trustLocalFile + -- 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))] + } - -- Get the metadata (from the previously updated index) +-- | Entry into the Hackage index. +newtype DirectoryEntry = DirectoryEntry { + -- | (Low-level) block number of the tar index entry -- - -- NOTE: 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. - 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 + -- 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) - -- The path of the package, relative to the targets.json file - let filePath :: TargetPath - filePath = TargetPathRepo $ repoLayoutPkgTarGz (repLayout rep) pkgId +instance Show DirectoryEntry where + show = show . directoryEntryBlockNo - 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 +instance Read DirectoryEntry where + readsPrec p = map (first DirectoryEntry) . readsPrec p - -- TODO: should we check if cached package available? (spec says no) - tarGz <- do - (targetPath, tempPath) <- getRemote' rep FirstAttempt $ - RemotePkgTarGz pkgId targetMetaData - verifyFileInfo' (Just targetMetaData) targetPath tempPath - return tempPath - liftIO $ callback tarGz +-- | 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) + } --- | Get a cabal file from the index + 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 -- --- This does currently not do any verification (bcause the cabal file comes --- from the index, and the index itself is verified). Once we introduce author --- signing this needs to be adapted. +-- Note that 'IndexEntry' contains a fields both for the raw file contents and +-- the parsed file contents; clients can choose which to use. -- --- Should be called only once a local index is available --- (i.e., after 'checkForUpdates'). +-- 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 -- --- Throws an 'InvalidPackageException' if there is no cabal file for the --- specified package in the index. -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 +-- 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.entryPath + + 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 -> IO Bool +requiresBootstrap :: Repository down -> IO Bool requiresBootstrap rep = isNothing <$> repGetCached rep CachedRoot -- | Bootstrap the chain of trust @@ -515,12 +836,12 @@ -- It is the responsibility of the client to call `bootstrap` only when this -- is the desired behaviour. bootstrap :: (Throws SomeRemoteError, Throws VerificationError) - => Repository -> [KeyId] -> KeyThreshold -> IO () -bootstrap rep trustedRootKeys keyThreshold = withMirror rep $ evalContT $ do + => Repository down -> [KeyId] -> KeyThreshold -> IO () +bootstrap rep@Repository{..} trustedRootKeys keyThreshold = withMirror rep $ runVerify repLockCache $ do _newRoot :: Trusted Root <- do - (targetPath, tempPath) <- getRemote' rep FirstAttempt (RemoteRoot Nothing) - signed <- throwErrorsChecked SomeRemoteError =<< - readJSON (repLayout rep) KeyEnv.empty tempPath + (targetPath, tempPath) <- getRemote' rep (AttemptNr 0) (RemoteRoot Nothing) + signed <- throwErrorsChecked (VerificationErrorDeserialization targetPath) =<< + readDownloadedJSON rep KeyEnv.empty tempPath verified <- throwErrorsChecked id $ verifyFingerprints trustedRootKeys keyThreshold @@ -531,56 +852,37 @@ clearCache rep {------------------------------------------------------------------------------- - Wrapper around the Repository functions (to avoid callback hell) + Wrapper around the Repository functions -------------------------------------------------------------------------------} -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 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 r. (Throws SomeRemoteError, Throws VerificationError) - => Repository - -> IsRetry - -> RemoteFile (f :- ()) - -> ContT r IO (TargetPath, TempPath) +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 -> m () +clearCache :: MonadIO m => Repository down -> m () clearCache r = liftIO $ repClearCache r -log :: MonadIO m => Repository -> LogMessage -> m () +log :: MonadIO m => Repository down -> LogMessage -> m () log r msg = liftIO $ repLog r msg --- We translate to a lazy bytestring here for convenience -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 . (:[]) - -- Tries to load the cached mirrors file -withMirror :: Repository -> IO a -> IO a +withMirror :: Repository down -> IO a -> IO a withMirror rep callback = do mMirrors <- repGetCached rep CachedMirrors mirrors <- case mMirrors of @@ -634,7 +936,11 @@ data LocalFileCorrupted = LocalFileCorrupted DeserializationError deriving (Typeable) -data InvalidFileInIndex = InvalidFileInIndex IndexFile DeserializationError +data InvalidFileInIndex = forall dec. InvalidFileInIndex { + invalidFileInIndex :: IndexFile dec + , invalidFileInIndexRaw :: BS.L.ByteString + , invalidFileInIndexError :: DeserializationError + } deriving (Typeable) #if MIN_VERSION_base(4,8,0) @@ -660,8 +966,11 @@ pretty (LocalFileCorrupted err) = "Local file corrupted: " ++ pretty err instance Pretty InvalidFileInIndex where - pretty (InvalidFileInIndex file err) = "Invalid file " ++ pretty file - ++ "in index: " ++ pretty err + pretty (InvalidFileInIndex file raw err) = unlines [ + "Invalid file in index: " ++ pretty file + , "Error: " ++ pretty err + , "Unparsed file: " ++ BS.L.C8.unpack raw + ] {------------------------------------------------------------------------------- Auxiliary @@ -678,21 +987,29 @@ -- | Just a simple wrapper around 'verifyFileInfo' -- -- Throws a VerificationError if verification failed. -verifyFileInfo' :: MonadIO m +verifyFileInfo' :: (MonadIO m, DownloadedFile down) => Maybe (Trusted FileInfo) -> TargetPath -- ^ For error messages - -> TempPath -- ^ File to verify + -> down typ -- ^ File to verify -> m () verifyFileInfo' Nothing _ _ = return () verifyFileInfo' (Just info) targetPath tempPath = liftIO $ do - verified <- verifyFileInfo tempPath info + verified <- downloadedVerify 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 +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' diff --git a/src/Hackage/Security/Client/Repository.hs b/src/Hackage/Security/Client/Repository.hs --- a/src/Hackage/Security/Client/Repository.hs +++ b/src/Hackage/Security/Client/Repository.hs @@ -5,24 +5,26 @@ {-# LANGUAGE CPP #-} module Hackage.Security.Client.Repository ( -- * Files - RemoteFile(..) + Metadata -- type index (really a kind) + , Binary -- type index (really a kind) + , RemoteFile(..) , CachedFile(..) , IndexFile(..) , remoteFileDefaultFormat , remoteFileDefaultInfo -- * Repository proper , Repository(..) - , TempPath - , IsRetry(..) + , AttemptNr(..) , LogMessage(..) , UpdateFailure(..) , SomeRemoteError(..) + -- ** Downloaded files + , DownloadedFile(..) -- ** Helpers , mirrorsUnsupported -- * Paths , remoteRepoPath , remoteRepoPath' - , indexFilePath -- * Utility , IsCached(..) , mustCache @@ -30,12 +32,14 @@ import Control.Exception import Data.Typeable (Typeable) -import qualified Data.ByteString as BS +import qualified Codec.Archive.Tar.Index as Tar +import qualified Data.ByteString.Lazy as BS.L import Distribution.Package import Distribution.Text import Hackage.Security.Client.Formats +import Hackage.Security.Client.Verify import Hackage.Security.Trusted import Hackage.Security.TUF import Hackage.Security.Util.Checked @@ -48,17 +52,21 @@ Files -------------------------------------------------------------------------------} +data Metadata +data Binary + -- | Abstract definition of files we might have to download -- -- 'RemoteFile' is parametrized by the type of the formats that we can accept --- from the remote repository. +-- from the remote repository, as well as with information on whether this file +-- is metadata actual binary content. -- -- NOTE: Haddock lacks GADT support so constructors have only regular comments. -data RemoteFile :: * -> * where +data RemoteFile :: * -> * -> * where -- Timestamp metadata (@timestamp.json@) -- -- We never have (explicit) file length available for timestamps. - RemoteTimestamp :: RemoteFile (FormatUn :- ()) + RemoteTimestamp :: RemoteFile (FormatUn :- ()) Metadata -- Root metadata (@root.json@) -- @@ -69,17 +77,17 @@ -- - If however we need to update the root metadata due to a verification -- exception we do not know the file info. -- - We also do not know the file info during bootstrapping. - RemoteRoot :: Maybe (Trusted FileInfo) -> RemoteFile (FormatUn :- ()) + RemoteRoot :: Maybe (Trusted FileInfo) -> RemoteFile (FormatUn :- ()) Metadata -- Snapshot metadata (@snapshot.json@) -- -- We get file info of the snapshot from the timestamp. - RemoteSnapshot :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) + RemoteSnapshot :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata -- Mirrors metadata (@mirrors.json@) -- -- We get the file info from the snapshot. - RemoteMirrors :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) + RemoteMirrors :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) Metadata -- Index -- @@ -93,19 +101,18 @@ -- (the snapshot should make it clear which files are available). RemoteIndex :: HasFormat fs FormatGz -> Formats fs (Trusted FileInfo) - -> RemoteFile fs + -> RemoteFile fs Binary -- Actual package -- -- Package file length comes from the corresponding @targets.json@. RemotePkgTarGz :: PackageIdentifier -> Trusted FileInfo - -> RemoteFile (FormatGz :- ()) + -> RemoteFile (FormatGz :- ()) Binary --- deriving instance Eq (RemoteFile fs) -deriving instance Show (RemoteFile fs) +deriving instance Show (RemoteFile fs typ) -instance Pretty (RemoteFile fs) where +instance Pretty (RemoteFile fs typ) where pretty RemoteTimestamp = "timestamp" pretty (RemoteRoot _) = "root" pretty (RemoteSnapshot _) = "snapshot" @@ -128,33 +135,17 @@ | CachedMirrors deriving (Eq, Ord, Show) --- | Files that we might request from the index --- --- TODO: We should also provide a way to extract preferred versions info from --- the tarball. After all, this is a security sensitive, as it might be used --- for rollback/freeze attacks. Until we have author signing however this is --- not a strict necessity, as the preferred versions comes from the index which --- is itself signed. -data IndexFile = - -- | Package-specific metadata (@targets.json@) - IndexPkgMetadata PackageIdentifier - - -- | Cabal file for a package - | IndexPkgCabal PackageIdentifier - deriving Show - -instance Pretty IndexFile where - pretty (IndexPkgMetadata pkgId) = "metadata for " ++ display pkgId - pretty (IndexPkgCabal pkgId) = ".cabal for " ++ display pkgId - --- | Path to temporary file -type TempPath = AbsolutePath +instance Pretty CachedFile where + pretty CachedTimestamp = "timestamp" + pretty CachedRoot = "root" + pretty CachedSnapshot = "snapshot" + pretty CachedMirrors = "mirrors" -- | Default format for each file type -- -- For most file types we don't have a choice; for the index the repository -- is only required to offer the GZip-compressed format so that is the default. -remoteFileDefaultFormat :: RemoteFile fs -> Some (HasFormat fs) +remoteFileDefaultFormat :: RemoteFile fs typ -> Some (HasFormat fs) remoteFileDefaultFormat RemoteTimestamp = Some $ HFZ FUn remoteFileDefaultFormat (RemoteRoot _) = Some $ HFZ FUn remoteFileDefaultFormat (RemoteSnapshot _) = Some $ HFZ FUn @@ -163,7 +154,7 @@ remoteFileDefaultFormat (RemoteIndex pf _) = Some pf -- | Default file info (see also 'remoteFileDefaultFormat') -remoteFileDefaultInfo :: RemoteFile fs -> Maybe (Trusted FileInfo) +remoteFileDefaultInfo :: RemoteFile fs typ -> Maybe (Trusted FileInfo) remoteFileDefaultInfo RemoteTimestamp = Nothing remoteFileDefaultInfo (RemoteRoot info) = info remoteFileDefaultInfo (RemoteSnapshot info) = Just info @@ -181,10 +172,10 @@ -- to download metafiles and target files, without specifying how this is done. -- For instance, for a local repository this could just be doing a file read, -- whereas for remote repositories this could be using any kind of HTTP client. -data Repository = Repository { +data Repository down = DownloadedFile down => Repository { -- | Get a file from the server -- - -- Responsibilies of 'repWithRemote': + -- Responsibilies of 'repGetRemote': -- -- * Download the file from the repository and make it available at a -- temporary location @@ -192,32 +183,23 @@ -- (Repositories such as local repositories that are not suspectible to -- endless data attacks can safely ignore this argument.) -- * Move the file from its temporary location to its permanent location - -- if the callback returns successfully (where appropriate). - -- - -- Responsibilities of the callback: - -- - -- * Verify the file and throw an exception if verification fails. - -- * Not modify or move the temporary file. - -- (Thus it is safe for local repositories to directly pass the path - -- into the local repository.) + -- if verification succeeds. -- - -- NOTE: Calls to 'repWithRemote' should _always_ be in the scope of + -- NOTE: Calls to 'repGetRemote' should _always_ be in the scope of -- 'repWithMirror'. - repWithRemote :: forall a fs. - (Throws VerificationError, Throws SomeRemoteError) - => IsRetry - -> RemoteFile fs - -> (forall f. HasFormat fs f -> TempPath -> IO a) - -> IO a + repGetRemote :: forall fs typ. Throws SomeRemoteError + => AttemptNr + -> RemoteFile fs typ + -> Verify (Some (HasFormat fs), down typ) -- | Get a cached file (if available) - , repGetCached :: CachedFile -> IO (Maybe AbsolutePath) + , repGetCached :: CachedFile -> IO (Maybe (Path Absolute)) -- | Get the cached root -- -- This is a separate method only because clients must ALWAYS have root -- information available. - , repGetCachedRoot :: IO AbsolutePath + , repGetCachedRoot :: IO (Path Absolute) -- | Clear all cached data -- @@ -225,14 +207,21 @@ -- It would also be okay, but not required, to delete the index. , repClearCache :: IO () - -- | Get a file from the index + -- | Open the tarball for reading -- - -- The use of a strict bytestring here is intentional: it means the - -- Repository is free to keep the index open and just seek the handle - -- for different files. Since we only extract small files, having the - -- entire extracted file in memory is not an issue. - , repGetFromIndex :: IndexFile -> IO (Maybe BS.ByteString) + -- This function has this shape so that: + -- + -- * We can read multiple files from the tarball without having to open + -- and close the handle each time + -- * We can close the handle immediately when done. + , repWithIndex :: forall a. (Handle -> IO a) -> IO a + -- | Read the index index + , repGetIndexIdx :: IO Tar.TarIndex + + -- | Lock the cache (during updates) + , repLockCache :: IO () -> IO () + -- | Mirror selection -- -- The purpose of 'repWithMirror' is to scope mirror selection. The idea @@ -265,11 +254,17 @@ -- | Layout of this repository , repLayout :: RepoLayout + -- | Layout of the index + -- + -- Since the repository hosts the index, the layout of the index is + -- not independent of the layout of the repository. + , repIndexLayout :: IndexLayout + -- | Description of the repository (used in the show instance) , repDescription :: String } -instance Show Repository where +instance Show (Repository down) where show = repDescription -- | Helper function to implement 'repWithMirrors'. @@ -279,7 +274,8 @@ -- | Are we requesting this information because of a previous validation error? -- -- Clients can take advantage of this to tell caches to revalidate files. -data IsRetry = FirstAttempt | AfterVerificationError +newtype AttemptNr = AttemptNr Int + deriving (Eq, Ord, Num) -- | Log messages -- @@ -304,17 +300,17 @@ | LogVerificationError VerificationError -- | Download a file from a repository - | LogDownloading (Some RemoteFile) + | forall fs typ. LogDownloading (RemoteFile fs typ) -- | Incrementally updating a file from a repository - | LogUpdating (Some RemoteFile) + | forall fs. LogUpdating (RemoteFile fs Binary) -- | Selected a particular mirror | LogSelectedMirror MirrorDescription -- | Updating a file failed -- (we will instead download it whole) - | LogCannotUpdate (Some RemoteFile) UpdateFailure + | forall fs. LogCannotUpdate (RemoteFile fs Binary) UpdateFailure -- | We got an exception with a particular mirror -- (we will try with a different mirror if any are available) @@ -322,27 +318,40 @@ -- | Records why we are downloading a file rather than updating it. data UpdateFailure = - -- | Server only provides compressed form of the file - UpdateImpossibleOnlyCompressed - - -- | Likewise, it's possible that client _wants_ the compressed form of - -- the file, in which case downloading the uncompressed form is not useful. - | UpdateNotUsefulWantsCompressed - -- | Server does not support incremental downloads - | UpdateImpossibleUnsupported + UpdateImpossibleUnsupported -- | We don't have a local copy of the file to update | UpdateImpossibleNoLocalCopy - -- | Updating the local file would actually mean downloading - -- MORE data then doing a regular download. - | UpdateTooLarge + -- | Update failed twice + -- + -- If we attempt an incremental update the first time, and it fails, we let + -- it go round the loop, update local security information, and try again. + -- But if an incremental update then fails _again_, we instead attempt a + -- regular download. + | UpdateFailedTwice - -- | Update failed + -- | Update failed (for example: perhaps the local file got corrupted) | UpdateFailed SomeException {------------------------------------------------------------------------------- + Downloaded files +-------------------------------------------------------------------------------} + +class DownloadedFile (down :: * -> *) where + -- | Verify a download file + downloadedVerify :: down a -> Trusted FileInfo -> IO Bool + + -- | Read the file we just downloaded into memory + -- + -- We never read binary data, only metadata. + downloadedRead :: down Metadata -> IO BS.L.ByteString + + -- | Copy a downloaded file to its destination + downloadedCopyTo :: down a -> Path Absolute -> IO () + +{------------------------------------------------------------------------------- Exceptions thrown by specific Repository implementations -------------------------------------------------------------------------------} @@ -369,10 +378,10 @@ Paths -------------------------------------------------------------------------------} -remoteRepoPath :: RepoLayout -> RemoteFile fs -> Formats fs RepoPath +remoteRepoPath :: RepoLayout -> RemoteFile fs typ -> Formats fs RepoPath remoteRepoPath RepoLayout{..} = go where - go :: RemoteFile fs -> Formats fs RepoPath + go :: RemoteFile fs typ -> Formats fs RepoPath go RemoteTimestamp = FsUn $ repoLayoutTimestamp go (RemoteRoot _) = FsUn $ repoLayoutRoot go (RemoteSnapshot _) = FsUn $ repoLayoutSnapshot @@ -384,32 +393,25 @@ goIndex FUn _ = repoLayoutIndexTar goIndex FGz _ = repoLayoutIndexTarGz -remoteRepoPath' :: RepoLayout -> RemoteFile fs -> HasFormat fs f -> RepoPath +remoteRepoPath' :: RepoLayout -> RemoteFile fs typ -> HasFormat fs f -> RepoPath remoteRepoPath' repoLayout file format = formatsLookup format $ remoteRepoPath repoLayout file -indexFilePath :: IndexLayout -> IndexFile -> IndexPath -indexFilePath IndexLayout{..} = go - where - go :: IndexFile -> IndexPath - go (IndexPkgMetadata pkgId) = indexLayoutPkgMetadata pkgId - go (IndexPkgCabal pkgId) = indexLayoutPkgCabal pkgId - {------------------------------------------------------------------------------- Utility -------------------------------------------------------------------------------} -- | Is a particular remote file cached? -data IsCached = +data IsCached :: * -> * where -- | This remote file should be cached, and we ask for it by name - CacheAs CachedFile + CacheAs :: CachedFile -> IsCached Metadata -- | We don't cache this remote file -- -- This doesn't mean a Repository should not feel free to cache the file -- if desired, but it does mean the generic algorithms will never ask for -- this file from the cache. - | DontCache + DontCache :: IsCached Binary -- | The index is somewhat special: it should be cached, but we never -- ask for it directly. @@ -419,11 +421,13 @@ -- the index in uncompressed form, others in compressed form; some might -- keep an index tarball index for quick access, others may scan the tarball -- linearly, etc. - | CacheIndex - deriving (Eq, Ord, Show) + CacheIndex :: IsCached Binary +deriving instance Eq (IsCached typ) +deriving instance Show (IsCached typ) + -- | Which remote files should we cache locally? -mustCache :: RemoteFile fs -> IsCached +mustCache :: RemoteFile fs typ -> IsCached typ mustCache RemoteTimestamp = CacheAs CachedTimestamp mustCache (RemoteRoot _) = CacheAs CachedRoot mustCache (RemoteSnapshot _) = CacheAs CachedSnapshot @@ -436,27 +440,23 @@ "Root info updated" pretty (LogVerificationError err) = "Verification error: " ++ pretty err - pretty (LogDownloading (Some file)) = + pretty (LogDownloading file) = "Downloading " ++ pretty file - pretty (LogUpdating (Some file)) = + pretty (LogUpdating file) = "Updating " ++ pretty file pretty (LogSelectedMirror mirror) = "Selected mirror " ++ mirror - pretty (LogCannotUpdate (Some file) ex) = + pretty (LogCannotUpdate file ex) = "Cannot update " ++ pretty file ++ " (" ++ pretty ex ++ ")" pretty (LogMirrorFailed mirror ex) = "Exception " ++ displayException ex ++ " when using mirror " ++ mirror instance Pretty UpdateFailure where - pretty UpdateImpossibleOnlyCompressed = - "server only provides file in compressed format" - pretty UpdateNotUsefulWantsCompressed = - "clients wants file in compressed format" pretty UpdateImpossibleUnsupported = "server does not provide incremental downloads" pretty UpdateImpossibleNoLocalCopy = "no local copy" - pretty UpdateTooLarge = - "update too large" + pretty UpdateFailedTwice = + "update failed twice" pretty (UpdateFailed ex) = displayException ex diff --git a/src/Hackage/Security/Client/Repository/Cache.hs b/src/Hackage/Security/Client/Repository/Cache.hs --- a/src/Hackage/Security/Client/Repository/Cache.hs +++ b/src/Hackage/Security/Client/Repository/Cache.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} -- | The files we cache from the repository -- -- Both the Local and the Remote repositories make use of this module. @@ -7,17 +8,20 @@ , getCachedRoot , getCachedIndex , clearCache - , getFromIndex +-- , getFromIndex + , withIndex + , getIndexIdx , cacheRemoteFile + , lockCache ) where import Control.Exception import Control.Monad -import Codec.Archive.Tar.Index (TarIndex) +import Codec.Archive.Tar (Entries(..)) +import Codec.Archive.Tar.Index (TarIndex, IndexBuilder, TarEntryOffset) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Index as TarIndex import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS.Builder import qualified Data.ByteString.Lazy as BS.L @@ -30,60 +34,78 @@ -- | Location and layout of the local cache data Cache = Cache { - cacheRoot :: AbsolutePath + cacheRoot :: Path Absolute , cacheLayout :: CacheLayout } -- | Cache a previously downloaded remote file -cacheRemoteFile :: Cache -> TempPath -> Format f -> IsCached -> IO () -cacheRemoteFile cache tempPath f isCached = do +cacheRemoteFile :: forall down typ f. DownloadedFile down + => Cache -> down typ -> Format f -> IsCached typ -> IO () +cacheRemoteFile cache downloaded f isCached = do go f isCached - -- TODO: This recreates the tar index ahead of time. Alternatively, we - -- could delete the index here and then it will be rebuilt on first access. - when (isCached == CacheIndex) $ rebuildTarIndex cache + case isCached of + CacheIndex -> rebuildTarIndex cache + _otherwise -> return () where - -- TODO: The case for FGz / CacheAs doesn't really occur in practice, - -- because we never download any of the TUF datafiles in compressed format. - -- It doesn't really harm though, and if we wanted to avoid this case we'd - -- have to encode more information in the types. - go :: Format f -> IsCached -> IO () - go _ DontCache = return () - go FUn (CacheAs cachedFile) = do copyTo $ cachedFilePath cache cachedFile - go FGz (CacheAs cachedFile) = do ungzTo $ cachedFilePath cache cachedFile - go FUn CacheIndex = do copyTo $ cachedIndexTarPath cache - go FGz CacheIndex = do ungzTo $ cachedIndexTarPath cache - case cachedIndexTarGzPath cache of - Nothing -> return () - Just tarGzPath -> copyTo tarGzPath + go :: Format f -> IsCached typ -> IO () + go _ DontCache = return () + go FUn (CacheAs file) = copyTo (cachedFilePath cache file) + go FGz CacheIndex = copyTo (cachedIndexPath cache FGz) >> unzipIndex + go _ _ = error "cacheRemoteFile: unexpected case" -- TODO: enforce in types? - copyTo :: AbsolutePath -> IO () + copyTo :: Path Absolute -> IO () copyTo fp = do createDirectoryIfMissing True (takeDirectory fp) - atomicCopyFile tempPath fp + downloadedCopyTo downloaded fp - ungzTo :: AbsolutePath -> IO () - ungzTo fp = do - createDirectoryIfMissing True (takeDirectory fp) - compressed <- readLazyByteString tempPath - atomicWriteFile fp $ GZip.decompress compressed + -- Whether or not we downloaded the compressed index incrementally, we can + -- always update the uncompressed index incrementally. + -- NOTE: This assumes we already updated the compressed file. + unzipIndex :: typ ~ Binary => IO () + unzipIndex = do + createDirectoryIfMissing True (takeDirectory indexUn) + compressed <- readLazyByteString indexGz + let uncompressed = GZip.decompress compressed + withFile indexUn ReadWriteMode $ \h -> do + currentSize <- hFileSize h + let seekTo = 0 `max` (currentSize - tarTrailer) + hSeek h AbsoluteSeek seekTo + BS.L.hPut h $ BS.L.drop (fromInteger seekTo) uncompressed + where + indexGz = cachedIndexPath cache FGz + indexUn = cachedIndexPath cache FUn + tarTrailer :: Integer + tarTrailer = 1024 + -- | Rebuild the tarball index -- --- TODO: Should we attempt to rebuild this incrementally? +-- Attempts to add to the existing index, if one exists. +-- -- TODO: Use throwChecked rather than throwUnchecked, and deal with the fallout. -- See . rebuildTarIndex :: Cache -> IO () rebuildTarIndex cache = do - entries <- Tar.read <$> readLazyByteString (cachedIndexTarPath cache) - case TarIndex.build entries of - Left ex -> throwUnchecked ex - Right index -> - atomicWithFile (cachedIndexIdxPath cache) $ \h -> do - hSetBuffering h (BlockBuffering Nothing) - BS.Builder.hPutBuilder h $ TarIndex.serialise index + (builder, offset) <- initBuilder <$> tryReadIndex (cachedIndexIdxPath cache) + withFile (cachedIndexPath cache FUn) ReadMode $ \hTar -> do + TarIndex.hSeekEntryOffset hTar offset + newEntries <- Tar.read <$> BS.L.hGetContents hTar + case addEntries builder newEntries of + Left ex -> throwUnchecked ex + Right idx -> withFile (cachedIndexIdxPath cache) WriteMode $ \hIdx -> do + hSetBuffering hIdx (BlockBuffering Nothing) + BS.Builder.hPutBuilder hIdx $ TarIndex.serialise idx + where + -- The initial index builder + -- If we don't have an index (or it's broken), we start from scratch + initBuilder :: Either e TarIndex -> (IndexBuilder, TarEntryOffset) + initBuilder (Left _) = ( TarIndex.empty, 0 ) + initBuilder (Right idx) = ( TarIndex.unfinalise idx + , TarIndex.indexEndEntryOffset idx + ) -- | Get a cached file (if available) -getCached :: Cache -> CachedFile -> IO (Maybe AbsolutePath) +getCached :: Cache -> CachedFile -> IO (Maybe (Path Absolute)) getCached cache cachedFile = do exists <- doesFileExist localPath if exists then return $ Just localPath @@ -92,61 +114,34 @@ localPath = cachedFilePath cache cachedFile -- | Get the cached index (if available) -getCachedIndex :: Cache -> IO (Maybe AbsolutePath) -getCachedIndex cache = do +getCachedIndex :: Cache -> Format f -> IO (Maybe (Path Absolute)) +getCachedIndex cache format = do exists <- doesFileExist localPath if exists then return $ Just localPath else return $ Nothing where - localPath = cachedIndexTarPath cache + localPath = cachedIndexPath cache format -- | Get the cached root -- -- Calling 'getCachedRoot' without root info available is a programmer error -- and will result in an unchecked exception. See 'requiresBootstrap'. -getCachedRoot :: Cache -> IO AbsolutePath +getCachedRoot :: Cache -> IO (Path Absolute) getCachedRoot cache = do mPath <- getCached cache CachedRoot case mPath of Just p -> return p Nothing -> internalError "Client missing root info" --- | Get a file from the index -getFromIndex :: Cache -> IndexLayout -> IndexFile -> IO (Maybe BS.ByteString) -getFromIndex cache indexLayout indexFile = do - mIndex <- tryReadIndex (cachedIndexIdxPath cache) +getIndexIdx :: Cache -> IO TarIndex +getIndexIdx cache = do + mIndex <- tryReadIndex $ cachedIndexIdxPath cache case mIndex of - Left _err -> do - -- If index is corrupted, rebuild and try again - rebuildTarIndex cache - getFromIndex cache indexLayout indexFile - Right index -> - case tarIndexLookup index (tarPath (indexFilePath indexLayout indexFile)) of - Just (TarIndex.TarFileEntry offset) -> - -- TODO: We might want to keep this handle open - withFileInReadMode (cachedIndexTarPath cache) $ \h -> do - entry <- TarIndex.hReadEntry h offset - case Tar.entryContent entry of - Tar.NormalFile lbs _size -> do - bs <- evaluate $ BS.concat . BS.L.toChunks $ lbs - return $ Just bs - _otherwise -> - return Nothing - _otherwise -> - return Nothing - where - tarPath :: IndexPath -> TarballPath - tarPath = castRoot + Left _ -> throwIO $ userError "Could not read index. Did you call 'checkForUpdates'?" + Right idx -> return idx - -- TODO: How come 'deserialise' uses _strict_ ByteStrings? - tryReadIndex :: AbsolutePath -> IO (Either (Maybe IOException) TarIndex) - tryReadIndex fp = - aux <$> try (TarIndex.deserialise <$> readStrictByteString fp) - where - aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a - aux (Left e) = Left (Just e) - aux (Right Nothing) = Left Nothing - aux (Right (Just (a, _))) = Right a +withIndex :: Cache -> (Handle -> IO a) -> IO a +withIndex cache = withFile (cachedIndexPath cache FUn) ReadMode -- | Delete a previously downloaded remote file clearCache :: Cache -> IO () @@ -154,11 +149,40 @@ removeFile $ cachedFilePath cache CachedTimestamp removeFile $ cachedFilePath cache CachedSnapshot +-- | Lock the cache +-- +-- This avoids two concurrent processes updating the cache at the same time, +-- provided they both take the lock. +lockCache :: Cache -> IO () -> IO () +lockCache Cache{..} = withDirLock cacheRoot + {------------------------------------------------------------------------------- + Auxiliary: tar +-------------------------------------------------------------------------------} + +-- | Variation on 'TarIndex.build' that takes in the initial 'IndexBuilder' +addEntries :: IndexBuilder -> Entries e -> Either e TarIndex +addEntries = go + where + go !builder (Next e es) = go (TarIndex.addNextEntry e builder) es + go !builder Done = Right $! TarIndex.finalise builder + go !_ (Fail err) = Left err + +-- TODO: How come 'deserialise' uses _strict_ ByteStrings? +tryReadIndex :: Path Absolute -> IO (Either (Maybe IOException) TarIndex) +tryReadIndex fp = + aux <$> try (TarIndex.deserialise <$> readStrictByteString fp) + where + aux :: Either e (Maybe (a, leftover)) -> Either (Maybe e) a + aux (Left e) = Left (Just e) + aux (Right Nothing) = Left Nothing + aux (Right (Just (a, _))) = Right a + +{------------------------------------------------------------------------------- Auxiliary: paths -------------------------------------------------------------------------------} -cachedFilePath :: Cache -> CachedFile -> AbsolutePath +cachedFilePath :: Cache -> CachedFile -> Path Absolute cachedFilePath Cache{cacheLayout=CacheLayout{..}, ..} file = anchorCachePath cacheRoot $ go file where @@ -168,14 +192,14 @@ go CachedSnapshot = cacheLayoutSnapshot go CachedMirrors = cacheLayoutMirrors -cachedIndexTarPath :: Cache -> AbsolutePath -cachedIndexTarPath Cache{..} = - anchorCachePath cacheRoot $ cacheLayoutIndexTar cacheLayout - -cachedIndexTarGzPath :: Cache -> Maybe AbsolutePath -cachedIndexTarGzPath Cache{..} = - fmap (anchorCachePath cacheRoot) $ cacheLayoutIndexTarGz cacheLayout +cachedIndexPath :: Cache -> Format f -> Path Absolute +cachedIndexPath Cache{..} format = + anchorCachePath cacheRoot $ go format + where + go :: Format f -> CachePath + go FUn = cacheLayoutIndexTar cacheLayout + go FGz = cacheLayoutIndexTarGz cacheLayout -cachedIndexIdxPath :: Cache -> AbsolutePath +cachedIndexIdxPath :: Cache -> Path Absolute cachedIndexIdxPath Cache{..} = anchorCachePath cacheRoot $ cacheLayoutIndexIdx cacheLayout diff --git a/src/Hackage/Security/Client/Repository/HttpLib.hs b/src/Hackage/Security/Client/Repository/HttpLib.hs --- a/src/Hackage/Security/Client/Repository/HttpLib.hs +++ b/src/Hackage/Security/Client/Repository/HttpLib.hs @@ -4,6 +4,7 @@ HttpLib(..) , HttpRequestHeader(..) , HttpResponseHeader(..) + , HttpStatus(..) , ProxyConfig(..) -- ** Body reader , BodyReader @@ -39,11 +40,23 @@ -- | Download a byte range -- -- Range is starting and (exclusive) end offset in bytes. + -- + -- HTTP servers are normally expected to respond to a range request with + -- a "206 Partial Content" response. However, servers can respond with a + -- "200 OK" response, sending the entire file instead (for instance, this + -- may happen for servers that don't actually support range rqeuests, but + -- for which we optimistically assumed they did). Implementations of + -- 'HttpLib' may accept such a response and inform the @hackage-security@ + -- library that the whole file is being returned; the security library can + -- then decide to execute the 'BodyReader' anyway (downloading the entire + -- file) or abort the request and try something else. For this reason + -- the security library must be informed whether the server returned the + -- full file or the requested range. , httpGetRange :: forall a. Throws SomeRemoteError => [HttpRequestHeader] -> URI -> (Int, Int) - -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a) -> IO a } @@ -57,18 +70,16 @@ -- | Set @Cache-Control: no-transform@ | HttpRequestNoTransform - - -- | Request transport compression (@Accept-Encoding: gzip@) - -- - -- It is the responsibility of the 'HttpLib' to do compression - -- (and report whether the original server reply was compressed or not). - -- - -- NOTE: Clients should NOT allow for compression unless explicitly - -- requested (since decompression happens before signature verification, it - -- is a potential security concern). - | HttpRequestContentCompression deriving (Eq, Ord, Show) +-- | HTTP status code +data HttpStatus = + -- | 200 OK + HttpStatus200OK + + -- | 206 Partial Content + | HttpStatus206PartialContent + -- | Response headers -- -- Since different libraries represent headers differently, here we just @@ -76,10 +87,6 @@ data HttpResponseHeader = -- | Server accepts byte-range requests (@Accept-Ranges: bytes@) HttpResponseAcceptRangesBytes - - -- | Original server response was compressed - -- (the 'HttpLib' however must do decompression) - | HttpResponseContentCompression deriving (Eq, Ord, Show) -- | Proxy configuration diff --git a/src/Hackage/Security/Client/Repository/Local.hs b/src/Hackage/Security/Client/Repository/Local.hs --- a/src/Hackage/Security/Client/Repository/Local.hs +++ b/src/Hackage/Security/Client/Repository/Local.hs @@ -1,13 +1,17 @@ -- | Local repository module Hackage.Security.Client.Repository.Local ( LocalRepo + , LocalFile -- opaque , withRepository ) where +import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.Client.Repository.Cache -import Hackage.Security.Client.Formats +import Hackage.Security.Client.Verify import Hackage.Security.TUF +import Hackage.Security.Trusted +import Hackage.Security.Util.IO import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty import Hackage.Security.Util.Some @@ -16,7 +20,7 @@ -- -- Note that we regard the local repository as immutable; we cache files just -- like we do for remote repositories. -type LocalRepo = Path (Rooted Absolute) +type LocalRepo = Path Absolute -- | Initialize the repository (and cleanup resources afterwards) -- @@ -26,38 +30,70 @@ -- -- It uses the same cache as the remote repository. withRepository - :: LocalRepo -- ^ Location of local repository - -> Cache -- ^ Location of local cache - -> RepoLayout -- ^ Repository layout - -> (LogMessage -> IO ()) -- ^ Logger - -> (Repository -> IO a) -- ^ Callback + :: LocalRepo -- ^ Location of local repository + -> Cache -- ^ Location of local cache + -> RepoLayout -- ^ Repository layout + -> IndexLayout -- ^ Index layout + -> (LogMessage -> IO ()) -- ^ Logger + -> (Repository LocalFile -> IO a) -- ^ Callback -> IO a -withRepository repo cache repLayout logger callback = callback Repository { - repWithRemote = withRemote repLayout repo cache +withRepository repo + cache + repLayout + repIndexLayout + logger + callback + = + callback Repository { + repGetRemote = getRemote repLayout repo cache , repGetCached = getCached cache , repGetCachedRoot = getCachedRoot cache , repClearCache = clearCache cache - , repGetFromIndex = getFromIndex cache (repoIndexLayout repLayout) + , repWithIndex = withIndex cache + , repGetIndexIdx = getIndexIdx cache + , repLockCache = lockCache cache , repWithMirror = mirrorsUnsupported , repLog = logger , repLayout = repLayout + , repIndexLayout = repIndexLayout , repDescription = "Local repository at " ++ pretty repo } -- | Get a file from the server -withRemote :: RepoLayout -> LocalRepo -> Cache - -> IsRetry - -> RemoteFile fs - -> (forall f. HasFormat fs f -> TempPath -> IO a) - -> IO a -withRemote repoLayout repo cache _isRetry remoteFile callback = do +getRemote :: RepoLayout -> LocalRepo -> Cache + -> AttemptNr + -> RemoteFile fs typ + -> Verify (Some (HasFormat fs), LocalFile typ) +getRemote repoLayout repo cache _attemptNr remoteFile = do case remoteFileDefaultFormat remoteFile of Some format -> do let remotePath' = remoteRepoPath' repoLayout remoteFile format remotePath = anchorRepoPathLocally repo remotePath' - result <- callback format remotePath - cacheRemoteFile cache - remotePath - (hasFormatGet format) - (mustCache remoteFile) - return result + localFile = LocalFile remotePath + ifVerified $ + cacheRemoteFile cache + localFile + (hasFormatGet format) + (mustCache remoteFile) + return (Some format, localFile) + +{------------------------------------------------------------------------------- + Files in the local repository +-------------------------------------------------------------------------------} + +newtype LocalFile a = LocalFile (Path Absolute) + +instance DownloadedFile LocalFile where + downloadedVerify = verifyLocalFile + downloadedRead = \(LocalFile local) -> readLazyByteString local + downloadedCopyTo = \(LocalFile local) -> copyFile local + +verifyLocalFile :: LocalFile typ -> Trusted FileInfo -> IO Bool +verifyLocalFile (LocalFile fp) trustedInfo = do + -- Verify the file size before comparing the entire file info + sz <- FileLength <$> getFileSize fp + if sz /= fileInfoLength + then return False + else knownFileInfoEqual info <$> computeFileInfo fp + where + info@FileInfo{..} = trusted trustedInfo diff --git a/src/Hackage/Security/Client/Repository/Remote.hs b/src/Hackage/Security/Client/Repository/Remote.hs --- a/src/Hackage/Security/Client/Repository/Remote.hs +++ b/src/Hackage/Security/Client/Repository/Remote.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | An implementation of Repository that talks to repositories over HTTP. -- -- This implementation is itself parameterized over a 'HttpClient', so that it @@ -20,6 +21,7 @@ withRepository , RepoOpts(..) , defaultRepoOpts + , RemoteTemp -- * File sizes , FileSize(..) , fileSizeWithinBounds @@ -29,9 +31,10 @@ import Control.Exception import Control.Monad.Cont import Control.Monad.Except -import Data.List (nub) +import Data.List (nub, intercalate) +import Data.Typeable import Network.URI hiding (uriPath, path) -import System.IO +import System.IO () import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L @@ -39,11 +42,13 @@ import Hackage.Security.Client.Repository import Hackage.Security.Client.Repository.Cache (Cache) import Hackage.Security.Client.Repository.HttpLib +import Hackage.Security.Client.Verify import Hackage.Security.Trusted import Hackage.Security.TUF import Hackage.Security.Util.Checked import Hackage.Security.Util.IO import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty import Hackage.Security.Util.Some import qualified Hackage.Security.Client.Repository.Cache as Cache @@ -87,13 +92,14 @@ data FileSize = -- | For most files we download we know the exact size beforehand -- (because this information comes from the snapshot or delegated info) - FileSizeExact Int + FileSizeExact Int54 -- | For some files we might not know the size beforehand, but we might -- be able to provide an upper bound (timestamp, root info) - | FileSizeBound Int + | FileSizeBound Int54 + deriving Show -fileSizeWithinBounds :: Int -> FileSize -> Bool +fileSizeWithinBounds :: Int54 -> FileSize -> Bool fileSizeWithinBounds sz (FileSizeExact sz') = sz <= sz' fileSizeWithinBounds sz (FileSizeBound sz') = sz <= sz' @@ -105,32 +111,18 @@ -- -- Clients should use 'defaultRepositoryOpts' and override required settings. data RepoOpts = RepoOpts { - -- | Should we allow HTTP content compression? - -- - -- Since content compression happens before signature verification, users - -- who are concerned about potential exploits of the decompression - -- algorithm may prefer to disallow content compression. - repoAllowContentCompression :: Bool - - -- | Do we want to a copy of the compressed index? - -- - -- This is important for mirroring clients only. - , repoWantCompressedIndex :: Bool - -- | Allow additional mirrors? -- -- If this is set to True (default), in addition to the (out-of-band) -- specified mirrors we will also use mirrors reported by those -- out-of-band mirrors (that is, @mirrors.json@). - , repoAllowAdditionalMirrors :: Bool + repoAllowAdditionalMirrors :: Bool } -- | Default repository options defaultRepoOpts :: RepoOpts defaultRepoOpts = RepoOpts { - repoAllowContentCompression = True - , repoWantCompressedIndex = False - , repoAllowAdditionalMirrors = True + repoAllowAdditionalMirrors = True } -- | Initialize the repository (and cleanup resources afterwards) @@ -150,19 +142,21 @@ -- here and the mirrors that we get from @mirrors.json@) as well as indicating -- mirror preferences. withRepository - :: HttpLib -- ^ Implementation of the HTTP protocol - -> [URI] -- ^ "Out of band" list of mirrors - -> RepoOpts -- ^ Repository options - -> Cache -- ^ Location of local cache - -> RepoLayout -- ^ Repository layout - -> (LogMessage -> IO ()) -- ^ Logger - -> (Repository -> IO a) -- ^ Callback + :: HttpLib -- ^ Implementation of the HTTP protocol + -> [URI] -- ^ "Out of band" list of mirrors + -> RepoOpts -- ^ Repository options + -> Cache -- ^ Location of local cache + -> RepoLayout -- ^ Repository layout + -> IndexLayout -- ^ Index layout + -> (LogMessage -> IO ()) -- ^ Logger + -> (Repository RemoteTemp -> IO a) -- ^ Callback -> IO a withRepository httpLib outOfBandMirrors repoOpts cache repLayout + repIndexLayout logger callback = do @@ -174,15 +168,17 @@ , cfgBase = mirror , cfgCache = cache , cfgCaps = caps - , cfgLogger = logger + , cfgLogger = liftIO . logger , cfgOpts = repoOpts } callback Repository { - repWithRemote = withRemote remoteConfig selectedMirror + repGetRemote = getRemote remoteConfig selectedMirror , repGetCached = Cache.getCached cache , repGetCachedRoot = Cache.getCachedRoot cache , repClearCache = Cache.clearCache cache - , repGetFromIndex = Cache.getFromIndex cache (repoIndexLayout repLayout) + , repWithIndex = Cache.withIndex cache + , repGetIndexIdx = Cache.getIndexIdx cache + , repLockCache = Cache.lockCache cache , repWithMirror = withMirror httpLib selectedMirror logger @@ -190,6 +186,7 @@ repoOpts , repLog = logger , repLayout = repLayout + , repIndexLayout = repIndexLayout , repDescription = "Remote repository at " ++ show outOfBandMirrors } @@ -199,8 +196,8 @@ -- | We select a mirror in 'withMirror' (the implementation of 'repWithMirror'). -- Outside the scope of 'withMirror' no mirror is selected, and a call to --- 'withRemote' will throw an exception. If this exception is ever thrown its --- a bug: calls to 'withRemote' ('repWithRemote') should _always_ be in the +-- 'getRemote' will throw an exception. If this exception is ever thrown its +-- a bug: calls to 'getRemote' ('repGetRemote') should _always_ be in the -- scope of 'repWithMirror'. type SelectedMirror = MVar (Maybe URI) @@ -220,26 +217,17 @@ Just baseURI -> return baseURI -- | Get a file from the server -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 - --- | Get a file from the server, assuming we have already picked a mirror -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 +getRemote :: Throws SomeRemoteError + => (URI -> RemoteConfig) + -> SelectedMirror + -> AttemptNr + -> RemoteFile fs typ + -> Verify (Some (HasFormat fs), RemoteTemp typ) +getRemote remoteConfig selectedMirror attemptNr remoteFile = do + baseURI <- liftIO $ getSelectedMirror selectedMirror + let cfg = remoteConfig baseURI + downloadMethod <- liftIO $ pickDownloadMethod cfg attemptNr remoteFile + getFile cfg attemptNr remoteFile downloadMethod -- | HTTP options -- @@ -247,31 +235,14 @@ -- mess things up with respect to hashes etc). Additionally, after a validation -- error we want to make sure caches get files upstream in case the validation -- error was because the cache updated files out of order. -httpRequestHeaders :: RemoteConfig - -> IsRetry - -> DownloadMethod fs - -> [HttpRequestHeader] -httpRequestHeaders RemoteConfig{..} isRetry method = - case isRetry of - FirstAttempt -> defaultHeaders - AfterVerificationError -> HttpRequestMaxAge0 : defaultHeaders +httpRequestHeaders :: RemoteConfig -> AttemptNr -> [HttpRequestHeader] +httpRequestHeaders RemoteConfig{..} attemptNr = + if attemptNr == 0 then defaultHeaders + else HttpRequestMaxAge0 : defaultHeaders where -- Headers we provide for _every_ attempt, first or not defaultHeaders :: [HttpRequestHeader] - defaultHeaders = concat [ - [ HttpRequestNoTransform ] - , [ HttpRequestContentCompression - | repoAllowContentCompression cfgOpts && not (isRangeRequest method) - ] - ] - - -- If we are doing a range request, we must not request content compression: - -- servers such as Apache interpret this range against the _compressed_ - -- stream, making it near useless for our purposes here. - isRangeRequest :: DownloadMethod fs -> Bool - isRangeRequest NeverUpdated{} = False - isRangeRequest CannotUpdate{} = False - isRangeRequest Update{} = True + defaultHeaders = [HttpRequestNoTransform] -- | Mirror selection withMirror :: forall a. @@ -327,204 +298,164 @@ -------------------------------------------------------------------------------} -- | Download method (downloading or updating) -data DownloadMethod fs = +data DownloadMethod :: * -> * -> * where -- | Download this file (we never attempt to update this type of file) - forall f. NeverUpdated { - downloadFormat :: HasFormat fs f - } + NeverUpdated :: { + neverUpdatedFormat :: HasFormat fs f + } -> DownloadMethod fs typ -- | Download this file (we cannot update this file right now) - | forall f. CannotUpdate { - downloadFormat :: HasFormat fs f - , downloadReason :: UpdateFailure - } + CannotUpdate :: { + cannotUpdateFormat :: HasFormat fs f + , cannotUpdateReason :: UpdateFailure + } -> DownloadMethod fs Binary -- | Attempt an (incremental) update of this file - -- - -- We record the trailer for the file; that is, the number of bytes - -- (counted from the end of the file) that we should overwrite with - -- the remote file. - | forall f f'. Update { - updateFormat :: HasFormat fs f - , updateInfo :: Trusted FileInfo - , updateLocal :: AbsolutePath - , updateTrailer :: Integer - , downloadFormat :: HasFormat fs f' -- ^ In case an update fails - } - -pickDownloadMethod :: RemoteConfig - -> RemoteFile fs - -> IO (DownloadMethod fs) -pickDownloadMethod RemoteConfig{..} remoteFile = multipleExitPoints $ do - -- We only have a choice for the index; everywhere else the repository only - -- gives a single option. For the index we return a proof that the - -- repository must at least have the compressed form available. - (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) - - -- If the client wants the compressed index, we have no choice - when (repoWantCompressedIndex cfgOpts) $ - exit $ CannotUpdate hasGz UpdateNotUsefulWantsCompressed - - -- Server must have uncompressed index available - hasUn <- case formatsMember FUn formats of - Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleOnlyCompressed - Just hasUn -> return hasUn - - -- Server must support @Range@ with a byte-range - rangeSupport <- checkServerCapability cfgCaps serverAcceptRangesBytes - unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported + Update :: { + updateFormat :: HasFormat fs f + , updateInfo :: Trusted FileInfo + , updateLocal :: Path Absolute + , updateTail :: Int54 + } -> DownloadMethod fs Binary - -- We must already have a local file to be updated - -- (if not we should try to download the initial file in compressed form) - mCachedIndex <- lift $ Cache.getCachedIndex cfgCache - cachedIndex <- case mCachedIndex of - Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy - Just fp -> return fp +pickDownloadMethod :: forall fs typ. RemoteConfig + -> AttemptNr + -> RemoteFile fs typ + -> IO (DownloadMethod fs typ) +pickDownloadMethod RemoteConfig{..} attemptNr remoteFile = + case remoteFile of + RemoteTimestamp -> return $ NeverUpdated (HFZ FUn) + (RemoteRoot _) -> return $ NeverUpdated (HFZ FUn) + (RemoteSnapshot _) -> return $ NeverUpdated (HFZ FUn) + (RemoteMirrors _) -> return $ NeverUpdated (HFZ FUn) + (RemotePkgTarGz _ _) -> return $ NeverUpdated (HFZ FGz) + (RemoteIndex hasGz formats) -> multipleExitPoints $ do + -- Server must support @Range@ with a byte-range + rangeSupport <- checkServerCapability cfgCaps serverAcceptRangesBytes + unless rangeSupport $ exit $ CannotUpdate hasGz UpdateImpossibleUnsupported - -- Index trailer - -- - -- TODO: This hardcodes the trailer length as 1024. We should instead take - -- advantage of the tarball index to find out where the trailer starts. - let trailerLength = 1024 + -- We must already have a local file to be updated + mCachedIndex <- lift $ Cache.getCachedIndex cfgCache (hasFormatGet hasGz) + cachedIndex <- case mCachedIndex of + Nothing -> exit $ CannotUpdate hasGz UpdateImpossibleNoLocalCopy + Just fp -> return fp - -- File sizes - 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 + -- We attempt an incremental update a maximum of 2 times + -- See 'UpdateFailedTwice' for details. + when (attemptNr >= 2) $ exit $ CannotUpdate hasGz UpdateFailedTwice - -- If all these checks pass try to do an incremental update. - return Update { - updateFormat = hasUn - , updateInfo = infoUn - , updateLocal = cachedIndex - , updateTrailer = trailerLength - , downloadFormat = hasGz - } + -- If all these checks pass try to do an incremental update. + return Update { + updateFormat = hasGz + , updateInfo = formatsLookup hasGz formats + , updateLocal = cachedIndex + , updateTail = 65536 -- max gzip block size + } -- | Download the specified file using the given download method -getFile :: forall fs a. (Throws VerificationError, Throws SomeRemoteError) - => RemoteConfig -- ^ Internal configuration - -> IsRetry -- ^ Did a security check previously fail? - -> RemoteFile fs -- ^ File to get - -> (forall f. HasFormat fs f -> TempPath -> IO a) -- ^ Callback - -> DownloadMethod fs -- ^ Selected format - -> IO a -getFile cfg@RemoteConfig{..} isRetry remoteFile callback method = +getFile :: forall fs typ. Throws SomeRemoteError + => RemoteConfig -- ^ Internal configuration + -> AttemptNr -- ^ Did a security check previously fail? + -> RemoteFile fs typ -- ^ File to get + -> DownloadMethod fs typ -- ^ Selected format + -> Verify (Some (HasFormat fs), RemoteTemp typ) +getFile cfg@RemoteConfig{..} attemptNr remoteFile method = go method where - go :: (Throws VerificationError, Throws SomeRemoteError) - => DownloadMethod fs -> IO a + go :: Throws SomeRemoteError + => DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ) go NeverUpdated{..} = do - cfgLogger $ LogDownloading (Some remoteFile) - download downloadFormat + cfgLogger $ LogDownloading remoteFile + download neverUpdatedFormat go CannotUpdate{..} = do - cfgLogger $ LogCannotUpdate (Some remoteFile) downloadReason - cfgLogger $ LogDownloading (Some remoteFile) - download downloadFormat + cfgLogger $ LogCannotUpdate remoteFile cannotUpdateReason + cfgLogger $ LogDownloading remoteFile + download cannotUpdateFormat go Update{..} = do - cfgLogger $ LogUpdating (Some remoteFile) - -- Attempt to download the file incrementally. - let updateFailed :: SomeException -> IO a - updateFailed = go . CannotUpdate downloadFormat . UpdateFailed - - -- If verification of the file fails, and this is the first attempt, - -- we let the exception be thrown up to the security layer, so that - -- it will try again with instructions to the cache to fetch stuff - -- upstream. Hopefully this will resolve the issue. However, if - -- an incrementally updated file cannot be verified on the next - -- attempt, we then try to download the whole file. - 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 + cfgLogger $ LogUpdating remoteFile + update updateFormat updateInfo updateLocal updateTail headers :: [HttpRequestHeader] - headers = httpRequestHeaders cfg isRetry method + headers = httpRequestHeaders cfg attemptNr -- Get any file from the server, without using incremental updates - download :: Throws SomeRemoteError => HasFormat fs f -> IO a - download format = - withTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri) $ \tempPath h -> do - -- We are careful NOT to scope the remainder of the computation underneath - -- the httpClientGet + download :: Throws SomeRemoteError => HasFormat fs f + -> Verify (Some (HasFormat fs), RemoteTemp typ) + download format = do + (tempPath, h) <- openTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri) + liftIO $ do httpGet headers uri $ \responseHeaders bodyReader -> do updateServerCapabilities cfgCaps responseHeaders execBodyReader targetPath sz h bodyReader hClose h - verifyAndCache format tempPath + cacheIfVerified format $ DownloadedWhole tempPath where targetPath = TargetPathRepo $ remoteRepoPath' cfgLayout remoteFile format uri = formatsLookup format $ remoteFileURI cfgLayout cfgBase remoteFile sz = formatsLookup format $ remoteFileSize remoteFile -- Get a file incrementally - -- - -- Sadly, this has some tar-specific functionality - update :: HasFormat fs f -- ^ Selected format - -> Trusted FileInfo -- ^ Expected info - -> AbsolutePath -- ^ Location of cached tar (after callback) - -> Integer -- ^ Trailer length - -> 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 - -- As in 'getFile', make sure we don't scope the remainder of the - -- computation underneath the httpClientGetRange - httpGetRange headers uri range $ \responseHeaders bodyReader -> do + update :: (typ ~ Binary) + => HasFormat fs f -- ^ Selected format + -> Trusted FileInfo -- ^ Expected info + -> Path Absolute -- ^ Location of cached file (after callback) + -> Int54 -- ^ How much of the tail to overwrite + -> Verify (Some (HasFormat fs), RemoteTemp typ) + update format info cachedFile fileTail = do + currentSz <- liftIO $ getFileSize cachedFile + let fileSz = fileLength' info + range = (0 `max` (currentSz - fileTail), fileSz) + range' = (fromIntegral (fst range), fromIntegral (snd range)) + cacheRoot = Cache.cacheRoot cfgCache + (tempPath, h) <- openTempFile cacheRoot (uriTemplate uri) + statusCode <- liftIO $ + httpGetRange headers uri range' $ \statusCode responseHeaders bodyReader -> do updateServerCapabilities cfgCaps responseHeaders - execBodyReader targetPath rangeSz h bodyReader - hClose h - verifyAndCache format tempPath + let expectedSize = + case statusCode of + HttpStatus206PartialContent -> + FileSizeExact (snd range - fst range) + HttpStatus200OK -> + FileSizeExact fileSz + execBodyReader targetPath expectedSize h bodyReader + hClose h + return statusCode + let downloaded = + case statusCode of + HttpStatus206PartialContent -> + DownloadedDelta { + deltaTemp = tempPath + , deltaExisting = cachedFile + , deltaSeek = fst range + } + HttpStatus200OK -> + DownloadedWhole tempPath + cacheIfVerified format downloaded where - targetPath = TargetPathRepo repoLayoutIndexTar - uri = modifyUriPath cfgBase (`anchorRepoPathRemotely` repoLayoutIndexTar) - RepoLayout{repoLayoutIndexTar} = cfgLayout + targetPath = TargetPathRepo repoPath + uri = modifyUriPath cfgBase (`anchorRepoPathRemotely` repoPath) + repoPath = remoteRepoPath' cfgLayout remoteFile format - -- | Verify the downloaded/updated file (by calling the callback) and - -- cache it if the callback does not throw any exceptions - 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 + cacheIfVerified :: HasFormat fs f -> RemoteTemp typ + -> Verify (Some (HasFormat fs), RemoteTemp typ) + cacheIfVerified format remoteTemp = do + ifVerified $ + Cache.cacheRemoteFile cfgCache + remoteTemp + (hasFormatGet format) + (mustCache remoteFile) + return (Some format, remoteTemp) HttpLib{..} = cfgHttpLib +{------------------------------------------------------------------------------- + Execute body reader +-------------------------------------------------------------------------------} + -- | Execute a body reader -- --- NOTE: This intentially does NOT use the @with..@ pattern: we want to execute --- the entire body reader (or cancel it) and write the results to a file and --- then continue. We do NOT want to scope the remainder of the computation --- as part of the same HTTP request. --- -- TODO: Deal with minimum download rate. -execBodyReader :: Throws VerificationError +execBodyReader :: Throws SomeRemoteError => TargetPath -- ^ File source (for error msgs only) -> FileSize -- ^ Maximum file size -> Handle -- ^ Handle to write data too @@ -532,27 +463,54 @@ -> IO () execBodyReader file mlen h br = go 0 where - go :: Int -> IO () + go :: Int54 -> IO () go sz = do unless (sz `fileSizeWithinBounds` mlen) $ - throwChecked $ VerificationErrorFileTooLarge file + throwChecked $ SomeRemoteError $ FileTooLarge file mlen bs <- br if BS.null bs then return () - else BS.hPut h bs >> go (sz + BS.length bs) + else BS.hPut h bs >> go (sz + fromIntegral (BS.length bs)) +-- | The file we requested from the server was larger than expected +-- (potential endless data attack) +data FileTooLarge = FileTooLarge { + fileTooLargePath :: TargetPath + , fileTooLargeExpected :: FileSize + } + deriving (Typeable) + +instance Pretty FileTooLarge where + pretty FileTooLarge{..} = concat [ + "file returned by server too large: " + , pretty fileTooLargePath + , " (expected " ++ expected fileTooLargeExpected ++ " bytes)" + ] + where + expected :: FileSize -> String + expected (FileSizeExact n) = "exactly " ++ show n + expected (FileSizeBound n) = "at most " ++ show n + +#if MIN_VERSION_base(4,8,0) +deriving instance Show FileTooLarge +instance Exception FileTooLarge where displayException = pretty +#else +instance Exception FileTooLarge +instance Show FileTooLarge where show = pretty +#endif + {------------------------------------------------------------------------------- Information about remote files -------------------------------------------------------------------------------} -remoteFileURI :: RepoLayout -> URI -> RemoteFile fs -> Formats fs URI +remoteFileURI :: RepoLayout -> URI -> RemoteFile fs typ -> Formats fs URI remoteFileURI repoLayout baseURI = fmap aux . remoteRepoPath repoLayout where aux :: RepoPath -> URI aux repoPath = modifyUriPath baseURI (`anchorRepoPathRemotely` repoPath) -- | Extracting or estimating file sizes -remoteFileSize :: RemoteFile fs -> Formats fs FileSize +remoteFileSize :: RemoteFile fs typ -> Formats fs FileSize remoteFileSize (RemoteTimestamp) = FsUn $ FileSizeBound fileSizeBoundTimestamp remoteFileSize (RemoteRoot mLen) = @@ -576,7 +534,7 @@ -- just under 200 bytes of that. So even if the timestamp is signed with 10 -- keys it would still only be 2420 bytes. Doubling this amount, an upper bound -- of 4kB should definitely be sufficient. -fileSizeBoundTimestamp :: Int +fileSizeBoundTimestamp :: Int54 fileSizeBoundTimestamp = 4096 -- | Bound on the size of the root @@ -600,7 +558,7 @@ -- -- We end up with a bound of about 665,000 bytes. Doubling this amount, an -- upper bound of 2MB should definitely be sufficient. -fileSizeBoundRoot :: Int +fileSizeBoundRoot :: Int54 fileSizeBoundRoot = 2 * 1024 * 2014 {------------------------------------------------------------------------------- @@ -616,7 +574,7 @@ , cfgBase :: URI , cfgCache :: Cache , cfgCaps :: ServerCapabilities - , cfgLogger :: LogMessage -> IO () + , cfgLogger :: forall m. MonadIO m => LogMessage -> m () , cfgOpts :: RepoOpts } @@ -626,12 +584,102 @@ -- | Template for the local file we use to download a URI to uriTemplate :: URI -> String -uriTemplate = unFragment . takeFileName . uriPath +uriTemplate = takeFileName . uriPath -fileLength' :: Trusted FileInfo -> Int +fileLength' :: Trusted FileInfo -> Int54 fileLength' = fileLength . fileInfoLength . trusted {------------------------------------------------------------------------------- + Files downloaded from the remote repository +-------------------------------------------------------------------------------} + +data RemoteTemp :: * -> * where + DownloadedWhole :: { + wholeTemp :: Path Absolute + } -> RemoteTemp a + + -- | If we download only the delta, we record both the path to where the + -- "old" file is stored and the path to the temp file containing the delta. + -- Then: + -- + -- * When we verify the file, we need both of these paths if we compute + -- the hash from scratch, or only the path to the delta if we attempt + -- to compute the hash incrementally (TODO: incremental verification + -- not currently implemented). + -- * When we copy a file over, we are additionally given a destination + -- path. In this case, we expect that destination path to be equal to + -- the path to the old file (and assert this to be the case). + DownloadedDelta :: { + deltaTemp :: Path Absolute + , deltaExisting :: Path Absolute + , deltaSeek :: Int54 -- ^ How much of the existing file to keep + } -> RemoteTemp Binary + +instance Pretty (RemoteTemp typ) where + pretty DownloadedWhole{..} = intercalate " " $ [ + "DownloadedWhole" + , pretty wholeTemp + ] + pretty DownloadedDelta{..} = intercalate " " $ [ + "DownloadedDelta" + , pretty deltaTemp + , pretty deltaExisting + , show deltaSeek + ] + +instance DownloadedFile RemoteTemp where + downloadedVerify = verifyRemoteFile + downloadedRead = readLazyByteString . wholeTemp + downloadedCopyTo = \f dest -> + case f of + DownloadedWhole{..} -> + renameFile wholeTemp dest + DownloadedDelta{..} -> do + unless (deltaExisting == dest) $ + throwIO $ userError "Assertion failure: deltaExisting /= dest" + -- We need ReadWriteMode in order to be able to seek + withFile deltaExisting ReadWriteMode $ \h -> do + hSeek h AbsoluteSeek (fromIntegral deltaSeek) + BS.L.hPut h =<< readLazyByteString deltaTemp + +-- | Verify a file downloaded from the remote repository +-- +-- TODO: This currently still computes the hash for the whole file. If we cached +-- the state of the hash generator we could compute the hash incrementally. +-- However, profiling suggests that this would only be a minor improvement. +verifyRemoteFile :: RemoteTemp typ -> Trusted FileInfo -> IO Bool +verifyRemoteFile remoteTemp trustedInfo = do + sz <- FileLength <$> remoteSize remoteTemp + if sz /= fileInfoLength + then return False + else withRemoteBS remoteTemp $ knownFileInfoEqual info . fileInfo + where + remoteSize :: RemoteTemp typ -> IO Int54 + remoteSize DownloadedWhole{..} = getFileSize wholeTemp + remoteSize DownloadedDelta{..} = do + deltaSize <- getFileSize deltaTemp + return $ deltaSeek + deltaSize + + -- It is important that we close the file handles when we're done + -- (esp. since we may not read the whole file) + withRemoteBS :: RemoteTemp typ -> (BS.L.ByteString -> Bool) -> IO Bool + withRemoteBS DownloadedWhole{..} callback = do + withFile wholeTemp ReadMode $ \h -> do + bs <- BS.L.hGetContents h + evaluate $ callback bs + withRemoteBS DownloadedDelta{..} callback = + withFile deltaExisting ReadMode $ \hExisting -> + withFile deltaTemp ReadMode $ \hTemp -> do + existing <- BS.L.hGetContents hExisting + temp <- BS.L.hGetContents hTemp + evaluate $ callback $ BS.L.concat [ + BS.L.take (fromIntegral deltaSeek) existing + , temp + ] + + info@FileInfo{..} = trusted trustedInfo + +{------------------------------------------------------------------------------- Auxiliary: multiple exit points -------------------------------------------------------------------------------} @@ -649,7 +697,7 @@ -- -- as -- --- > choose $ do +-- > multipleExitPoints $ do -- > when (cond1) $ -- > exit exp1 -- > when (cond) $ diff --git a/src/Hackage/Security/Client/Verify.hs b/src/Hackage/Security/Client/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Verify.hs @@ -0,0 +1,103 @@ +module Hackage.Security.Client.Verify ( + -- * Verification monad + Verify -- opaque + , runVerify + , acquire + , ifVerified + -- * Specific resources + , openTempFile + -- * Re-exports + , liftIO + ) where + +import Control.Exception +import Control.Monad.Reader +import Data.IORef + +import Hackage.Security.Util.IO +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + Verification monad +-------------------------------------------------------------------------------} + +type Finaliser = IO () +type Cleanup = IO () + +-- | Verification monad +-- +-- The verification monad is similar to 'ResourceT' in intent, in that we can +-- register handlers to be run to release resources. Unlike 'ResourceT', +-- however, we maintain _two_ handlers: a cleanup handler which is run whether +-- or not verification succeeds, and a finalisation handler which is run only if +-- verification succeeds. +-- +-- * Cleanup handlers are registered using 'acquire', and are guaranteed to run +-- just before the computation terminates (after the finalisation handler). +-- * The finalisation handlers are run only when verification succeeds, and can +-- be registered with 'ifVerified'. Finalisation can be used for instance to +-- update the local cache (which should only happen if verification is +-- successful). +newtype Verify a = Verify { + unVerify :: ReaderT (IORef Cleanup, IORef Finaliser) IO a + } + deriving (Functor, Applicative, Monad, MonadIO) + +-- | Run an action in the 'Verify' monad +runVerify :: (Finaliser -> Finaliser) -> Verify a -> IO a +runVerify modifyFinaliser v = do + rCleanup <- newIORef $ return () + rFinaliser <- newIORef $ return () + mask $ \restore -> do + ma <- try $ restore $ runReaderT (unVerify v) (rCleanup, rFinaliser) + case ma of + Left ex -> do join $ readIORef rCleanup + throwIO (ex :: SomeException) + Right a -> do modifyFinaliser $ join $ readIORef rFinaliser + join $ readIORef rCleanup + return a + +-- | Acquire a resource and register the corresponding cleanup handler +-- +-- NOTE: Resource acquisition happens with exceptions masked. If it is important +-- that the resource acquistion can be timed out (or receive other kinds of +-- asynchronous exceptions), you will need to use an interruptible operation. +-- See for +-- details. +acquire :: IO a -> (a -> IO ()) -> Verify a +acquire get release = Verify $ do + (rCleanup, _rFinaliser) <- ask + liftIO $ mask_ $ do + a <- liftIO get + modifyIORef rCleanup (>> release a) + return a + +-- | Register an action to be run only if verification succeeds +ifVerified :: IO () -> Verify () +ifVerified handler = Verify $ do + (_rCleanup, rFinaliser) <- ask + liftIO $ modifyIORef rFinaliser (>> handler) + +{------------------------------------------------------------------------------- + Specific resources +-------------------------------------------------------------------------------} + +-- | Create a short-lived temporary file +-- +-- Creates the directory where the temp file should live if it does not exist. +openTempFile :: FsRoot root + => Path root -- ^ Temp directory + -> String -- ^ Template + -> Verify (Path Absolute, Handle) +openTempFile tmpDir template = + acquire createTempFile closeAndDelete + where + createTempFile :: IO (Path Absolute, Handle) + createTempFile = do + createDirectoryIfMissing True tmpDir + openTempFile' tmpDir template + + closeAndDelete :: (Path Absolute, Handle) -> IO () + closeAndDelete (fp, h) = do + hClose h + void $ handleDoesNotExist $ removeFile fp diff --git a/src/Hackage/Security/JSON.hs b/src/Hackage/Security/JSON.hs --- a/src/Hackage/Security/JSON.hs +++ b/src/Hackage/Security/JSON.hs @@ -48,8 +48,7 @@ import Hackage.Security.Key import Hackage.Security.Key.Env (KeyEnv) -import Hackage.Security.TUF.Layout -import Hackage.Security.Util.IO +import Hackage.Security.TUF.Layout.Repo import Hackage.Security.Util.JSON import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty @@ -253,36 +252,36 @@ Left err -> Left (DeserializationErrorMalformed err) Right val -> runReadJSON_NoKeys_NoLayout (fromJSON val) -readJSON_Keys_Layout :: ( IsFileSystemRoot root +readJSON_Keys_Layout :: ( FsRoot root , FromJSON ReadJSON_Keys_Layout a ) => KeyEnv -> RepoLayout - -> Path (Rooted root) + -> Path root -> IO (Either DeserializationError a) readJSON_Keys_Layout keyEnv repoLayout fp = do - withFileInReadMode fp $ \h -> do + withFile fp ReadMode $ \h -> do bs <- BS.L.hGetContents h evaluate $ parseJSON_Keys_Layout keyEnv repoLayout bs -readJSON_Keys_NoLayout :: ( IsFileSystemRoot root +readJSON_Keys_NoLayout :: ( FsRoot root , FromJSON ReadJSON_Keys_NoLayout a ) => KeyEnv - -> Path (Rooted root) + -> Path root -> IO (Either DeserializationError a) readJSON_Keys_NoLayout keyEnv fp = do - withFileInReadMode fp $ \h -> do + withFile fp ReadMode $ \h -> do bs <- BS.L.hGetContents h evaluate $ parseJSON_Keys_NoLayout keyEnv bs -readJSON_NoKeys_NoLayout :: ( IsFileSystemRoot root +readJSON_NoKeys_NoLayout :: ( FsRoot root , FromJSON ReadJSON_NoKeys_NoLayout a ) - => Path (Rooted root) + => Path root -> IO (Either DeserializationError a) readJSON_NoKeys_NoLayout fp = do - withFileInReadMode fp $ \h -> do + withFile fp ReadMode $ \h -> do bs <- BS.L.hGetContents h evaluate $ parseJSON_NoKeys_NoLayout bs @@ -314,15 +313,11 @@ renderJSON_NoLayout :: ToJSON Identity a => a -> BS.L.ByteString renderJSON_NoLayout = renderCanonicalJSON . runIdentity . toJSON -writeJSON :: ToJSON WriteJSON a => RepoLayout -> AbsolutePath -> a -> IO () -writeJSON repoLayout fp a = - atomicWithFile fp $ \h -> - BS.L.hPut h $ renderJSON repoLayout a +writeJSON :: ToJSON WriteJSON a => RepoLayout -> Path Absolute -> a -> IO () +writeJSON repoLayout fp = writeLazyByteString fp . renderJSON repoLayout -writeJSON_NoLayout :: ToJSON Identity a => AbsolutePath -> a -> IO () -writeJSON_NoLayout fp a = - atomicWithFile fp $ \h -> - BS.L.hPut h $ renderJSON_NoLayout a +writeJSON_NoLayout :: ToJSON Identity a => Path Absolute -> a -> IO () +writeJSON_NoLayout fp = writeLazyByteString fp . renderJSON_NoLayout writeKeyAsId :: Some PublicKey -> JSValue writeKeyAsId = JSString . keyIdString . someKeyId diff --git a/src/Hackage/Security/Key.hs b/src/Hackage/Security/Key.hs --- a/src/Hackage/Security/Key.hs +++ b/src/Hackage/Security/Key.hs @@ -178,11 +178,23 @@ -- ed25519 sign :: PrivateKey typ -> BS.L.ByteString -> BS.ByteString sign (PrivateKeyEd25519 pri) = - Ed25519.unSignature . Ed25519.sign' pri . BS.concat . BS.L.toChunks + Ed25519.unSignature . dsign pri . BS.concat . BS.L.toChunks + where +#if MIN_VERSION_ed25519(0,0,4) + dsign = Ed25519.dsign +#else + dsign = Ed25519.sign' +#endif verify :: PublicKey typ -> BS.L.ByteString -> BS.ByteString -> Bool verify (PublicKeyEd25519 pub) inp sig = - Ed25519.verify' pub (BS.concat $ BS.L.toChunks inp) (Ed25519.Signature sig) + dverify pub (BS.concat $ BS.L.toChunks inp) (Ed25519.Signature sig) + where +#if MIN_VERSION_ed25519(0,0,4) + dverify = Ed25519.dverify +#else + dverify = Ed25519.verify' +#endif {------------------------------------------------------------------------------- JSON encoding and decoding diff --git a/src/Hackage/Security/TUF.hs b/src/Hackage/Security/TUF.hs --- a/src/Hackage/Security/TUF.hs +++ b/src/Hackage/Security/TUF.hs @@ -4,9 +4,12 @@ , module Hackage.Security.TUF.FileInfo , module Hackage.Security.TUF.FileMap , module Hackage.Security.TUF.Header - , module Hackage.Security.TUF.Layout + , module Hackage.Security.TUF.Layout.Cache + , module Hackage.Security.TUF.Layout.Index + , module Hackage.Security.TUF.Layout.Repo , module Hackage.Security.TUF.Mirrors - , module Hackage.Security.TUF.Patterns + , module Hackage.Security.TUF.Paths +-- , module Hackage.Security.TUF.Patterns , module Hackage.Security.TUF.Root , module Hackage.Security.TUF.Signed , module Hackage.Security.TUF.Snapshot @@ -17,9 +20,12 @@ import Hackage.Security.TUF.Common import Hackage.Security.TUF.FileInfo import Hackage.Security.TUF.Header -import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Layout.Cache +import Hackage.Security.TUF.Layout.Index +import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Mirrors -import Hackage.Security.TUF.Patterns +-- import Hackage.Security.TUF.Patterns +import Hackage.Security.TUF.Paths import Hackage.Security.TUF.Root import Hackage.Security.TUF.Signed import Hackage.Security.TUF.Snapshot diff --git a/src/Hackage/Security/TUF/Common.hs b/src/Hackage/Security/TUF/Common.hs --- a/src/Hackage/Security/TUF/Common.hs +++ b/src/Hackage/Security/TUF/Common.hs @@ -16,14 +16,14 @@ -- -- Having verified file length information means we can protect against -- endless data attacks and similar. -newtype FileLength = FileLength { fileLength :: Int } +newtype FileLength = FileLength { fileLength :: Int54 } deriving (Eq, Ord, Show) -- | Key threshold -- -- The key threshold is the minimum number of keys a document must be signed -- with. Key thresholds are specified in 'RoleSpec' or 'DelegationsSpec'. -newtype KeyThreshold = KeyThreshold Int +newtype KeyThreshold = KeyThreshold Int54 deriving (Eq, Ord, Show) -- | File hash diff --git a/src/Hackage/Security/TUF/FileInfo.hs b/src/Hackage/Security/TUF/FileInfo.hs --- a/src/Hackage/Security/TUF/FileInfo.hs +++ b/src/Hackage/Security/TUF/FileInfo.hs @@ -7,6 +7,9 @@ , fileInfo , computeFileInfo , knownFileInfoEqual + , fileInfoSHA256 + -- ** Re-exports + , Int54 ) where import Prelude hiding (lookup) @@ -60,7 +63,7 @@ } -- | Compute 'FileInfo' -computeFileInfo :: IsFileSystemRoot root => Path (Rooted root) -> IO FileInfo +computeFileInfo :: FsRoot root => Path root -> IO FileInfo computeFileInfo fp = fileInfo <$> readLazyByteString fp -- | Compare known file info @@ -71,6 +74,10 @@ knownFileInfoEqual :: FileInfo -> FileInfo -> Bool knownFileInfoEqual a b = (==) (fileInfoLength a, fileInfoHashes a) (fileInfoLength b, fileInfoHashes b) + +-- | Extract SHA256 hash from 'FileInfo' (if present) +fileInfoSHA256 :: FileInfo -> Maybe Hash +fileInfoSHA256 FileInfo{..} = Map.lookup HashFnSHA256 fileInfoHashes {------------------------------------------------------------------------------- JSON diff --git a/src/Hackage/Security/TUF/FileMap.hs b/src/Hackage/Security/TUF/FileMap.hs --- a/src/Hackage/Security/TUF/FileMap.hs +++ b/src/Hackage/Security/TUF/FileMap.hs @@ -27,7 +27,7 @@ import Hackage.Security.JSON import Hackage.Security.TUF.FileInfo -import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Paths import Hackage.Security.Util.Path import Hackage.Security.Util.Pretty @@ -127,8 +127,8 @@ instance ReportSchemaErrors m => FromObjectKey m TargetPath where fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) = - return . TargetPathRepo . rootPath Rooted . fromUnrootedFilePath $ path + return . TargetPathRepo . rootPath . fromUnrootedFilePath $ path fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) = - return . TargetPathIndex . rootPath Rooted . fromUnrootedFilePath $ path + return . TargetPathIndex . rootPath . fromUnrootedFilePath $ path fromObjectKey str = expected "target path" (Just str) diff --git a/src/Hackage/Security/TUF/Header.hs b/src/Hackage/Security/TUF/Header.hs --- a/src/Hackage/Security/TUF/Header.hs +++ b/src/Hackage/Security/TUF/Header.hs @@ -36,7 +36,7 @@ -- -- 'Show' and 'Read' instance are defined in terms of the underlying 'Int' -- (this is use for example by hackage during the backup process). -newtype FileVersion = FileVersion Int +newtype FileVersion = FileVersion Int54 deriving (Eq, Ord, Typeable) instance Show FileVersion where diff --git a/src/Hackage/Security/TUF/Layout.hs b/src/Hackage/Security/TUF/Layout.hs deleted file mode 100644 --- a/src/Hackage/Security/TUF/Layout.hs +++ /dev/null @@ -1,228 +0,0 @@ -module Hackage.Security.TUF.Layout ( - -- * Repository layout - RepoRoot - , RepoPath - , RepoLayout(..) - , hackageRepoLayout - , cabalLocalRepoLayout - , anchorRepoPathLocally - , anchorRepoPathRemotely - -- * Index tarball layout - , IndexRoot - , IndexPath - , IndexLayout(..) - , hackageIndexLayout - -- * Cache layout - , CacheRoot - , CachePath - , CacheLayout(..) - , cabalCacheLayout - , anchorCachePath - ) where - -import Distribution.Package -import Distribution.Text - -import Hackage.Security.Util.Path - -{------------------------------------------------------------------------------- - Repository layout --------------------------------------------------------------------------------} - --- | The root of the repository --- --- Repository roots can be anchored at a remote URL or a local directory. --- --- Note that even for remote repos 'RepoRoot' is (potentially) different from --- 'WebRoot' -- for a repository located at, say, @http://hackage.haskell.org@ --- they happen to coincide, but for one location at --- @http://example.com/some/subdirectory@ they do not. -data RepoRoot - --- | Paths relative to the root of the repository -type RepoPath = Path (Rooted RepoRoot) - -instance IsRoot RepoRoot where showRoot _ = "" - --- | Layout of a repository -data RepoLayout = RepoLayout { - -- | TUF root metadata - repoLayoutRoot :: RepoPath - - -- | TUF timestamp - , repoLayoutTimestamp :: RepoPath - - -- | TUF snapshot - , repoLayoutSnapshot :: RepoPath - - -- | TUF mirrors list - , repoLayoutMirrors :: RepoPath - - -- | Compressed index tarball - , repoLayoutIndexTarGz :: RepoPath - - -- | Uncompressed index tarball - , repoLayoutIndexTar :: RepoPath - - -- | Path to the package tarball - , repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath - - -- | Layout of the index - -- - -- Since the repository hosts the index, the layout of the index is - -- not independent of the layout of the repository. - , repoIndexLayout :: IndexLayout - } - --- | The layout used on Hackage -hackageRepoLayout :: RepoLayout -hackageRepoLayout = RepoLayout { - repoLayoutRoot = rp $ fragment' "root.json" - , repoLayoutTimestamp = rp $ fragment' "timestamp.json" - , repoLayoutSnapshot = rp $ fragment' "snapshot.json" - , repoLayoutMirrors = rp $ fragment' "mirrors.json" - , repoLayoutIndexTarGz = rp $ fragment' "01-index.tar.gz" - , repoLayoutIndexTar = rp $ fragment' "01-index.tar" - , repoLayoutPkgTarGz = \pkgId -> rp $ fragment' "package" pkgFile pkgId - , repoIndexLayout = hackageIndexLayout - } - where - pkgFile :: PackageIdentifier -> UnrootedPath - pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz" - - rp :: UnrootedPath -> RepoPath - rp = rootPath Rooted - --- | Layout used by cabal for ("legacy") local repos --- --- Obviously, such repos do not normally contain any of the TUF files, so their --- location is more or less arbitrary here. -cabalLocalRepoLayout :: RepoLayout -cabalLocalRepoLayout = hackageRepoLayout { - repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId pkgFile pkgId - } - where - pkgLoc :: PackageIdentifier -> UnrootedPath - pkgLoc pkgId = joinFragments [ - mkFragment $ display (packageName pkgId) - , mkFragment $ display (packageVersion pkgId) - ] - - pkgFile :: PackageIdentifier -> UnrootedPath - pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz" - - rp :: UnrootedPath -> RepoPath - rp = rootPath Rooted - -anchorRepoPathLocally :: IsFileSystemRoot root - => Path (Rooted root) -> RepoPath -> Path (Rooted root) -anchorRepoPathLocally localRoot repoPath = localRoot unrootPath' repoPath - -anchorRepoPathRemotely :: URIPath -> RepoPath -> URIPath -anchorRepoPathRemotely remoteRoot repoPath = remoteRoot unrootPath' repoPath - -{------------------------------------------------------------------------------- - Index layout --------------------------------------------------------------------------------} - --- | The root of the index tarball -data IndexRoot - --- | Paths relative to the root of the index tarball -type IndexPath = Path (Rooted RepoRoot) - -instance IsRoot IndexRoot where showRoot _ = "" - --- | Layout of the files within the index tarball -data IndexLayout = IndexLayout { - -- | TUF metadata for a package - indexLayoutPkgMetadata :: PackageIdentifier -> IndexPath - - -- | Package .cabal file - , indexLayoutPkgCabal :: PackageIdentifier -> IndexPath - } - --- | The layout of the index as maintained on Hackage -hackageIndexLayout :: IndexLayout -hackageIndexLayout = IndexLayout { - indexLayoutPkgMetadata = \pkgId -> rp $ pkgLoc pkgId pkgMetadata - , indexLayoutPkgCabal = \pkgId -> rp $ pkgLoc pkgId pkgCabal pkgId - } - where - pkgLoc :: PackageIdentifier -> UnrootedPath - pkgLoc pkgId = joinFragments [ - mkFragment $ display (packageName pkgId) - , mkFragment $ display (packageVersion pkgId) - ] - - pkgCabal :: PackageIdentifier -> UnrootedPath - pkgCabal pkgId = fragment' (display (packageName pkgId)) <.> "cabal" - - pkgMetadata :: UnrootedPath - pkgMetadata = fragment' "package" <.> "json" - - rp :: UnrootedPath -> IndexPath - rp = rootPath Rooted - -{------------------------------------------------------------------------------- - Cache layout --------------------------------------------------------------------------------} - --- | The cache directory -data CacheRoot -type CachePath = Path (Rooted CacheRoot) - -instance IsRoot CacheRoot where showRoot _ = "" - --- | Location of the various files we cache --- --- Although the generic TUF algorithms do not care how we organize the cache, --- we nonetheless specity this here because as long as there are tools which --- access files in the cache directly we need to define the cache layout. --- See also comments for 'defaultCacheLayout'. -data CacheLayout = CacheLayout { - -- | TUF root metadata - cacheLayoutRoot :: CachePath - - -- | TUF timestamp - , cacheLayoutTimestamp :: CachePath - - -- | TUF snapshot - , cacheLayoutSnapshot :: CachePath - - -- | TUF mirrors list - , cacheLayoutMirrors :: CachePath - - -- | Uncompressed index tarball - , cacheLayoutIndexTar :: CachePath - - -- | Index to the uncompressed index tarball - , cacheLayoutIndexIdx :: CachePath - - -- | Compressed index tarball (if cached) - , cacheLayoutIndexTarGz :: Maybe CachePath - } - --- | The cache layout cabal-install uses --- --- We cache the index as @/00-index.tar@; this is important because --- `cabal-install` expects to find it there (and does not currently go through --- the hackage-security library to get files from the index). -cabalCacheLayout :: CacheLayout -cabalCacheLayout = CacheLayout { - cacheLayoutRoot = rp $ fragment' "root.json" - , cacheLayoutTimestamp = rp $ fragment' "timestamp.json" - , cacheLayoutSnapshot = rp $ fragment' "snapshot.json" - , cacheLayoutMirrors = rp $ fragment' "mirrors.json" - , cacheLayoutIndexTar = rp $ fragment' "00-index.tar" - , cacheLayoutIndexIdx = rp $ fragment' "00-index.tar.idx" - , cacheLayoutIndexTarGz = Nothing - } - where - rp :: UnrootedPath -> CachePath - rp = rootPath Rooted - --- | Anchor a cache path to the location of the cache -anchorCachePath :: IsFileSystemRoot root - => Path (Rooted root) -> CachePath -> Path (Rooted root) -anchorCachePath cacheRoot cachePath = cacheRoot unrootPath' cachePath diff --git a/src/Hackage/Security/TUF/Layout/Cache.hs b/src/Hackage/Security/TUF/Layout/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Layout/Cache.hs @@ -0,0 +1,64 @@ +module Hackage.Security.TUF.Layout.Cache ( + -- * Cache layout + CacheLayout(..) + , cabalCacheLayout + ) where + +import Hackage.Security.TUF.Paths +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + Cache layout +-------------------------------------------------------------------------------} + +-- | Location of the various files we cache +-- +-- Although the generic TUF algorithms do not care how we organize the cache, +-- we nonetheless specity this here because as long as there are tools which +-- access files in the cache directly we need to define the cache layout. +-- See also comments for 'defaultCacheLayout'. +data CacheLayout = CacheLayout { + -- | TUF root metadata + cacheLayoutRoot :: CachePath + + -- | TUF timestamp + , cacheLayoutTimestamp :: CachePath + + -- | TUF snapshot + , cacheLayoutSnapshot :: CachePath + + -- | TUF mirrors list + , cacheLayoutMirrors :: CachePath + + -- | Uncompressed index tarball + , cacheLayoutIndexTar :: CachePath + + -- | Index to the uncompressed index tarball + , cacheLayoutIndexIdx :: CachePath + + -- | Compressed index tarball + -- + -- We cache both the compressed and the uncompressed tarballs, because + -- incremental updates happen through the compressed tarball, but reads + -- happen through the uncompressed one (with the help of the tarball index). + , cacheLayoutIndexTarGz :: CachePath + } + +-- | The cache layout cabal-install uses +-- +-- We cache the index as @/00-index.tar@; this is important because +-- `cabal-install` expects to find it there (and does not currently go through +-- the hackage-security library to get files from the index). +cabalCacheLayout :: CacheLayout +cabalCacheLayout = CacheLayout { + cacheLayoutRoot = rp $ fragment "root.json" + , cacheLayoutTimestamp = rp $ fragment "timestamp.json" + , cacheLayoutSnapshot = rp $ fragment "snapshot.json" + , cacheLayoutMirrors = rp $ fragment "mirrors.json" + , cacheLayoutIndexTar = rp $ fragment "00-index.tar" + , cacheLayoutIndexIdx = rp $ fragment "00-index.tar.idx" + , cacheLayoutIndexTarGz = rp $ fragment "00-index.tar.gz" + } + where + rp :: Path Unrooted -> CachePath + rp = rootPath diff --git a/src/Hackage/Security/TUF/Layout/Index.hs b/src/Hackage/Security/TUF/Layout/Index.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Layout/Index.hs @@ -0,0 +1,116 @@ +module Hackage.Security.TUF.Layout.Index ( + -- * Repository layout + IndexLayout(..) + , IndexFile(..) + , hackageIndexLayout + -- ** Utility + , indexLayoutPkgMetadata + , indexLayoutPkgCabal + , indexLayoutPkgPrefs + ) where + +import qualified System.FilePath as FP + +import Distribution.Package +import Distribution.Text + +import Hackage.Security.TUF.Paths +import Hackage.Security.TUF.Signed +import Hackage.Security.TUF.Targets +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty +import Hackage.Security.Util.Some + +{------------------------------------------------------------------------------- + Index layout +-------------------------------------------------------------------------------} + +-- | Layout of the files within the index tarball +data IndexLayout = IndexLayout { + -- | Translate an 'IndexFile' to a path + indexFileToPath :: forall dec. IndexFile dec -> IndexPath + + -- | Parse an 'FilePath' + , indexFileFromPath :: IndexPath -> Maybe (Some IndexFile) + } + +-- | Files that we might request from the index +-- +-- The type index tells us the type of the decoded file, if any. For files for +-- which the library does not support decoding this will be @()@. +-- NOTE: Clients should NOT rely on this type index being @()@, or they might +-- break if we add support for parsing additional file formats in the future. +-- +-- TODO: If we wanted to support legacy Hackage, we should also have a case for +-- the global preferred-versions file. But supporting legacy Hackage will +-- probably require more work anyway.. +data IndexFile :: * -> * where + -- | Package-specific metadata (@targets.json@) + IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets) + + -- | Cabal file for a package + IndexPkgCabal :: PackageIdentifier -> IndexFile () + + -- | Preferred versions a package + IndexPkgPrefs :: PackageName -> IndexFile () + +deriving instance Show (IndexFile dec) + +instance Pretty (IndexFile dec) where + pretty (IndexPkgMetadata pkgId) = "metadata for " ++ display pkgId + pretty (IndexPkgCabal pkgId) = ".cabal for " ++ display pkgId + pretty (IndexPkgPrefs pkgNm) = "preferred-versions for " ++ display pkgNm + +instance SomeShow IndexFile where someShow = DictShow +instance SomePretty IndexFile where somePretty = DictPretty + +-- | The layout of the index as maintained on Hackage +hackageIndexLayout :: IndexLayout +hackageIndexLayout = IndexLayout { + indexFileToPath = toPath + , indexFileFromPath = fromPath . toUnrootedFilePath . unrootPath + } + where + toPath :: IndexFile dec -> IndexPath + toPath (IndexPkgCabal pkgId) = fromFragments [ + display (packageName pkgId) + , display (packageVersion pkgId) + , display (packageName pkgId) ++ ".cabal" + ] + toPath (IndexPkgMetadata pkgId) = fromFragments [ + display (packageName pkgId) + , display (packageVersion pkgId) + , "package.json" + ] + toPath (IndexPkgPrefs pkgNm) = fromFragments [ + display pkgNm + , "preferred-versions" + ] + + fromFragments :: [String] -> IndexPath + fromFragments = rootPath . joinFragments + + fromPath :: FilePath -> Maybe (Some IndexFile) + fromPath fp = case FP.splitPath fp of + [pkg, version, file] -> do + pkgId <- simpleParse (init pkg ++ "-" ++ init version) + case FP.takeExtension file of + ".cabal" -> return $ Some $ IndexPkgCabal pkgId + ".json" -> return $ Some $ IndexPkgMetadata pkgId + _otherwise -> Nothing + [pkg, "preferred-versions"] -> + Some . IndexPkgPrefs <$> simpleParse (init pkg) + _otherwise -> Nothing + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +indexLayoutPkgMetadata :: IndexLayout -> PackageIdentifier -> IndexPath +indexLayoutPkgMetadata IndexLayout{..} = indexFileToPath . IndexPkgMetadata + +indexLayoutPkgCabal :: IndexLayout -> PackageIdentifier -> IndexPath +indexLayoutPkgCabal IndexLayout{..} = indexFileToPath . IndexPkgCabal + +indexLayoutPkgPrefs :: IndexLayout -> PackageName -> IndexPath +indexLayoutPkgPrefs IndexLayout{..} = indexFileToPath . IndexPkgPrefs diff --git a/src/Hackage/Security/TUF/Layout/Repo.hs b/src/Hackage/Security/TUF/Layout/Repo.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Layout/Repo.hs @@ -0,0 +1,79 @@ +module Hackage.Security.TUF.Layout.Repo ( + -- * Repository layout + RepoLayout(..) + , hackageRepoLayout + , cabalLocalRepoLayout + ) where + +import Distribution.Package +import Distribution.Text + +import Hackage.Security.TUF.Paths +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + Repository layout +-------------------------------------------------------------------------------} + +-- | Layout of a repository +data RepoLayout = RepoLayout { + -- | TUF root metadata + repoLayoutRoot :: RepoPath + + -- | TUF timestamp + , repoLayoutTimestamp :: RepoPath + + -- | TUF snapshot + , repoLayoutSnapshot :: RepoPath + + -- | TUF mirrors list + , repoLayoutMirrors :: RepoPath + + -- | Compressed index tarball + , repoLayoutIndexTarGz :: RepoPath + + -- | Uncompressed index tarball + , repoLayoutIndexTar :: RepoPath + + -- | Path to the package tarball + , repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath + } + +-- | The layout used on Hackage +hackageRepoLayout :: RepoLayout +hackageRepoLayout = RepoLayout { + repoLayoutRoot = rp $ fragment "root.json" + , repoLayoutTimestamp = rp $ fragment "timestamp.json" + , repoLayoutSnapshot = rp $ fragment "snapshot.json" + , repoLayoutMirrors = rp $ fragment "mirrors.json" + , repoLayoutIndexTarGz = rp $ fragment "01-index.tar.gz" + , repoLayoutIndexTar = rp $ fragment "01-index.tar" + , repoLayoutPkgTarGz = \pkgId -> rp $ fragment "package" pkgFile pkgId + } + where + pkgFile :: PackageIdentifier -> Path Unrooted + pkgFile pkgId = fragment (display pkgId) <.> "tar.gz" + + rp :: Path Unrooted -> RepoPath + rp = rootPath + +-- | Layout used by cabal for ("legacy") local repos +-- +-- Obviously, such repos do not normally contain any of the TUF files, so their +-- location is more or less arbitrary here. +cabalLocalRepoLayout :: RepoLayout +cabalLocalRepoLayout = hackageRepoLayout { + repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId pkgFile pkgId + } + where + pkgLoc :: PackageIdentifier -> Path Unrooted + pkgLoc pkgId = joinFragments [ + display (packageName pkgId) + , display (packageVersion pkgId) + ] + + pkgFile :: PackageIdentifier -> Path Unrooted + pkgFile pkgId = fragment (display pkgId) <.> "tar.gz" + + rp :: Path Unrooted -> RepoPath + rp = rootPath diff --git a/src/Hackage/Security/TUF/Paths.hs b/src/Hackage/Security/TUF/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Paths.hs @@ -0,0 +1,72 @@ +-- | Paths used in the TUF data structures +module Hackage.Security.TUF.Paths ( + -- * Repository + RepoRoot + , RepoPath + , anchorRepoPathLocally + , anchorRepoPathRemotely + -- * Index + , IndexRoot + , IndexPath + -- * Cache + , CacheRoot + , CachePath + , anchorCachePath + ) where + +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty + +{------------------------------------------------------------------------------- + Repo +-------------------------------------------------------------------------------} + +-- | The root of the repository +-- +-- Repository roots can be anchored at a remote URL or a local directory. +-- +-- Note that even for remote repos 'RepoRoot' is (potentially) different from +-- 'Web' -- for a repository located at, say, @http://hackage.haskell.org@ +-- they happen to coincide, but for one location at +-- @http://example.com/some/subdirectory@ they do not. +data RepoRoot + +-- | Paths relative to the root of the repository +type RepoPath = Path RepoRoot + +instance Pretty (Path RepoRoot) where + pretty (Path fp) = "/" ++ fp + +anchorRepoPathLocally :: FsRoot root => Path root -> RepoPath -> Path root +anchorRepoPathLocally localRoot repoPath = localRoot unrootPath repoPath + +anchorRepoPathRemotely :: Path Web -> RepoPath -> Path Web +anchorRepoPathRemotely remoteRoot repoPath = remoteRoot unrootPath repoPath + +{------------------------------------------------------------------------------- + Index +-------------------------------------------------------------------------------} + +-- | The root of the index tarball +data IndexRoot + +-- | Paths relative to the root of the index tarball +type IndexPath = Path IndexRoot + +instance Pretty (Path IndexRoot) where + pretty (Path fp) = "/" ++ fp + +{------------------------------------------------------------------------------- + Cache +-------------------------------------------------------------------------------} + +-- | The cache directory +data CacheRoot +type CachePath = Path CacheRoot + +instance Pretty (Path CacheRoot) where + pretty (Path fp) = "/" ++ fp + +-- | Anchor a cache path to the location of the cache +anchorCachePath :: FsRoot root => Path root -> CachePath -> Path root +anchorCachePath cacheRoot cachePath = cacheRoot unrootPath cachePath diff --git a/src/Hackage/Security/TUF/Patterns.hs b/src/Hackage/Security/TUF/Patterns.hs --- a/src/Hackage/Security/TUF/Patterns.hs +++ b/src/Hackage/Security/TUF/Patterns.hs @@ -1,4 +1,7 @@ -- | Patterns and replacements +-- +-- NOTE: This module was developed to prepare for proper delegation (#39). +-- It is currently unusued. {-# LANGUAGE TemplateHaskell #-} module Hackage.Security.TUF.Patterns ( -- * Patterns and replacements diff --git a/src/Hackage/Security/TUF/Signed.hs b/src/Hackage/Security/TUF/Signed.hs --- a/src/Hackage/Security/TUF/Signed.hs +++ b/src/Hackage/Security/TUF/Signed.hs @@ -35,7 +35,7 @@ import Hackage.Security.JSON import Hackage.Security.Key -import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Layout.Repo import Hackage.Security.Util.Some import Text.JSON.Canonical import qualified Hackage.Security.Util.Base64 as B64 diff --git a/src/Hackage/Security/TUF/Snapshot.hs b/src/Hackage/Security/TUF/Snapshot.hs --- a/src/Hackage/Security/TUF/Snapshot.hs +++ b/src/Hackage/Security/TUF/Snapshot.hs @@ -10,7 +10,7 @@ import Hackage.Security.TUF.Header import Hackage.Security.TUF.FileInfo import Hackage.Security.TUF.FileMap -import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap diff --git a/src/Hackage/Security/TUF/Timestamp.hs b/src/Hackage/Security/TUF/Timestamp.hs --- a/src/Hackage/Security/TUF/Timestamp.hs +++ b/src/Hackage/Security/TUF/Timestamp.hs @@ -10,7 +10,7 @@ import Hackage.Security.TUF.FileInfo import Hackage.Security.TUF.FileMap import Hackage.Security.TUF.Header -import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Layout.Repo import Hackage.Security.TUF.Signed import qualified Hackage.Security.TUF.FileMap as FileMap diff --git a/src/Hackage/Security/Trusted.hs b/src/Hackage/Security/Trusted.hs --- a/src/Hackage/Security/Trusted.hs +++ b/src/Hackage/Security/Trusted.hs @@ -9,7 +9,6 @@ -- ** Role verification , VerifyRole(..) -- ** File info verification - , verifyFileInfo , trustedFileInfoEqual ) where @@ -17,8 +16,6 @@ import Data.Time import Hackage.Security.TUF import Hackage.Security.Trusted.TCB hiding (DeclareTrusted) -import Hackage.Security.Util.IO -import Hackage.Security.Util.Path {------------------------------------------------------------------------------- Combinators on trusted values @@ -56,43 +53,6 @@ File info verification -------------------------------------------------------------------------------} --- | Verify 'FileInfo' --- --- We compare file lengths before computing hashes, but once we have verified --- that the file lengths match we compute _all_ hashes, and then compare the --- resulting sets. This is the right thing to do: sure, in the case where the --- file info does _not_ match this is a waste of effort. However, we expect --- that in the majority of cases the file info _will_ match, in which case --- having to traverse the file multiple times to compute each hash, rather than --- traversing the file once and computing all hashes at once, is inefficient. --- --- (Of course, right now the difference is moot since we only use one hash.) -verifyFileInfo :: forall root. IsFileSystemRoot root - => Path (Rooted root) -> Trusted FileInfo -> IO Bool -verifyFileInfo fp trustedInfo = lazyAndM [ - verifyFileLength - , (knownFileInfoEqual info) <$> computeFileInfo fp - ] - where - verifyFileLength :: IO Bool - verifyFileLength = (== fileInfoLength) <$> getFileLength - - getFileLength :: IO FileLength - getFileLength = FileLength . fromInteger <$> getFileSize fp - - info@FileInfo{..} = trusted trustedInfo - -- | Variation on 'knownFileInfoEqual' for 'Trusted' 'FileInfo' trustedFileInfoEqual :: Trusted FileInfo -> Trusted FileInfo -> Bool trustedFileInfoEqual = knownFileInfoEqual `on` trusted - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -lazyAndM :: Monad m => [m Bool] -> m Bool -lazyAndM [] = return True -lazyAndM (m:ms) = do b <- m - case b of - False -> return False - True -> lazyAndM ms diff --git a/src/Hackage/Security/Trusted/TCB.hs b/src/Hackage/Security/Trusted/TCB.hs --- a/src/Hackage/Security/Trusted/TCB.hs +++ b/src/Hackage/Security/Trusted/TCB.hs @@ -6,7 +6,7 @@ , trustStatic , trustVerified , trustApply - , trustSeq + , trustElems -- * Verification errors , VerificationError(..) , RootUpdated(..) @@ -31,6 +31,7 @@ import Data.Typeable import Data.Time import Hackage.Security.TUF +import Hackage.Security.JSON import Hackage.Security.Key import Hackage.Security.Util.Pretty import qualified Hackage.Security.Util.Lens as Lens @@ -81,12 +82,79 @@ trustApply :: Trusted (a -> b) -> Trusted a -> Trusted b trustApply (DeclareTrusted f) (DeclareTrusted x) = DeclareTrusted (f x) --- | Equivalent of 'sequenceA' +-- | Trust all elements of some trusted (traversable) container -- --- Trusted isn't quite Traversable (no Functor instance), but it is --- somehow Traversable-like: we have the equivalent of 'sequenceA' -trustSeq :: Functor f => Trusted (f a) -> f (Trusted a) -trustSeq (DeclareTrusted fa) = DeclareTrusted `fmap` fa +-- If we have, say, a trusted list of values, we should be able to get a list +-- of trusted values out of it. +-- +-- > trustElems :: Trusted [a] -> [Trusted a] +-- +-- NOTE. It might appear that the more natural primitive to offer is a +-- 'sequenceA'-like operator such as +-- +-- > trustSeq :: Applicative f => Trusted (f a) -> f (Trusted a) +-- +-- However, this is unsound. To see this, consider that @((->) a)@ is +-- 'Applicative' (it's the reader monad); hence, we can instantiate 'trustSeq' +-- at +-- +-- > trustSeq :: Trusted (a -> a) -> a -> Trusted a +-- +-- and by passing @trustStatic (static id)@ make 'Trusted' a functor, which we +-- certainly don't want to do (see comments for 'Trusted'). +-- +-- So why is it okay when we insist on 'Traversable' rather than 'Applicative'? +-- To see this, it's instructive to consider how we might make a @((->) a)@ an +-- instance of 'Traversable'. If we define the domain of enumerable types as +-- +-- > class Eq a => Enumerable a where +-- > enumerate :: [a] +-- +-- then we can make @((->) r)@ traversable by +-- +-- > instance Enumerable r => Traversable ((->) r) where +-- > sequenceA f = rebuild <$> sequenceA ((\r -> (r,) <$> f r) <$> enumerate) +-- > where +-- > rebuild :: [(r, a)] -> r -> a +-- > rebuild fun arg = fromJust (lookup arg fun) +-- +-- The idea is that if the domain of a function is enumerable, we can apply the +-- function to each possible input, collect the outputs, and construct a new +-- function by pairing the inputs with the outputs. I.e., if we had something of +-- type +-- +-- > a -> IO b +-- +-- and @a@ is enumerable, we just run the @IO@ action on each possible @a@ and +-- collect all @b@s to get a pure function @a -> b@. Of course, you probably +-- don't want to be doing that, but the point is that as far as the type system +-- is concerned you could. +-- +-- In the context of 'Trusted', this means that we can derive +-- +-- > enumPure :: Enumerable a => a -> Trusted a +-- +-- but in a way this this makes sense anyway. If a domain is enumerable, it +-- would not be unreasonable to change @Enumerable@ to +-- +-- > class Eq a => Enumerable a where +-- > enumerate :: [StaticPtr a] +-- +-- so we could define @enumPure@ as +-- +-- > enumPure :: Enumerable a => a -> Trusted a +-- > enumPure x = trustStatic +-- > $ fromJust (find ((== x) . deRefStaticPtr) enumerate) +-- +-- In other words, we just enumerate the entire domain as trusted values +-- (because we defined them locally) and then return the one that matched the +-- untrusted value. +-- +-- The conclusion from all of this is that the types of untrusted input (like +-- the types of the TUF files we download from the server) should probably not +-- be considered enumerable. +trustElems :: Traversable f => Trusted (f a) -> f (Trusted a) +trustElems (DeclareTrusted fa) = DeclareTrusted `fmap` fa {------------------------------------------------------------------------------- Role verification @@ -112,10 +180,16 @@ -- but the information wasn't in the corresponding @targets.json@ file. | VerificationErrorUnknownTarget TargetPath - -- | The file we requested from the server was larger than expected - -- (potential endless data attack) - | VerificationErrorFileTooLarge TargetPath + -- | The metadata for the specified target is missing a SHA256 + | VerificationErrorMissingSHA256 TargetPath + -- | Some verification errors materialize as deserialization errors + -- + -- For example: if we try to deserialize a timestamp file but the timestamp + -- key has been rolled over, deserialization of the file will fail with + -- 'DeserializationErrorUnknownKey'. + | VerificationErrorDeserialization TargetPath DeserializationError + -- | The spec stipulates that if a verification error occurs during -- the check for updates, we must download new root information and -- start over. However, we limit how often we attempt this. @@ -153,8 +227,10 @@ "Invalid hash for " ++ pretty file pretty (VerificationErrorUnknownTarget file) = pretty file ++ " not found in corresponding target metadata" - pretty (VerificationErrorFileTooLarge file) = - pretty file ++ " too large" + pretty (VerificationErrorMissingSHA256 file) = + "Missing SHA256 hash for " ++ pretty file + pretty (VerificationErrorDeserialization file err) = + "Could not deserialize " ++ pretty file ++ ": " ++ pretty err pretty (VerificationErrorLoop es) = "Verification loop. Errors in order:\n" ++ unlines (map ((" " ++) . either pretty pretty) es) @@ -213,7 +289,7 @@ -- was invalid we would already have thrown an error constructing Signed. -- (Similarly, if two signatures were made by the same key, the FromJSON -- instance for Signatures would have thrown an error.) - unless (length (filter isRoleSpecKey sigs) >= threshold) $ + unless (length (filter isRoleSpecKey sigs) >= fromIntegral threshold) $ throwError $ VerificationErrorSignatures targetPath -- Everything is A-OK! @@ -236,7 +312,7 @@ (KeyThreshold threshold) targetPath Signed{signatures = Signatures sigs, ..} = - if length (filter isTrustedKey sigs) >= threshold + if length (filter isTrustedKey sigs) >= fromIntegral threshold then Right $ SignaturesVerified signed else Left $ VerificationErrorSignatures targetPath where diff --git a/src/Hackage/Security/Util/IO.hs b/src/Hackage/Security/Util/IO.hs --- a/src/Hackage/Security/Util/IO.hs +++ b/src/Hackage/Security/Util/IO.hs @@ -1,18 +1,16 @@ module Hackage.Security.Util.IO ( -- * Miscelleneous - withTempFile - , getFileSize + getFileSize , handleDoesNotExist - -- * Atomic file operations - , atomicCopyFile - , atomicWriteFile - , atomicWithFile + , withDirLock + -- * Debugging + , timedIO ) where import Control.Exception -import Control.Monad +import Data.Time +import System.IO hiding (openTempFile, withFile) import System.IO.Error -import qualified Data.ByteString.Lazy as BS.L import Hackage.Security.Util.Path @@ -20,25 +18,8 @@ Miscelleneous -------------------------------------------------------------------------------} --- | Create a short-lived temporary file --- --- Creates the directory where the temp file should live if it does not exist. -withTempFile :: forall a root. IsFileSystemRoot root - => Path (Rooted root) -- ^ Temp directory - -> String -- ^ Template - -> (AbsolutePath -> Handle -> IO a) -- ^ Callback - -> IO a -withTempFile tmpDir template callback = do - createDirectoryIfMissing True tmpDir - bracket (openTempFile tmpDir template) closeAndDelete (uncurry callback) - where - closeAndDelete :: (AbsolutePath, Handle) -> IO () - closeAndDelete (fp, h) = do - hClose h - void $ handleDoesNotExist $ removeFile fp - -getFileSize :: IsFileSystemRoot root => Path (Rooted root) -> IO Integer -getFileSize fp = withFileInReadMode fp hFileSize +getFileSize :: (Num a, FsRoot root) => Path root -> IO a +getFileSize fp = fromInteger <$> withFile fp ReadMode hFileSize handleDoesNotExist :: IO a -> IO (Maybe a) handleDoesNotExist act = @@ -49,46 +30,32 @@ then return Nothing else throwIO e -{------------------------------------------------------------------------------- - Atomic file operations --------------------------------------------------------------------------------} - --- | Copy a file atomically +-- | Attempt to create a filesystem lock in the specified directory -- --- If both files live in the same directory, we call 'renameFile'. Otherwise --- we read the source file and call 'atomicWriteFile' (because only when the --- two files live in the same directory can be sure that the two locations are --- on the same physical device). -atomicCopyFile :: AbsolutePath -- ^ Source - -> AbsolutePath -- ^ Destination - -> IO () -atomicCopyFile src dst = do - if takeDirectory src == takeDirectory dst - then renameFile src dst - else atomicWriteFile dst =<< readLazyByteString src +-- Given a file @/path/to@, we do this by attempting to create the directory +-- @//path/to/hackage-security-lock@, and deleting the directory again +-- afterwards. Creating a directory that already exists will throw an exception +-- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way +-- to implement a lock file. +withDirLock :: Path Absolute -> IO a -> IO a +withDirLock dir = bracket_ takeLock releaseLock + where + lock :: Path Absolute + lock = dir fragment "hackage-security-lock" --- | Atomically write a bytestring --- --- We write to a temporary file in the destination folder and then rename. -atomicWriteFile :: AbsolutePath -- ^ Source - -> BS.L.ByteString -- ^ Destination - -> IO () -atomicWriteFile dst src = atomicWithFile dst $ \h -> BS.L.hPut h src + takeLock, releaseLock :: IO () + takeLock = createDirectory lock + releaseLock = removeDirectory lock --- | Like 'withFile .. WriteMode', but overwrite the destination atomically. --- --- We open a handle to a temporary file in the same directory as the final --- location, then call the callback, and only when there are no exceptions --- finally rename the temporary file to the final destination. -atomicWithFile :: AbsolutePath -- ^ Final destination - -> (Handle -> IO a) -- ^ Callback - -> IO a -atomicWithFile final callback = - withTempFile finalDir finalFileName $ \tempPath h -> do - a <- callback h - hClose h - renameFile tempPath final - return a - where - finalDir = takeDirectory final - finalFileName = unFragment (takeFileName final) +{------------------------------------------------------------------------------- + Debugging +-------------------------------------------------------------------------------} + +timedIO :: String -> IO a -> IO a +timedIO label act = do + before <- getCurrentTime + result <- act + after <- getCurrentTime + hPutStrLn stderr $ label ++ ": " ++ show (after `diffUTCTime` before) + hFlush stderr + return result diff --git a/src/Hackage/Security/Util/JSON.hs b/src/Hackage/Security/Util/JSON.hs --- a/src/Hackage/Security/Util/JSON.hs +++ b/src/Hackage/Security/Util/JSON.hs @@ -20,6 +20,7 @@ , mkObject -- * Re-exports , JSValue(..) + , Int54 ) where import Control.Monad (liftM) @@ -86,17 +87,11 @@ instance Monad m => FromObjectKey m String where fromObjectKey = return -instance Monad m => ToObjectKey m (Path Unrooted) where - toObjectKey = return . toUnrootedFilePath - -instance Monad m => FromObjectKey m (Path Unrooted) where - fromObjectKey = return . fromUnrootedFilePath - -instance Monad m => ToObjectKey m (Path (Rooted root)) where - toObjectKey = toObjectKey . unrootPath' +instance Monad m => ToObjectKey m (Path root) where + toObjectKey (Path fp) = return fp -instance Monad m => FromObjectKey m (Path (Rooted root)) where - fromObjectKey = liftM (rootPath Rooted) . fromObjectKey +instance Monad m => FromObjectKey m (Path root) where + fromObjectKey = liftM Path . fromObjectKey {------------------------------------------------------------------------------- ToJSON and FromJSON instances @@ -115,10 +110,10 @@ fromJSON (JSString str) = return str fromJSON val = expected' "string" val -instance Monad m => ToJSON m Int where +instance Monad m => ToJSON m Int54 where toJSON = return . JSNum -instance ReportSchemaErrors m => FromJSON m Int where +instance ReportSchemaErrors m => FromJSON m Int54 where fromJSON (JSNum i) = return i fromJSON val = expected' "int" val diff --git a/src/Hackage/Security/Util/Path.hs b/src/Hackage/Security/Util/Path.hs --- a/src/Hackage/Security/Util/Path.hs +++ b/src/Hackage/Security/Util/Path.hs @@ -8,89 +8,84 @@ -- Note that his module does not import any other modules from Hackage.Security; -- everywhere else we use Path instead of FilePath directly. module Hackage.Security.Util.Path ( - -- * Path fragments - Fragment -- opaque - , mkFragment - , unFragment -- * Paths - , Path + Path(..) + , castRoot + -- * FilePath-like operations on paths with arbitrary roots + , takeDirectory + , takeFileName + , (<.>) + , splitExtension + -- * Unrooted paths , Unrooted - , Rooted(..) - , UnrootedPath - , IsRoot(..) - -- ** Construcion and destruction - , fragment - , fragment' , () , rootPath , unrootPath - , unrootPath' - , castRoot - -- ** Unrooted paths - , joinFragments - , splitFragments , toUnrootedFilePath , fromUnrootedFilePath + , fragment + , joinFragments , isPathPrefixOf - -- ** FilePath-like operations - , takeDirectory - , takeFileName - , (<.>) - , splitExtension - -- * File-system paths - , IsFileSystemRoot + -- * File-system paths , Relative , Absolute , HomeDir - , AbsolutePath - , RelativePath - , FileSystemPath(..) - -- ** Conversions + , FsRoot(..) + , FsPath(..) + -- ** Conversions , toFilePath , fromFilePath , makeAbsolute - , toAbsoluteFilePath , fromAbsoluteFilePath - -- ** Wrappers around System.IO - , openTempFile - , withFileInReadMode - -- ** Wrappers around Data.ByteString.* + -- ** Wrappers around System.IO + , withFile + , openTempFile' + -- ** Wrappers around Data.ByteString , readLazyByteString , readStrictByteString - -- ** Wrappers around System.Directory + , writeLazyByteString + , writeStrictByteString + -- ** Wrappers around System.Directory + , copyFile + , createDirectory , createDirectoryIfMissing - , doesDirectoryExist + , removeDirectory , doesFileExist - , getCurrentDirectory + , doesDirectoryExist + , removeFile + , getTemporaryDirectory , getDirectoryContents , getRecursiveContents - , getTemporaryDirectory - , removeFile , renameFile - -- ** Wrappers around Codec.Archive.Tar.* - , TarballRoot - , TarballPath + , getCurrentDirectory + -- * Wrappers around Codec.Archive.Tar + , Tar , tarIndexLookup , tarAppend - -- * Paths in URIs - , WebRoot - , URIPath + -- * Wrappers around Network.URI + , Web + , toURIPath + , fromURIPath , uriPath , modifyUriPath -- * Re-exports - , IO.IOMode(..) - , IO.BufferMode(..) - , IO.Handle + , IOMode(..) + , BufferMode(..) + , Handle + , SeekMode(..) , IO.hSetBuffering , IO.hClose , IO.hFileSize + , IO.hSeek ) where import Control.Monad -import Data.Function (on) +import Data.List (isPrefixOf) +import System.IO (IOMode(..), BufferMode(..), Handle, SeekMode(..)) +import System.IO.Unsafe (unsafeInterleaveIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L -import qualified System.FilePath as FilePath hiding (splitPath) +import qualified System.FilePath as FP import qualified System.IO as IO import qualified System.Directory as Dir import qualified Codec.Archive.Tar as Tar @@ -100,251 +95,170 @@ import Hackage.Security.Util.Pretty {------------------------------------------------------------------------------- - Fragments --------------------------------------------------------------------------------} - --- | Path fragments --- --- Path fragments must be non-empty and not contain any path delimiters. -newtype Fragment = Fragment { unFragment :: String } - deriving (Show, Eq, Ord) - -instance Pretty Fragment where - pretty = unFragment - -mkFragment :: String -> Fragment -mkFragment str - | hasSep str = invalid "fragment contains path separators" - | null str = invalid "empty fragment" - | otherwise = Fragment str - where - invalid :: String -> a - invalid msg = error $ "mkFragment: " ++ show str ++ ": " ++ msg - - hasSep :: String -> Bool - hasSep = any FilePath.isPathSeparator - -{------------------------------------------------------------------------------- Paths -------------------------------------------------------------------------------} --- | Unrooted paths --- --- Unrooted paths need a root before they can be interpreted. -data Unrooted - --- | Rooted paths --- --- The 'a' parameter is a phantom argument; 'Rooted' is effectively a proxy. -data Rooted a = Rooted - deriving (Show) - -- | Paths -- --- A path consists of an optional root and a list of fragments. --- Alternatively, think of it as a list with two kinds of nil-constructors. -data Path a where - PathRoot :: Rooted root -> Path (Rooted root) - PathNil :: Path Unrooted - PathSnoc :: Path a -> Fragment -> Path a - -deriving instance Show (Path a) - -class IsRoot root where - showRoot :: Rooted root -> String - -type UnrootedPath = Path Unrooted - -instance Eq (Path a) where - (==) = (==) `on` (splitFragments . unrootPath') - -instance Ord (Path a) where - (<=) = (<=) `on` (splitFragments . unrootPath') +-- A 'Path' is simply a 'FilePath' with a type-level tag indicating where this +-- path is rooted (relative to the current directory, absolute path, relative to +-- a web domain, whatever). Most operations on 'Path' are just lifted versions +-- of the operations on the underlying 'FilePath'. The tag however allows us to +-- give a lot of operations a more meaningful type. For instance, it does not +-- make sense to append two absolute paths together; instead, we can only append +-- an unrooted path to another path. It also means we avoid bugs where we use +-- one kind of path where we expect another. +newtype Path a = Path { unPath :: FilePath } + deriving (Show, Eq, Ord) --- | Turn a path into a human-readable string -instance IsRoot root => Pretty (Path (Rooted root)) where - pretty path = showRoot root FilePath. toUnrootedFilePath unrooted - where - (root, unrooted) = unrootPath path +-- | Reinterpret the root of a path +-- +-- This literally just changes the type-level tag; use with caution! +castRoot :: Path root -> Path root' +castRoot (Path fp) = Path fp {------------------------------------------------------------------------------- - Constructing and destructing paths + FilePath-like operations on paths with an arbitrary root -------------------------------------------------------------------------------} -fragment :: Fragment -> UnrootedPath -fragment = PathSnoc PathNil +takeDirectory :: Path a -> Path a +takeDirectory = liftFP FP.takeDirectory --- | For convenience: combine `fragment` and `mkFragment` --- --- This can therefore throw the same runtime errors as `mkFragment`. -fragment' :: String -> UnrootedPath -fragment' = fragment . mkFragment +takeFileName :: Path a -> String +takeFileName = liftFromFP FP.takeFileName -() :: Path a -> UnrootedPath -> Path a -ps PathNil = ps -ps PathSnoc qs q = PathSnoc (ps qs) q +(<.>) :: Path a -> String -> Path a +fp <.> ext = liftFP (FP.<.> ext) fp -rootPath :: forall root. Rooted root -> UnrootedPath -> Path (Rooted root) -rootPath root = go +splitExtension :: Path a -> (Path a, String) +splitExtension (Path fp) = (Path fp', ext) where - go :: UnrootedPath -> Path (Rooted root) - go PathNil = PathRoot root - go (PathSnoc qs q) = PathSnoc (go qs) q - -unrootPath :: Path (Rooted root) -> (Rooted root, UnrootedPath) -unrootPath (PathRoot root) = (root, PathNil) -unrootPath (PathSnoc qs q) = let (root, unrooted) = unrootPath qs - in (root, PathSnoc unrooted q) - -unrootPath' :: Path a -> UnrootedPath -unrootPath' (PathRoot _) = PathNil -unrootPath' PathNil = PathNil -unrootPath' (PathSnoc qs q) = PathSnoc (unrootPath' qs) q - --- | Reinterpret the root of a path -castRoot :: Path (Rooted root) -> Path (Rooted root') -castRoot (PathRoot _) = PathRoot Rooted -castRoot (PathSnoc qs q) = PathSnoc (castRoot qs) q + (fp', ext) = FP.splitExtension fp {------------------------------------------------------------------------------- Unrooted paths -------------------------------------------------------------------------------} -joinFragments :: [Fragment] -> UnrootedPath -joinFragments = go PathNil - where - go :: UnrootedPath -> [Fragment] -> UnrootedPath - go acc [] = acc - go acc (p:ps) = go (PathSnoc acc p) ps +-- | Type-level tag for unrooted paths +-- +-- Unrooted paths need a root before they can be interpreted. +data Unrooted -splitFragments :: UnrootedPath -> [Fragment] -splitFragments = go [] - where - go :: [Fragment] -> UnrootedPath -> [Fragment] - go acc PathNil = acc - go acc (PathSnoc ps p) = go (p:acc) ps +instance Pretty (Path Unrooted) where + pretty (Path fp) = fp -toUnrootedFilePath :: UnrootedPath -> FilePath -toUnrootedFilePath = FilePath.joinPath . map unFragment . splitFragments +() :: Path a -> Path Unrooted -> Path a +() = liftFP2 (FP.) -fromUnrootedFilePath :: FilePath -> UnrootedPath -fromUnrootedFilePath = joinFragments . map mkFragment . splitPath +-- | Reinterpret an unrooted path +-- +-- This is an alias for 'castRoot'; see comments there. +rootPath :: Path Unrooted -> Path root +rootPath (Path fp) = Path fp -isPathPrefixOf :: UnrootedPath -> UnrootedPath -> Bool -isPathPrefixOf = go `on` splitFragments - where - go :: [Fragment] -> [Fragment] -> Bool - go [] _ = True - go _ [] = False - go (p:ps) (q:qs) = p == q && go ps qs +-- | Forget a path's root +-- +-- This is an alias for 'castRoot'; see comments there. +unrootPath :: Path root -> Path Unrooted +unrootPath (Path fp) = Path fp -{------------------------------------------------------------------------------- - FilePath-like operations --------------------------------------------------------------------------------} +toUnrootedFilePath :: Path Unrooted -> FilePath +toUnrootedFilePath = unPath -takeDirectory :: Path a -> Path a -takeDirectory (PathRoot root) = PathRoot root -takeDirectory PathNil = PathNil -takeDirectory (PathSnoc ps _) = ps +fromUnrootedFilePath :: FilePath -> Path Unrooted +fromUnrootedFilePath = Path -takeFileName :: Path a -> Fragment -takeFileName (PathRoot _) = error "takeFileName: empty path" -takeFileName PathNil = error "takeFileName: empty path" -takeFileName (PathSnoc _ p) = p +-- | A path fragment (like a single directory or filename) +fragment :: String -> Path Unrooted +fragment = fromUnrootedFilePath -(<.>) :: Path a -> String -> Path a -PathRoot _ <.> _ = error "(<.>): empty path" -PathNil <.> _ = error "(<.>): empty path" -PathSnoc ps p <.> ext = PathSnoc ps p' - where - p' = mkFragment $ unFragment p FilePath.<.> ext +joinFragments :: [String] -> Path Unrooted +joinFragments = liftToFP FP.joinPath -splitExtension :: Path a -> (Path a, String) -splitExtension (PathRoot _) = error "splitExtension: empty path" -splitExtension PathNil = error "splitExtension: empty path" -splitExtension (PathSnoc ps p) = - let (p', ext) = FilePath.splitExtension (unFragment p) - in (PathSnoc ps (mkFragment p'), ext) +isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool +isPathPrefixOf = liftFromFP2 isPrefixOf {------------------------------------------------------------------------------- File-system paths -------------------------------------------------------------------------------} --- | A file system root can be interpreted as an (absolute) FilePath -class IsRoot root => IsFileSystemRoot root where - interpretRoot :: Rooted root -> IO FilePath - data Relative data Absolute data HomeDir -type AbsolutePath = Path (Rooted Absolute) -type RelativePath = Path (Rooted Relative) +instance Pretty (Path Absolute) where + pretty (Path fp) = fp -instance IsRoot Relative where showRoot _ = "." -instance IsRoot Absolute where showRoot _ = "/" -instance IsRoot HomeDir where showRoot _ = "~" +instance Pretty (Path Relative) where + pretty (Path fp) = "./" ++ fp -instance IsFileSystemRoot Relative where - interpretRoot _ = Dir.getCurrentDirectory +instance Pretty (Path HomeDir) where + pretty (Path fp) = "~/" ++ fp -instance IsFileSystemRoot Absolute where - interpretRoot _ = return "/" +-- | A file system root can be interpreted as an (absolute) FilePath +class FsRoot root where + toAbsoluteFilePath :: Path root -> IO FilePath -instance IsFileSystemRoot HomeDir where - interpretRoot _ = Dir.getHomeDirectory +instance FsRoot Relative where + toAbsoluteFilePath (Path fp) = Dir.makeAbsolute fp +instance FsRoot Absolute where + toAbsoluteFilePath (Path fp) = return fp + +instance FsRoot HomeDir where + toAbsoluteFilePath (Path fp) = do + home <- Dir.getHomeDirectory + return $ home FP. fp + -- | Abstract over a file system root -- -- see 'fromFilePath' -data FileSystemPath where - FileSystemPath :: IsFileSystemRoot root => Path (Rooted root) -> FileSystemPath +data FsPath = forall root. FsRoot root => FsPath (Path root) {------------------------------------------------------------------------------- Conversions -------------------------------------------------------------------------------} -toFilePath :: AbsolutePath -> FilePath -toFilePath path = "/" FilePath. toUnrootedFilePath (unrootPath' path) - -fromFilePath :: FilePath -> FileSystemPath -fromFilePath ('/':path) = FileSystemPath $ - rootPath (Rooted :: Rooted Absolute) (fromUnrootedFilePath path) -fromFilePath ('~':'/':path) = FileSystemPath $ - rootPath (Rooted :: Rooted HomeDir) (fromUnrootedFilePath path) -fromFilePath path = FileSystemPath $ - rootPath (Rooted :: Rooted Relative) (fromUnrootedFilePath path) +toFilePath :: Path Absolute -> FilePath +toFilePath (Path fp) = fp -makeAbsolute :: FileSystemPath -> IO AbsolutePath -makeAbsolute (FileSystemPath path) = do - let (root, unrooted) = unrootPath path - rootFilePath <- fromUnrootedFilePath <$> interpretRoot root - return $ rootPath Rooted (rootFilePath unrooted) +fromFilePath :: FilePath -> FsPath +fromFilePath fp + | FP.isAbsolute fp = FsPath (Path fp :: Path Absolute) + | Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir) + | otherwise = FsPath (Path fp :: Path Relative) + where + -- TODO: I don't know if there a standard way that Windows users refer to + -- their home directory. For now, we'll only interpret '~'. Everybody else + -- can specify an absolute path if this doesn't work. + atHome :: FilePath -> Maybe FilePath + atHome "~" = Just "" + atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp' + atHome _otherwise = Nothing -toAbsoluteFilePath :: IsFileSystemRoot root => Path (Rooted root) -> IO FilePath -toAbsoluteFilePath = fmap toFilePath . makeAbsolute . FileSystemPath +makeAbsolute :: FsPath -> IO (Path Absolute) +makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p -fromAbsoluteFilePath :: FilePath -> AbsolutePath -fromAbsoluteFilePath ('/':path) = rootPath Rooted (fromUnrootedFilePath path) -fromAbsoluteFilePath _ = error "fromAbsoluteFilePath: not an absolute path" +fromAbsoluteFilePath :: FilePath -> Path Absolute +fromAbsoluteFilePath fp + | FP.isAbsolute fp = Path fp + | otherwise = error "fromAbsoluteFilePath: not an absolute path" {------------------------------------------------------------------------------- Wrappers around System.IO -------------------------------------------------------------------------------} --- | Open a file in read mode --- --- We don't wrap the general 'withFile' to encourage using atomic file ops. -withFileInReadMode :: IsFileSystemRoot root - => Path (Rooted root) -> (IO.Handle -> IO r) -> IO r -withFileInReadMode path callback = do +-- | Wrapper around 'withFile' +withFile :: FsRoot root => Path root -> IOMode -> (Handle -> IO r) -> IO r +withFile path mode callback = do filePath <- toAbsoluteFilePath path - IO.withFile filePath IO.ReadMode callback + IO.withFile filePath mode callback -- | Wrapper around 'openBinaryTempFileWithDefaultPermissions' -openTempFile :: forall root. IsFileSystemRoot root - => Path (Rooted root) -> String -> IO (AbsolutePath, IO.Handle) -openTempFile path template = do +-- +-- NOTE: The caller is responsible for cleaning up the temporary file. +openTempFile' :: FsRoot root => Path root -> String -> IO (Path Absolute, Handle) +openTempFile' path template = do filePath <- toAbsoluteFilePath path (tempFilePath, h) <- IO.openBinaryTempFileWithDefaultPermissions filePath template return (fromAbsoluteFilePath tempFilePath, h) @@ -353,57 +267,75 @@ Wrappers around Data.ByteString.* -------------------------------------------------------------------------------} -readLazyByteString :: IsFileSystemRoot root - => Path (Rooted root) -> IO BS.L.ByteString +readLazyByteString :: FsRoot root => Path root -> IO BS.L.ByteString readLazyByteString path = do filePath <- toAbsoluteFilePath path BS.L.readFile filePath -readStrictByteString :: IsFileSystemRoot root - => Path (Rooted root) -> IO BS.ByteString +readStrictByteString :: FsRoot root => Path root -> IO BS.ByteString readStrictByteString path = do filePath <- toAbsoluteFilePath path BS.readFile filePath +writeLazyByteString :: FsRoot root => Path root -> BS.L.ByteString -> IO () +writeLazyByteString path bs = do + filePath <- toAbsoluteFilePath path + BS.L.writeFile filePath bs + +writeStrictByteString :: FsRoot root => Path root -> BS.ByteString -> IO () +writeStrictByteString path bs = do + filePath <- toAbsoluteFilePath path + BS.writeFile filePath bs + {------------------------------------------------------------------------------- Wrappers around System.Directory -------------------------------------------------------------------------------} -createDirectoryIfMissing :: IsFileSystemRoot root - => Bool -> Path (Rooted root) -> IO () +copyFile :: (FsRoot root, FsRoot root') => Path root -> Path root' -> IO () +copyFile src dst = do + src' <- toAbsoluteFilePath src + dst' <- toAbsoluteFilePath dst + Dir.copyFile src' dst' + +createDirectory :: FsRoot root => Path root -> IO () +createDirectory path = Dir.createDirectory =<< toAbsoluteFilePath path + +createDirectoryIfMissing :: FsRoot root => Bool -> Path root -> IO () createDirectoryIfMissing createParents path = do filePath <- toAbsoluteFilePath path Dir.createDirectoryIfMissing createParents filePath -doesFileExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool +removeDirectory :: FsRoot root => Path root -> IO () +removeDirectory path = Dir.removeDirectory =<< toAbsoluteFilePath path + +doesFileExist :: FsRoot root => Path root -> IO Bool doesFileExist path = do filePath <- toAbsoluteFilePath path Dir.doesFileExist filePath -doesDirectoryExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool +doesDirectoryExist :: FsRoot root => Path root -> IO Bool doesDirectoryExist path = do filePath <- toAbsoluteFilePath path Dir.doesDirectoryExist filePath -removeFile :: IsFileSystemRoot root => Path (Rooted root) -> IO () +removeFile :: FsRoot root => Path root -> IO () removeFile path = do filePath <- toAbsoluteFilePath path Dir.removeFile filePath -getTemporaryDirectory :: IO AbsolutePath +getTemporaryDirectory :: IO (Path Absolute) getTemporaryDirectory = fromAbsoluteFilePath <$> Dir.getTemporaryDirectory -- | Return the immediate children of a directory -- -- Filters out @"."@ and @".."@. -getDirectoryContents :: IsFileSystemRoot root - => Path (Rooted root) -> IO [UnrootedPath] +getDirectoryContents :: FsRoot root => Path root -> IO [Path Unrooted] getDirectoryContents path = do filePath <- toAbsoluteFilePath path fragments <$> Dir.getDirectoryContents filePath where - fragments :: [String] -> [UnrootedPath] - fragments = map fragment' . filter (not . skip) + fragments :: [String] -> [Path Unrooted] + fragments = map fromUnrootedFilePath . filter (not . skip) skip :: String -> Bool skip "." = True @@ -412,15 +344,15 @@ -- | Recursive traverse a directory structure -- --- Returns a set of paths relative to the directory specified. --- TODO: Not sure about the memory behaviour with large file systems. -getRecursiveContents :: IsFileSystemRoot root - => Path (Rooted root) - -> IO [UnrootedPath] -getRecursiveContents root = go PathNil +-- Returns a set of paths relative to the directory specified. The list is +-- lazily constructed, so that directories are only read when required. +-- (This is also essential to ensure that this function does not build the +-- entire result in memory before returning, potentially running out of heap.) +getRecursiveContents :: FsRoot root => Path root -> IO [Path Unrooted] +getRecursiveContents root = go emptyPath where - go :: UnrootedPath -> IO [UnrootedPath] - go subdir = do + go :: Path Unrooted -> IO [Path Unrooted] + go subdir = unsafeInterleaveIO $ do entries <- getDirectoryContents (root subdir) liftM concat $ forM entries $ \entry -> do let path = subdir entry @@ -428,16 +360,19 @@ if isDirectory then go path else return [path] -renameFile :: (IsFileSystemRoot root, IsFileSystemRoot root1) - => Path (Rooted root) -- ^ Old - -> Path (Rooted root1) -- ^ New + emptyPath :: Path Unrooted + emptyPath = Path (FP.joinPath []) + +renameFile :: (FsRoot root, FsRoot root') + => Path root -- ^ Old + -> Path root' -- ^ New -> IO () renameFile old new = do old' <- toAbsoluteFilePath old new' <- toAbsoluteFilePath new Dir.renameFile old' new' -getCurrentDirectory :: IO AbsolutePath +getCurrentDirectory :: IO (Path Absolute) getCurrentDirectory = do cwd <- Dir.getCurrentDirectory makeAbsolute $ fromFilePath cwd @@ -446,21 +381,21 @@ Wrappers around Codec.Archive.Tar.* -------------------------------------------------------------------------------} -data TarballRoot -type TarballPath = Path (Rooted TarballRoot) +data Tar -instance Show (Rooted TarballRoot) where show _ = "" +instance Pretty (Path Tar) where + pretty (Path fp) = "/" ++ fp -tarIndexLookup :: TarIndex.TarIndex -> TarballPath -> Maybe TarIndex.TarIndexEntry +tarIndexLookup :: TarIndex.TarIndex -> Path Tar -> Maybe TarIndex.TarIndexEntry tarIndexLookup index path = TarIndex.lookup index path' where path' :: FilePath - path' = toUnrootedFilePath $ unrootPath' path + path' = toUnrootedFilePath $ unrootPath path -tarAppend :: (IsFileSystemRoot root, IsFileSystemRoot root') - => Path (Rooted root) -- ^ Path of the @.tar@ file - -> Path (Rooted root') -- ^ Base directory - -> [TarballPath] -- ^ Files to add, relative to the base dir +tarAppend :: (FsRoot root, FsRoot root') + => Path root -- ^ Path of the @.tar@ file + -> Path root' -- ^ Base directory + -> [Path Tar] -- ^ Files to add, relative to the base dir -> IO () tarAppend tarFile baseDir contents = do tarFile' <- toAbsoluteFilePath tarFile @@ -468,48 +403,44 @@ Tar.append tarFile' baseDir' contents' where contents' :: [FilePath] - contents' = map (toUnrootedFilePath . unrootPath') contents + contents' = map (toUnrootedFilePath . unrootPath) contents {------------------------------------------------------------------------------- Wrappers around Network.URI -------------------------------------------------------------------------------} -data WebRoot - -type URIPath = Path (Rooted WebRoot) +data Web -toURIPath :: FilePath -> URIPath -toURIPath = rootPath Rooted . fromUnrootedFilePath +toURIPath :: FilePath -> Path Web +toURIPath = rootPath . fromUnrootedFilePath -fromURIPath :: URIPath -> FilePath -fromURIPath = toUnrootedFilePath . unrootPath' +fromURIPath :: Path Web -> FilePath +fromURIPath = toUnrootedFilePath . unrootPath -uriPath :: URI.URI -> URIPath +uriPath :: URI.URI -> Path Web uriPath = toURIPath . URI.uriPath -modifyUriPath :: URI.URI -> (URIPath -> URIPath) -> URI.URI +modifyUriPath :: URI.URI -> (Path Web -> Path Web) -> URI.URI modifyUriPath uri f = uri { URI.uriPath = f' (URI.uriPath uri) } where f' :: FilePath -> FilePath f' = fromURIPath . f . toURIPath {------------------------------------------------------------------------------- - Auxiliary: operations on raw FilePaths + Auxiliary -------------------------------------------------------------------------------} --- | Split a path into its components --- --- Unlike 'FilePath.splitPath' this satisfies the invariants required by --- 'mkFragment'. That is, the fragments do NOT contain any path separators. --- --- Multiple consecutive path separators are considered to be the same as a --- single path separator, and leading and trailing separators are ignored. -splitPath :: FilePath -> [FilePath] -splitPath = go [] - where - go :: [FilePath] -> FilePath -> [FilePath] - go acc fp = case break FilePath.isPathSeparator fp of - ("", []) -> reverse acc - (fr, []) -> reverse (fr:acc) - ("", _:fp') -> go acc fp' - (fr, _:fp') -> go (fr:acc) fp' +liftFP :: (FilePath -> FilePath) -> Path a -> Path b +liftFP f (Path fp) = Path (f fp) + +liftFP2 :: (FilePath -> FilePath -> FilePath) -> Path a -> Path b -> Path c +liftFP2 f (Path fp) (Path fp') = Path (f fp fp') + +liftFromFP :: (FilePath -> x) -> Path a -> x +liftFromFP f (Path fp) = f fp + +liftFromFP2 :: (FilePath -> FilePath -> x) -> Path a -> Path b -> x +liftFromFP2 f (Path fp) (Path fp') = f fp fp' + +liftToFP :: (x -> FilePath) -> x -> Path a +liftToFP f x = Path (f x) diff --git a/src/Hackage/Security/Util/Some.hs b/src/Hackage/Security/Util/Some.hs --- a/src/Hackage/Security/Util/Some.hs +++ b/src/Hackage/Security/Util/Some.hs @@ -8,6 +8,9 @@ -- ** Serialization , DictShow(..) , SomeShow(..) + -- ** Pretty-printing + , DictPretty(..) + , SomePretty(..) -- ** Type checking , typecheckSome #if !MIN_VERSION_base(4,7,0) @@ -23,6 +26,7 @@ #endif import Hackage.Security.Util.TypedEmbedded +import Hackage.Security.Util.Pretty data Some f = forall a. Some (f a) @@ -71,6 +75,21 @@ instance SomeShow f => Show (Some f) where show (Some (x :: f a)) = case someShow :: DictShow (f a) of DictShow -> show x + +{------------------------------------------------------------------------------- + Pretty-printing Some types +-------------------------------------------------------------------------------} + +data DictPretty a where + DictPretty :: Pretty a => DictPretty a + +-- | Type @f@ satisfies @SomeShow f@ if @f a@ satisfies @Show@ independent of @a@ +class SomePretty f where + somePretty :: DictPretty (f a) + +instance SomePretty f => Pretty (Some f) where + pretty (Some (x :: f a)) = + case somePretty :: DictPretty (f a) of DictPretty -> pretty x {------------------------------------------------------------------------------- Typechecking Some types diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -9,7 +9,7 @@ , Monoid(..) , (<$>) , (<$) - , traverse + , Traversable(traverse) , displayException #endif ) where @@ -25,7 +25,7 @@ import Control.Applicative import Control.Exception (Exception) import Data.Monoid -import Data.Traversable (traverse) +import Data.Traversable (Traversable(traverse)) displayException :: Exception e => e -> String displayException = show diff --git a/src/Text/JSON/Canonical.hs b/src/Text/JSON/Canonical.hs --- a/src/Text/JSON/Canonical.hs +++ b/src/Text/JSON/Canonical.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Module : Text.JSON.Parsec @@ -17,9 +18,13 @@ -- This implementation is derived from the json parser from the json package, -- with simplifications to meet the Canonical JSON grammar. -- - +-- TODO: Known bugs/limitations: +-- +-- * Decoding/encoding Unicode code-points beyond @U+00ff@ is currently broken +-- module Text.JSON.Canonical ( JSValue(..) + , Int54 , parseCanonicalJSON , renderCanonicalJSON ) where @@ -28,23 +33,84 @@ ( CharParser, (<|>), (), many, between, sepBy , satisfy, char, string, digit, spaces , parse ) +import Control.Arrow (first) +import Data.Bits (Bits) +#if MIN_VERSION_base(4,7,0) +import Data.Bits (FiniteBits) +#endif import Data.Char (isDigit, digitToInt) -import Data.List (foldl', sortBy) +import Data.Data (Data) import Data.Function (on) +import Data.Int (Int64) +import Data.Ix (Ix) +import Data.List (foldl', sortBy) +import Data.Typeable (Typeable) +import Foreign.Storable (Storable) +import Text.Printf (PrintfArg) import qualified Data.ByteString.Lazy.Char8 as BS - data JSValue = JSNull | JSBool !Bool - | JSNum !Int + | JSNum !Int54 | JSString String | JSArray [JSValue] | JSObject [(String, JSValue)] deriving (Show, Read, Eq, Ord) +-- | 54-bit integer values +-- +-- JavaScript can only safely represent numbers between @-(2^53 - 1)@ and +-- @2^53 - 1@. +-- +-- TODO: Although we introduce the type here, we don't actually do any bounds +-- checking and just inherit all type class instance from Int64. We should +-- probably define `fromInteger` to do bounds checking, give different instances +-- for type classes such as `Bounded` and `FiniteBits`, etc. +newtype Int54 = Int54 { int54ToInt64 :: Int64 } + deriving ( Bounded + , Enum + , Eq + , Integral + , Data + , Num + , Ord + , Real + , Ix +#if MIN_VERSION_base(4,7,0) + , FiniteBits +#endif + , Bits + , Storable + , PrintfArg + , Typeable + ) + +instance Show Int54 where + show = show . int54ToInt64 + +instance Read Int54 where + readsPrec p = map (first Int54) . readsPrec p + ------------------------------------------------------------------------------ +-- | Encode as \"Canonical\" JSON. +-- +-- NB: Canonical JSON's string escaping rules deviate from RFC 7159 +-- JSON which requires +-- +-- "All Unicode characters may be placed within the quotation +-- marks, except for the characters that must be escaped: quotation +-- mark, reverse solidus, and the control characters (@U+0000@ +-- through @U+001F@)." +-- +-- Whereas the current specification of Canonical JSON explicitly +-- requires to violate this by only escaping the quotation mark and +-- the reverse solidus. This, however, contradicts Canonical JSON's +-- statement that "Canonical JSON is parsable with any full JSON +-- parser" +-- +-- Consequently, Canonical JSON is not a proper subset of RFC 7159. renderCanonicalJSON :: JSValue -> BS.ByteString renderCanonicalJSON v = BS.pack (s_value v []) @@ -181,16 +247,24 @@ digit digit digits -} -p_number :: CharParser () Int + +-- | Parse an int +-- +-- TODO: Currently this allows for a maximum of 15 digits (i.e. a maximum value +-- of @999,999,999,999,999@) as a crude approximation of the 'Int54' range. +p_number :: CharParser () Int54 p_number = tok ( (char '-' *> (negate <$> pnat)) <|> pnat <|> zero ) - where pnat = (\d ds -> strToInt (d:ds)) <$> digit19 <*> manyN 8 digit + where pnat = (\d ds -> strToInt (d:ds)) <$> digit19 <*> manyN 14 digit digit19 = satisfy (\c -> isDigit c && c /= '0') "digit" - strToInt = foldl' (\x d -> 10*x + digitToInt d) 0 + strToInt = foldl' (\x d -> 10*x + digitToInt54 d) 0 zero = 0 <$ char '0' + +digitToInt54 :: Char -> Int54 +digitToInt54 = fromIntegral . digitToInt manyN :: Int -> CharParser () a -> CharParser () [a] manyN 0 _ = pure [] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,434 @@ +module Main (main) where + +-- stdlib +import Control.Exception +import Control.Monad +import Data.Maybe (fromJust) +import Data.Time +import Network.URI (URI, parseURI) +import Test.Tasty +import Test.Tasty.HUnit +import System.IO.Temp (withSystemTempDirectory) + +-- hackage-security +import Hackage.Security.Client +import Hackage.Security.Client.Repository +import Hackage.Security.JSON (DeserializationError(..)) +import Hackage.Security.Util.Checked +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty +import qualified Hackage.Security.Client.Repository.Remote as Remote +import qualified Hackage.Security.Client.Repository.Cache as Cache + +-- TestSuite +import TestSuite.HttpMem +import TestSuite.InMemCache +import TestSuite.InMemRepo +import TestSuite.InMemRepository +import TestSuite.PrivateKeys +import TestSuite.Util.StrictMVar + +{------------------------------------------------------------------------------- + TestSuite driver +-------------------------------------------------------------------------------} + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "hackage-security" [ + testGroup "InMem" [ + testCase "testInMemInitialHasForUpdates" testInMemInitialHasUpdates + , testCase "testInMemNoUpdates" testInMemNoUpdates + , testCase "testInMemUpdatesAfterCron" testInMemUpdatesAfterCron + , testCase "testInMemKeyRollover" testInMemKeyRollover + , testCase "testInMemOutdatedTimestamp" testInMemOutdatedTimestamp + ] + , testGroup "HttpMem" [ + testCase "testHttpMemInitialHasForUpdates" testHttpMemInitialHasUpdates + , testCase "testHttpMemNoUpdates" testHttpMemNoUpdates + , testCase "testHttpMemUpdatesAfterCron" testHttpMemUpdatesAfterCron + , testCase "testHttpMemKeyRollover" testHttpMemKeyRollover + , testCase "testHttpMemOutdatedTimestamp" testHttpMemOutdatedTimestamp + ] + ] + +{------------------------------------------------------------------------------- + In-memory tests + + These tests test the core TUF infrastructure, but any specific Repository + implementation; instead, they use one specifically designed for testing + (almost a Repository mock-up). +-------------------------------------------------------------------------------} + +-- | Initial check for updates: empty cache +testInMemInitialHasUpdates :: Assertion +testInMemInitialHasUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs [] $ + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Check that if we run updates again, with no changes on the server, +-- we get NoUpdates +testInMemNoUpdates :: Assertion +testInMemNoUpdates = inMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs [] $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs [] $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test that we have updates reported after the timestamp is resigned +testInMemUpdatesAfterCron :: Assertion +testInMemUpdatesAfterCron = inMemTest $ \inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs [] $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs [] $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + inMemRepoCron inMemRepo =<< getCurrentTime + + withAssertLog "C" logMsgs [] $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "D" logMsgs [] $ do + assertEqual "D.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test what happens when the timestamp/snapshot keys rollover +testInMemKeyRollover :: Assertion +testInMemKeyRollover = inMemTest $ \inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs [] $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs [] $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + inMemRepoKeyRollover inMemRepo =<< getCurrentTime + + let msgs = [verificationError $ unknownKeyError timestampPath] + withAssertLog "C" logMsgs msgs $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "D" logMsgs [] $ do + assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test what happens when server has an outdated timestamp +-- (after a successful initial update) +testInMemOutdatedTimestamp :: Assertion +testInMemOutdatedTimestamp = inMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs [] $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs [] $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + now <- getCurrentTime + let (FileExpires fourDaysLater) = expiresInDays now 4 + + let msgs = replicate 5 (inHistory (Right (expired timestampPath))) + catchVerificationLoop msgs $ do + withAssertLog "C" logMsgs [] $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater + +{------------------------------------------------------------------------------- + Same tests, but going through the "real" Remote repository and Cache, though + still using an in-memory repository (with a HttpLib bridge) + + These are almost hte same as the in-memory tests, but the log messages we + expect are slightly different because the Remote repository indicates what + is is downloading, and why. +-------------------------------------------------------------------------------} + +-- | Initial check for updates: empty cache +testHttpMemInitialHasUpdates :: Assertion +testHttpMemInitialHasUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs msgsInitialUpdate $ + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Check that if we run updates again, with no changes on the server, +-- we get NoUpdates +testHttpMemNoUpdates :: Assertion +testHttpMemNoUpdates = httpMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs msgsInitialUpdate $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs msgsNoUpdates $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test that we have updates reported after the timestamp is resigned +testHttpMemUpdatesAfterCron :: Assertion +testHttpMemUpdatesAfterCron = httpMemTest $ \inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs msgsInitialUpdate $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs msgsNoUpdates $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + inMemRepoCron inMemRepo =<< getCurrentTime + + withAssertLog "C" logMsgs msgsResigned $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "D" logMsgs msgsNoUpdates $ do + assertEqual "D.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test what happens when the timestamp/snapshot keys rollover +testHttpMemKeyRollover :: Assertion +testHttpMemKeyRollover = httpMemTest $ \inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs msgsInitialUpdate $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs msgsNoUpdates $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + inMemRepoKeyRollover inMemRepo =<< getCurrentTime + + withAssertLog "C" logMsgs msgsKeyRollover $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "D" logMsgs msgsNoUpdates $ do + assertEqual "D.1" NoUpdates =<< checkForUpdates repo =<< checkExpiry + +-- | Test what happens when server has an outdated timestamp +-- (after a successful initial update) +testHttpMemOutdatedTimestamp :: Assertion +testHttpMemOutdatedTimestamp = httpMemTest $ \_inMemRepo logMsgs repo -> do + withAssertLog "A" logMsgs msgsInitialUpdate $ do + assertEqual "A.1" HasUpdates =<< checkForUpdates repo =<< checkExpiry + withAssertLog "B" logMsgs msgsNoUpdates $ do + assertEqual "B.2" NoUpdates =<< checkForUpdates repo =<< checkExpiry + + now <- getCurrentTime + let (FileExpires fourDaysLater) = expiresInDays now 4 + + let msgs = replicate 5 (inHistory (Right (expired timestampPath))) + catchVerificationLoop msgs $ do + withAssertLog "C" logMsgs [] $ do + assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater + +{------------------------------------------------------------------------------- + Log messages we expect when using the Remote repository +-------------------------------------------------------------------------------} + +-- | The log messages we expect on the initial check for updates +msgsInitialUpdate :: [LogMessage -> Bool] +msgsInitialUpdate = [ + selectedMirror inMemURI + , downloading isTimestamp + , downloading isSnapshot + , downloading isMirrors + , noLocalCopy + , downloading isIndex + ] + +-- | Log messages when we do a check for updates and there are no changes +msgsNoUpdates :: [LogMessage -> Bool] +msgsNoUpdates = [ + selectedMirror inMemURI + , downloading isTimestamp + ] + +-- | Log messages we expect when the timestamp and snapshot have been resigned +msgsResigned :: [LogMessage -> Bool] +msgsResigned = [ + selectedMirror inMemURI + , downloading isTimestamp + , downloading isSnapshot + ] + +-- | Log messages we expect when the timestamp key has been rolled over +msgsKeyRollover :: [LogMessage -> Bool] +msgsKeyRollover = [ + selectedMirror inMemURI + , downloading isTimestamp + , verificationError $ unknownKeyError timestampPath + , downloading isRoot + , downloading isTimestamp + , downloading isSnapshot + -- Since we delete the timestamp and snapshot on a root info change, + -- we will then conclude that we need to update the mirrors and the index. + , downloading isMirrors + , updating isIndex + ] + +{------------------------------------------------------------------------------- + Classifying log messages +-------------------------------------------------------------------------------} + +downloading :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool +downloading isFile (LogDownloading file) = isFile file +downloading _ _ = False + +noLocalCopy :: LogMessage -> Bool +noLocalCopy (LogCannotUpdate (RemoteIndex _ _) UpdateImpossibleNoLocalCopy) = True +noLocalCopy _ = False + +selectedMirror :: URI -> LogMessage -> Bool +selectedMirror mirror (LogSelectedMirror mirror') = mirror' == show mirror +selectedMirror _ _ = False + +updating :: (forall fs typ. RemoteFile fs typ -> Bool) -> LogMessage -> Bool +updating isFile (LogUpdating file) = isFile file +updating _ _ = False + +expired :: TargetPath -> VerificationError -> Bool +expired f (VerificationErrorExpired f') = f == f' +expired _ _ = False + +unknownKeyError :: TargetPath -> VerificationError -> Bool +unknownKeyError f (VerificationErrorDeserialization f' (DeserializationErrorUnknownKey _keyId)) = + f == f' +unknownKeyError _ _ = False + +verificationError :: (VerificationError -> Bool) -> LogMessage -> Bool +verificationError isErr (LogVerificationError err) = isErr err +verificationError _ _ = False + +inHistory :: Either RootUpdated (VerificationError -> Bool) -> HistoryMsg -> Bool +inHistory (Right isErr) (Right err) = isErr err +inHistory (Left _) (Left _) = True +inHistory _ _ = False + +type HistoryMsg = Either RootUpdated VerificationError + +catchVerificationLoop :: ([HistoryMsg -> Bool]) -> Assertion -> Assertion +catchVerificationLoop history = handleJust isLoop handler + where + isLoop :: VerificationError -> Maybe VerificationHistory + isLoop (VerificationErrorLoop history') = Just history' + isLoop _ = Nothing + + handler :: VerificationHistory -> Assertion + handler history' = + unless (length history == length history' && and (zipWith ($) history history')) $ + assertFailure $ "Unexpected verification history:" + ++ unlines (map pretty' history') + + pretty' :: HistoryMsg -> String + pretty' (Left RootUpdated) = "root updated" + pretty' (Right err) = pretty err + +{------------------------------------------------------------------------------- + Classifying files +-------------------------------------------------------------------------------} + +isRoot :: RemoteFile fs typ -> Bool +isRoot (RemoteRoot _) = True +isRoot _ = False + +isIndex :: RemoteFile fs typ -> Bool +isIndex (RemoteIndex _ _) = True +isIndex _ = False + +isMirrors :: RemoteFile fs typ -> Bool +isMirrors (RemoteMirrors _) = True +isMirrors _ = False + +isSnapshot :: RemoteFile fs typ -> Bool +isSnapshot (RemoteSnapshot _) = True +isSnapshot _ = False + +isTimestamp :: RemoteFile fs typ -> Bool +isTimestamp RemoteTimestamp = True +isTimestamp _ = False + +timestampPath :: TargetPath +timestampPath = TargetPathRepo $ repoLayoutTimestamp hackageRepoLayout + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Check the contents of the log +assertLog :: String -> [LogMessage -> Bool] -> [LogMessage] -> Assertion +assertLog label expected actual = go expected actual + where + go :: [LogMessage -> Bool] -> [LogMessage] -> Assertion + go [] [] = return () + go [] as = unexpected as + go (_:_) [] = assertFailure $ label ++ ": expected log message" + go (e:es) (a:as) = if e a then go es as else unexpected [a] + + unexpected :: [LogMessage] -> Assertion + unexpected msgs = assertFailure $ label ++ ": " + ++ "unexpected log messages:\n" + ++ unlines (map pretty msgs) + ++ "\nfull set of log messages was:\n" + ++ unlines (map pretty actual) + +-- | Run the actions and check its log messages +withAssertLog :: String + -> MVar [LogMessage] + -> [LogMessage -> Bool] + -> Assertion -> Assertion +withAssertLog label mv expected action = do + oldMsgs <- modifyMVar mv $ \old -> return ([], old) + action + newMsgs <- modifyMVar mv $ \new -> return (oldMsgs, new) + assertLog label expected newMsgs + +-- | Unit test using the in-memory repository/cache +inMemTest :: ( ( Throws SomeRemoteError + , Throws VerificationError + ) => InMemRepo -> MVar [LogMessage] -> Repository InMemFile -> Assertion + ) + -> Assertion +inMemTest test = uncheckClientErrors $ do + now <- getCurrentTime + keys <- createPrivateKeys + let root = initRoot now layout keys + withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do + tempDir <- makeAbsolute $ fromFilePath tempDir' + inMemRepo <- newInMemRepo layout root now keys + inMemCache <- newInMemCache tempDir layout + logMsgs <- newMVar [] + + let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg] + repository <- newInMemRepository layout hackageIndexLayout inMemRepo inMemCache logger + + bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2) + test inMemRepo logMsgs repository + where + layout :: RepoLayout + layout = hackageRepoLayout + +-- | Unit test using the Remote repository but with the in-mem repo +httpMemTest :: ( ( Throws SomeRemoteError + , Throws VerificationError + ) => InMemRepo -> MVar [LogMessage] -> Repository Remote.RemoteTemp -> Assertion + ) + -> Assertion +httpMemTest test = uncheckClientErrors $ do + now <- getCurrentTime + keys <- createPrivateKeys + let root = initRoot now layout keys + withSystemTempDirectory "hackage-security-test" $ \tempDir' -> do + tempDir <- makeAbsolute $ fromFilePath tempDir' + inMemRepo <- newInMemRepo layout root now keys + logMsgs <- newMVar [] + + let logger msg = modifyMVar_ logMsgs $ \msgs -> return $ msgs ++ [msg] + httpLib = httpMem inMemRepo + cache = Cache.Cache { + cacheRoot = tempDir fragment "cache" + , cacheLayout = cabalCacheLayout + } + + Remote.withRepository httpLib + [inMemURI] + Remote.defaultRepoOpts + cache + hackageRepoLayout + hackageIndexLayout + logger + $ \repository -> do + withAssertLog "bootstrap" logMsgs bootstrapMsgs $ + bootstrap repository (map someKeyId (privateRoot keys)) (KeyThreshold 2) + test inMemRepo logMsgs repository + where + bootstrapMsgs :: [LogMessage -> Bool] + bootstrapMsgs = [ selectedMirror inMemURI + , downloading isRoot + ] + + layout :: RepoLayout + layout = hackageRepoLayout + +-- | Base URI for the in-memory repository +-- +-- This could really be anything at all +inMemURI :: URI +inMemURI = fromJust (parseURI "inmem://") + +-- | Return @Just@ the current time +checkExpiry :: IO (Maybe UTCTime) +checkExpiry = Just `fmap` getCurrentTime diff --git a/tests/TestSuite/InMemCache.hs b/tests/TestSuite/InMemCache.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite/InMemCache.hs @@ -0,0 +1,149 @@ +module TestSuite.InMemCache ( + InMemCache(..) + , newInMemCache + ) where + +-- base +import Control.Exception +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS.L + +-- hackage-security +import Hackage.Security.Client +import Hackage.Security.Client.Formats +import Hackage.Security.Client.Repository +import Hackage.Security.JSON +import Hackage.Security.Util.Path + +-- TestSuite +import TestSuite.Util.StrictMVar +import TestSuite.InMemRepo + +data InMemCache = InMemCache { + inMemCacheGet :: CachedFile -> IO (Maybe (Path Absolute)) + , inMemCacheGetRoot :: IO (Path Absolute) + , inMemCacheClear :: IO () + , inMemCachePut :: forall f typ. InMemFile typ -> Format f -> IsCached typ -> IO () + } + +newInMemCache :: Path Absolute -> RepoLayout -> IO InMemCache +newInMemCache tempDir layout = do + state <- newMVar $ initLocalState layout + return InMemCache { + inMemCacheGet = get state tempDir + , inMemCacheGetRoot = getRoot state tempDir + , inMemCacheClear = clear state + , inMemCachePut = put state + } + +{------------------------------------------------------------------------------- + "Local" state (the files we "cached") +-------------------------------------------------------------------------------} + +data LocalState = LocalState { + cacheRepoLayout :: !RepoLayout + , cachedRoot :: !(Maybe (Signed Root)) + , cachedMirrors :: !(Maybe (Signed Mirrors)) + , cachedTimestamp :: !(Maybe (Signed Timestamp)) + , cachedSnapshot :: !(Maybe (Signed Snapshot)) + + -- We cache only the uncompressed index + + -- (we can unambiguously construct the @.tar@ from the @.tar.gz@, + -- but not the other way around) + , cachedIndex :: Maybe BS.L.ByteString + } + +cachedRoot' :: LocalState -> Signed Root +cachedRoot' LocalState{..} = needRoot cachedRoot + +needRoot :: Maybe a -> a +needRoot Nothing = error "InMemCache: no root info (did you bootstrap?)" +needRoot (Just root) = root + +initLocalState :: RepoLayout -> LocalState +initLocalState layout = LocalState { + cacheRepoLayout = layout + , cachedRoot = Nothing + , cachedMirrors = Nothing + , cachedTimestamp = Nothing + , cachedSnapshot = Nothing + , cachedIndex = Nothing + } + +{------------------------------------------------------------------------------- + Individual methods +-------------------------------------------------------------------------------} + +-- | Get a cached file (if available) +get :: MVar LocalState -> Path Absolute -> CachedFile -> IO (Maybe (Path Absolute)) +get state cacheTempDir cachedFile = + case cachedFile of + CachedRoot -> serve "root.json" $ render cachedRoot + CachedMirrors -> serve "mirrors.json" $ render cachedMirrors + CachedTimestamp -> serve "timestamp.json" $ render cachedTimestamp + CachedSnapshot -> serve "snapshot.json" $ render cachedSnapshot + where + render :: forall b. ToJSON WriteJSON b + => (LocalState -> Maybe b) + -> (LocalState -> Maybe BS.L.ByteString) + render f st = renderJSON (cacheRepoLayout st) `fmap` (f st) + + serve :: String + -> (LocalState -> Maybe BS.L.ByteString) + -> IO (Maybe (Path Absolute)) + serve template f = + withMVar state $ \st -> + case f st of + Nothing -> return Nothing + Just bs -> do (tempFile, h) <- openTempFile' cacheTempDir template + BS.L.hPut h bs + hClose h + return $ Just tempFile + +-- | Get the cached root +getRoot :: MVar LocalState -> Path Absolute -> IO (Path Absolute) +getRoot state cacheTempDir = + needRoot `fmap` get state cacheTempDir CachedRoot + +-- | Clear all cached data +clear :: MVar LocalState -> IO () +clear state = modifyMVar_ state $ \st -> return st { + cachedMirrors = Nothing + , cachedTimestamp = Nothing + , cachedSnapshot = Nothing + , cachedIndex = Nothing + } + +-- | Cache a previously downloaded remote file +put :: MVar LocalState -> InMemFile typ -> Format f -> IsCached typ -> IO () +put state = put' state . inMemFileRender + +put' :: MVar LocalState -> BS.L.ByteString -> Format f -> IsCached typ -> IO () +put' state bs = go + where + go :: Format f -> IsCached typ -> IO () + go _ DontCache = return () + go FUn (CacheAs f) = go' f + go FGz (CacheAs _) = error "put: the impossible happened" + go FUn CacheIndex = modifyMVar_ state $ \st -> return st { + cachedIndex = Just bs + } + go FGz CacheIndex = modifyMVar_ state $ \st -> return st { + cachedIndex = Just (GZip.decompress bs) + } + + go' :: CachedFile -> IO () + go' CachedRoot = go'' $ \x st -> st { cachedRoot = Just x } + go' CachedTimestamp = go'' $ \x st -> st { cachedTimestamp = Just x } + go' CachedSnapshot = go'' $ \x st -> st { cachedSnapshot = Just x } + go' CachedMirrors = go'' $ \x st -> st { cachedMirrors = Just x } + + go'' :: forall a. FromJSON ReadJSON_Keys_Layout a + => (a -> LocalState -> LocalState) -> IO () + go'' f = do + modifyMVar_ state $ \st@LocalState{..} -> do + let keyEnv = rootKeys . signed . cachedRoot' $ st + case parseJSON_Keys_Layout keyEnv cacheRepoLayout bs of + Left err -> throwIO err + Right parsed -> return $ f parsed st diff --git a/tests/TestSuite/InMemRepo.hs b/tests/TestSuite/InMemRepo.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite/InMemRepo.hs @@ -0,0 +1,262 @@ +module TestSuite.InMemRepo ( + InMemRepo(..) + , newInMemRepo + , initRoot + , InMemFile(..) + , inMemFileRender + ) where + +-- stdlib +import Control.Exception +import Data.Time +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import qualified Data.ByteString.Lazy as BS.L + +-- Cabal +import Distribution.Text + +-- hackage-security +import Hackage.Security.Client +import Hackage.Security.Client.Formats +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Verify +import Hackage.Security.JSON +import Hackage.Security.Util.Path +import Hackage.Security.Util.Some + +-- TestSuite +import TestSuite.PrivateKeys +import TestSuite.Util.StrictMVar + +{------------------------------------------------------------------------------- + "Files" from the in-memory repository +-------------------------------------------------------------------------------} + +data InMemFile :: * -> * where + InMemMetadata :: ToJSON WriteJSON a => RepoLayout -> a -> InMemFile Metadata + InMemBinary :: BS.L.ByteString -> InMemFile Binary + +inMemFileRender :: InMemFile typ -> BS.L.ByteString +inMemFileRender (InMemMetadata layout file) = renderJSON layout file +inMemFileRender (InMemBinary bs) = bs + +instance DownloadedFile InMemFile where + downloadedRead file = + return $ inMemFileRender file + + downloadedVerify file info = + return $ knownFileInfoEqual (fileInfo (inMemFileRender file)) + (trusted info) + + downloadedCopyTo file dest = + writeLazyByteString dest (inMemFileRender file) + +{------------------------------------------------------------------------------- + In-memory repository +-------------------------------------------------------------------------------} + +data InMemRepo = InMemRepo { + -- | Get a file from the repository + inMemRepoGet :: forall fs typ. + RemoteFile fs typ + -> Verify (Some (HasFormat fs), InMemFile typ) + + -- | Get a file, based on a path (uses hackageRepoLayout) + , inMemRepoGetPath :: RepoPath -> IO (Some InMemFile) + + -- | Run the "cron job" on the server + -- + -- That is, resign the timestamp and the snapshot + , inMemRepoCron :: UTCTime -> IO () + + -- | Rollover the timestamp and snapshot keys + , inMemRepoKeyRollover :: UTCTime -> IO () + } + +newInMemRepo :: RepoLayout + -> Signed Root + -> UTCTime + -> PrivateKeys + -> IO InMemRepo +newInMemRepo layout root now keys = do + state <- newMVar $ initRemoteState now layout keys root + return InMemRepo { + inMemRepoGet = get state + , inMemRepoGetPath = getPath state + , inMemRepoCron = cron state + , inMemRepoKeyRollover = keyRollover state + } + +{------------------------------------------------------------------------------- + "Remote" state (as it is "on the server") +-------------------------------------------------------------------------------} + +data RemoteState = RemoteState { + remoteKeys :: !PrivateKeys + , remoteLayout :: !RepoLayout + , remoteRoot :: !(Signed Root) + , remoteTimestamp :: !(Signed Timestamp) + , remoteSnapshot :: !(Signed Snapshot) + , remoteMirrors :: !(Signed Mirrors) + , remoteTar :: !BS.L.ByteString + , remoteTarGz :: !BS.L.ByteString + } + +initRoot :: UTCTime -> RepoLayout -> PrivateKeys -> Signed Root +initRoot now layout keys = withSignatures layout (privateRoot keys) Root { + rootVersion = FileVersion 1 + , rootExpires = expiresInDays now (365 * 10) + , rootKeys = privateKeysEnv keys + , rootRoles = privateKeysRoles keys + } + +initRemoteState :: UTCTime + -> RepoLayout + -> PrivateKeys + -> Signed Root + -> RemoteState +initRemoteState now layout keys signedRoot = RemoteState { + remoteKeys = keys + , remoteLayout = layout + , remoteRoot = signedRoot + , remoteTimestamp = signedTimestamp + , remoteSnapshot = signedSnapshot + , remoteMirrors = signedMirrors + , remoteTar = initTar + , remoteTarGz = initTarGz + } + where + signedTimestamp = withSignatures layout [privateTimestamp keys] initTimestamp + signedSnapshot = withSignatures layout [privateSnapshot keys] initSnapshot + signedMirrors = withSignatures layout [privateMirrors keys] initMirrors + + initMirrors :: Mirrors + initMirrors = Mirrors { + mirrorsVersion = FileVersion 1 + , mirrorsExpires = expiresNever + , mirrorsMirrors = [] + } + + initSnapshot :: Snapshot + initSnapshot = Snapshot { + snapshotVersion = FileVersion 1 + , snapshotExpires = expiresInDays now 3 + , snapshotInfoRoot = fileInfo $ renderJSON layout signedRoot + , snapshotInfoMirrors = fileInfo $ renderJSON layout signedMirrors + , snapshotInfoTarGz = fileInfo $ initTarGz + , snapshotInfoTar = Just $ fileInfo initTar + } + + initTimestamp :: Timestamp + initTimestamp = Timestamp { + timestampVersion = FileVersion 1 + , timestampExpires = expiresInDays now 3 + , timestampInfoSnapshot = fileInfo $ renderJSON layout signedSnapshot + } + + initTar :: BS.L.ByteString + initTar = Tar.write [] + + initTarGz :: BS.L.ByteString + initTarGz = GZip.compress initTar + +{------------------------------------------------------------------------------- + InMemRepo methods +-------------------------------------------------------------------------------} + +-- | Get a file from the server +get :: MVar RemoteState -> RemoteFile fs typ -> Verify (Some (HasFormat fs), InMemFile typ) +get state remoteFile = do + RemoteState{..} <- liftIO $ readMVar state + case remoteFile of + RemoteTimestamp -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteTimestamp) + RemoteSnapshot _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteSnapshot) + RemoteMirrors _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteMirrors) + RemoteRoot _ -> return (Some (HFZ FUn), InMemMetadata remoteLayout remoteRoot) + RemoteIndex hasGz _ -> return (Some hasGz, InMemBinary remoteTarGz) + RemotePkgTarGz pkgId _ -> error $ "withRemote: RemotePkgTarGz " ++ display pkgId + +getPath :: MVar RemoteState -> RepoPath -> IO (Some InMemFile) +getPath state repoPath = do + RemoteState{..} <- readMVar state + case toUnrootedFilePath (unrootPath repoPath) of + "root.json" -> return $ Some (InMemMetadata remoteLayout remoteRoot) + "timestamp.json" -> return $ Some (InMemMetadata remoteLayout remoteTimestamp) + "snapshot.json" -> return $ Some (InMemMetadata remoteLayout remoteSnapshot) + "mirrors.json" -> return $ Some (InMemMetadata remoteLayout remoteMirrors) + "01-index.tar.gz" -> return $ Some (InMemBinary remoteTarGz) + "01-index.tar" -> return $ Some (InMemBinary remoteTar) + otherPath -> throwIO . userError $ "getPath: Unknown path " ++ otherPath + where + +cron :: MVar RemoteState -> UTCTime -> IO () +cron state now = modifyMVar_ state $ \st@RemoteState{..} -> do + let snapshot, snapshot' :: Snapshot + snapshot = signed remoteSnapshot + snapshot' = snapshot { + snapshotVersion = versionIncrement $ snapshotVersion snapshot + , snapshotExpires = expiresInDays now 3 + } + + timestamp, timestamp' :: Timestamp + timestamp = signed remoteTimestamp + timestamp' = Timestamp { + timestampVersion = versionIncrement $ timestampVersion timestamp + , timestampExpires = expiresInDays now 3 + , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot + } + + signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys] timestamp' + signedSnapshot = withSignatures remoteLayout [privateSnapshot remoteKeys] snapshot' + + return st { + remoteTimestamp = signedTimestamp + , remoteSnapshot = signedSnapshot + } + +keyRollover :: MVar RemoteState -> UTCTime -> IO () +keyRollover state now = modifyMVar_ state $ \st@RemoteState{..} -> do + newKeySnapshot <- createKey' KeyTypeEd25519 + newKeyTimestamp <- createKey' KeyTypeEd25519 + + let remoteKeys' :: PrivateKeys + remoteKeys' = remoteKeys { + privateSnapshot = newKeySnapshot + , privateTimestamp = newKeyTimestamp + } + + root, root' :: Root + root = signed remoteRoot + root' = Root { + rootVersion = versionIncrement $ rootVersion root + , rootExpires = expiresInDays now (365 * 10) + , rootKeys = privateKeysEnv remoteKeys' + , rootRoles = privateKeysRoles remoteKeys' + } + + snapshot, snapshot' :: Snapshot + snapshot = signed remoteSnapshot + snapshot' = snapshot { + snapshotVersion = versionIncrement $ snapshotVersion snapshot + , snapshotExpires = expiresInDays now 3 + , snapshotInfoRoot = fileInfo $ renderJSON remoteLayout signedRoot + } + + timestamp, timestamp' :: Timestamp + timestamp = signed remoteTimestamp + timestamp' = Timestamp { + timestampVersion = versionIncrement $ timestampVersion timestamp + , timestampExpires = expiresInDays now 3 + , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot + } + + signedRoot = withSignatures remoteLayout (privateRoot remoteKeys') root' + signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys'] timestamp' + signedSnapshot = withSignatures remoteLayout [privateSnapshot remoteKeys'] snapshot' + + return st { + remoteRoot = signedRoot + , remoteTimestamp = signedTimestamp + , remoteSnapshot = signedSnapshot + } diff --git a/tests/TestSuite/InMemRepository.hs b/tests/TestSuite/InMemRepository.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite/InMemRepository.hs @@ -0,0 +1,63 @@ +module TestSuite.InMemRepository ( + newInMemRepository + ) where + +-- stdlib +import Control.Concurrent + +-- hackage-security +import Hackage.Security.Client +import Hackage.Security.Client.Formats +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Verify +import Hackage.Security.Util.Checked +import Hackage.Security.Util.Some + +-- TestSuite +import TestSuite.InMemCache +import TestSuite.InMemRepo + +newInMemRepository :: RepoLayout + -> IndexLayout + -> InMemRepo + -> InMemCache + -> (LogMessage -> IO ()) + -> IO (Repository InMemFile) +newInMemRepository layout indexLayout repo cache logger = do + cacheLock <- newMVar () + return $ Repository { + repGetRemote = getRemote repo cache + , repGetCached = inMemCacheGet cache + , repGetCachedRoot = inMemCacheGetRoot cache + , repClearCache = inMemCacheClear cache + , repLockCache = withMVar cacheLock . const + , repWithIndex = error "newInMemRepository: repWithIndex TODO" + , repGetIndexIdx = error "newInMemRepository: repGetIndexIdx TODO" + , repWithMirror = withMirror + , repLog = logger + , repLayout = layout + , repIndexLayout = indexLayout + , repDescription = "In memory repository" + } + +{------------------------------------------------------------------------------- + Repository methods +-------------------------------------------------------------------------------} + +-- | Get a file from the server +getRemote :: forall fs typ. Throws SomeRemoteError + => InMemRepo + -> InMemCache + -> AttemptNr + -> RemoteFile fs typ + -> Verify (Some (HasFormat fs), InMemFile typ) +getRemote InMemRepo{..} InMemCache{..} _isRetry remoteFile = do + (Some format, inMemFile) <- inMemRepoGet remoteFile + ifVerified $ inMemCachePut inMemFile (hasFormatGet format) (mustCache remoteFile) + return (Some format, inMemFile) + +-- | Mirror selection +withMirror :: forall a. Maybe [Mirror] -> IO a -> IO a +withMirror Nothing callback = callback +withMirror (Just []) callback = callback +withMirror _ _ = error "Mirror selection not implemented" diff --git a/tests/TestSuite/PrivateKeys.hs b/tests/TestSuite/PrivateKeys.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite/PrivateKeys.hs @@ -0,0 +1,69 @@ +module TestSuite.PrivateKeys ( + PrivateKeys(..) + , createPrivateKeys + , privateKeysEnv + , privateKeysRoles + ) where + +-- stdlib +import Control.Monad + +-- hackage-security +import Hackage.Security.Client +import Hackage.Security.Key.Env (KeyEnv) +import Hackage.Security.Util.Some +import qualified Hackage.Security.Key.Env as KeyEnv + +{------------------------------------------------------------------------------- + All private keys +-------------------------------------------------------------------------------} + +data PrivateKeys = PrivateKeys { + privateRoot :: [Some Key] + , privateTarget :: [Some Key] + , privateSnapshot :: Some Key + , privateTimestamp :: Some Key + , privateMirrors :: Some Key + } + +createPrivateKeys :: IO PrivateKeys +createPrivateKeys = do + privateRoot <- replicateM 3 $ createKey' KeyTypeEd25519 + privateTarget <- replicateM 3 $ createKey' KeyTypeEd25519 + privateSnapshot <- createKey' KeyTypeEd25519 + privateTimestamp <- createKey' KeyTypeEd25519 + privateMirrors <- createKey' KeyTypeEd25519 + return PrivateKeys{..} + +privateKeysEnv :: PrivateKeys -> KeyEnv +privateKeysEnv PrivateKeys{..} = KeyEnv.fromKeys $ concat [ + privateRoot + , privateTarget + , [privateSnapshot] + , [privateTimestamp] + , [privateMirrors] + ] + +privateKeysRoles :: PrivateKeys -> RootRoles +privateKeysRoles PrivateKeys{..} = RootRoles { + rootRolesRoot = RoleSpec { + roleSpecKeys = map somePublicKey privateRoot + , roleSpecThreshold = KeyThreshold 2 + } + , rootRolesSnapshot = RoleSpec { + roleSpecKeys = [somePublicKey privateSnapshot] + , roleSpecThreshold = KeyThreshold 1 + } + , rootRolesTargets = RoleSpec { + roleSpecKeys = map somePublicKey privateTarget + , roleSpecThreshold = KeyThreshold 2 + } + , rootRolesTimestamp = RoleSpec { + roleSpecKeys = [somePublicKey privateTimestamp] + , roleSpecThreshold = KeyThreshold 1 + } + , rootRolesMirrors = RoleSpec { + roleSpecKeys = [somePublicKey privateMirrors] + , roleSpecThreshold = KeyThreshold 1 + } + } diff --git a/tests/TestSuite/Util/StrictMVar.hs b/tests/TestSuite/Util/StrictMVar.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite/Util/StrictMVar.hs @@ -0,0 +1,27 @@ +module TestSuite.Util.StrictMVar ( + MVar -- opaque + , newMVar + , CC.withMVar + , modifyMVar + , modifyMVar_ + , CC.readMVar + ) where + +import Control.Concurrent (MVar) +import Control.Exception +import qualified Control.Concurrent as CC + +newMVar :: a -> IO (MVar a) +newMVar x = CC.newMVar =<< evaluate x + +modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b +modifyMVar mv f = CC.modifyMVar mv $ \old -> do + (new, ret) <- f old + new' <- evaluate new + return (new', ret) + +modifyMVar_ :: MVar a -> (a -> IO a) -> IO () +modifyMVar_ mv f = modifyMVar mv (returnUnit . f) + where + returnUnit :: IO a -> IO (a, ()) + returnUnit = fmap $ \a -> (a, ())