hackage-security 0.3.0.0 → 0.5.0.0
raw patch · 39 files changed
+3163/−1400 lines, 39 filesdep +HUnitdep +hackage-securitydep +tastydep ~Cabaldep ~basedep ~bytestring
Dependencies added: HUnit, hackage-security, tasty, tasty-hunit, temporary
Dependency ranges changed: Cabal, base, bytestring, containers, directory, network-uri, tar, time, zlib
Files
- ChangeLog.md +32/−0
- hackage-security.cabal +65/−21
- src/Hackage/Security/Client.hs +525/−208
- src/Hackage/Security/Client/Repository.hs +106/−106
- src/Hackage/Security/Client/Repository/Cache.hs +109/−85
- src/Hackage/Security/Client/Repository/HttpLib.hs +22/−15
- src/Hackage/Security/Client/Repository/Local.hs +58/−22
- src/Hackage/Security/Client/Repository/Remote.hs +293/−245
- src/Hackage/Security/Client/Verify.hs +103/−0
- src/Hackage/Security/JSON.hs +14/−19
- src/Hackage/Security/Key.hs +14/−2
- src/Hackage/Security/TUF.hs +10/−4
- src/Hackage/Security/TUF/Common.hs +2/−2
- src/Hackage/Security/TUF/FileInfo.hs +8/−1
- src/Hackage/Security/TUF/FileMap.hs +3/−3
- src/Hackage/Security/TUF/Header.hs +1/−1
- src/Hackage/Security/TUF/Layout.hs +0/−228
- src/Hackage/Security/TUF/Layout/Cache.hs +64/−0
- src/Hackage/Security/TUF/Layout/Index.hs +116/−0
- src/Hackage/Security/TUF/Layout/Repo.hs +79/−0
- src/Hackage/Security/TUF/Paths.hs +72/−0
- src/Hackage/Security/TUF/Patterns.hs +3/−0
- src/Hackage/Security/TUF/Signed.hs +1/−1
- src/Hackage/Security/TUF/Snapshot.hs +1/−1
- src/Hackage/Security/TUF/Timestamp.hs +1/−1
- src/Hackage/Security/Trusted.hs +0/−40
- src/Hackage/Security/Trusted/TCB.hs +89/−13
- src/Hackage/Security/Util/IO.hs +34/−67
- src/Hackage/Security/Util/JSON.hs +7/−12
- src/Hackage/Security/Util/Path.hs +225/−294
- src/Hackage/Security/Util/Some.hs +19/−0
- src/Prelude.hs +2/−2
- src/Text/JSON/Canonical.hs +81/−7
- tests/TestSuite.hs +434/−0
- tests/TestSuite/InMemCache.hs +149/−0
- tests/TestSuite/InMemRepo.hs +262/−0
- tests/TestSuite/InMemRepository.hs +63/−0
- tests/TestSuite/PrivateKeys.hs +69/−0
- tests/TestSuite/Util/StrictMVar.hs +27/−0
ChangeLog.md view
@@ -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)
hackage-security.cabal view
@@ -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
src/Hackage/Security/Client.hs view
@@ -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 <https://github.com/theupdateframework/tuf/issues/283>.- 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 <https://github.com/theupdateframework/tuf/issues/283#issuecomment-115739521> 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+ <https://github.com/theupdateframework/tuf/issues/282#issuecomment-102468421>.++ TODO: Currently we hardcode the location of the package specific metadata. By+ rights we should read the global targets file and apply the delegation rules.+ Until we have author signing however this is unnecessary.+-------------------------------------------------------------------------------}++-- | Index directory+data Directory = Directory {+ -- | The first entry in the dictionary+ directoryFirst :: DirectoryEntry++ -- | The next available (i.e., one after last) directory entry+ , directoryNext :: DirectoryEntry++ -- | Lookup an entry in the dictionary --- -- 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- -- <https://github.com/theupdateframework/tuf/issues/282#issuecomment-102468421>.- 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'
src/Hackage/Security/Client/Repository.hs view
@@ -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
src/Hackage/Security/Client/Repository/Cache.hs view
@@ -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 <https://github.com/well-typed/hackage-security/issues/84>. 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
src/Hackage/Security/Client/Repository/HttpLib.hs view
@@ -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
src/Hackage/Security/Client/Repository/Local.hs view
@@ -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
src/Hackage/Security/Client/Repository/Remote.hs view
@@ -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) $
+ src/Hackage/Security/Client/Verify.hs view
@@ -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 <http://www.well-typed.com/blog/2014/08/asynchronous-exceptions/> 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
src/Hackage/Security/JSON.hs view
@@ -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
src/Hackage/Security/Key.hs view
@@ -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
src/Hackage/Security/TUF.hs view
@@ -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
src/Hackage/Security/TUF/Common.hs view
@@ -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
src/Hackage/Security/TUF/FileInfo.hs view
@@ -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
src/Hackage/Security/TUF/FileMap.hs view
@@ -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)
src/Hackage/Security/TUF/Header.hs view
@@ -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
− src/Hackage/Security/TUF/Layout.hs
@@ -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 _ = "<repo>"---- | 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 _ = "<index>"---- | 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 _ = "<cache>"---- | 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 @<cache>/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
+ src/Hackage/Security/TUF/Layout/Cache.hs view
@@ -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 @<cache>/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
+ src/Hackage/Security/TUF/Layout/Index.hs view
@@ -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
+ src/Hackage/Security/TUF/Layout/Repo.hs view
@@ -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
+ src/Hackage/Security/TUF/Paths.hs view
@@ -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) = "<repo>/" ++ 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) = "<index>/" ++ fp++{-------------------------------------------------------------------------------+ Cache+-------------------------------------------------------------------------------}++-- | The cache directory+data CacheRoot+type CachePath = Path CacheRoot++instance Pretty (Path CacheRoot) where+ pretty (Path fp) = "<cache>/" ++ 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
src/Hackage/Security/TUF/Patterns.hs view
@@ -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
src/Hackage/Security/TUF/Signed.hs view
@@ -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
src/Hackage/Security/TUF/Snapshot.hs view
@@ -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
src/Hackage/Security/TUF/Timestamp.hs view
@@ -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
src/Hackage/Security/Trusted.hs view
@@ -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
src/Hackage/Security/Trusted/TCB.hs view
@@ -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
src/Hackage/Security/Util/IO.hs view
@@ -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
src/Hackage/Security/Util/JSON.hs view
@@ -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
src/Hackage/Security/Util/Path.hs view
@@ -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 _ = "<tarball>"+instance Pretty (Path Tar) where+ pretty (Path fp) = "<tarball>/" ++ 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)
src/Hackage/Security/Util/Some.hs view
@@ -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
src/Prelude.hs view
@@ -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
src/Text/JSON/Canonical.hs view
@@ -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 []
+ tests/TestSuite.hs view
@@ -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
+ tests/TestSuite/InMemCache.hs view
@@ -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
+ tests/TestSuite/InMemRepo.hs view
@@ -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+ }
+ tests/TestSuite/InMemRepository.hs view
@@ -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"
+ tests/TestSuite/PrivateKeys.hs view
@@ -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+ }+ }
+ tests/TestSuite/Util/StrictMVar.hs view
@@ -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, ())