diff --git a/hackage-security.cabal b/hackage-security.cabal --- a/hackage-security.cabal +++ b/hackage-security.cabal @@ -1,5 +1,5 @@ name: hackage-security -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Hackage security library description: The hackage security library provides both server and client utilities for securing the Hackage package server @@ -19,7 +19,7 @@ "Hackage.Security.Server" is the main entry point for servers (the typical example being @hackage-server@). . - This is a beta release. + This is a beta release. license: BSD3 license-file: LICENSE author: Edsko de Vries @@ -33,6 +33,10 @@ description: Are we using base 4.8 or later? manual: False +flag use-network-uri + description: Are we using network-uri? + manual: False + library -- Most functionality is exported through the top-level entry points .Client -- and .Server; the other exported modules are intended for qualified imports. @@ -83,15 +87,14 @@ -- 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.23, + 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, - network-uri >= 2.6 && < 2.7, parsec >= 3.1 && < 3.2, - SHA >= 1.6 && < 1.7, + cryptohash >= 0.11 && < 0.12, -- version 0.4.2 of tar introduces TarIndex tar >= 0.4.2 && < 0.5, time >= 1.2 && < 1.6, @@ -134,6 +137,44 @@ build-depends: base >= 4.8 else build-depends: old-locale >= 1.0 + + -- The URI type got split out off the network package after version 2.5, and + -- moved to a separate network-uri package. Since we don't need the rest of + -- network here, it would suffice to rely only on network-uri: + -- + -- > if flag(use-network-uri) + -- > build-depends: network-uri >= 2.6 && < 2.7 + -- > else + -- > build-depends: network >= 2.5 && < 2.6 + -- + -- However, if we did the same in hackage-security-HTTP, Cabal would consider + -- those two flag choices (hackage-security:use-network-uri and + -- hackage-security-HTTP:use-network-uri) to be completely independent; but + -- they aren't: if it links hackage-security against network-uri and + -- hackage-security-HTTP against network, we will get type errors when + -- hackage-security-HTTP tries to pass a URI to hackage-security. + -- + -- It might seem we can solve this problem by re-exporting the URI type in + -- hackage-security and avoid the dependency in hackage-security-HTTP + -- altogether. However, this merely shifts the problem: hackage-security-HTTP + -- relies on the HTTP library which--surprise!--makes the same choice between + -- depending on network or network-uri. Cabal will not notice that we cannot + -- build hackage-security and hackage-security-HTTP against network-uri but + -- HTTP against network. + -- + -- We solve the problem by explicitly relying on network-2.6 when choosing + -- network-uri. This dependency is redundant, strictly speaking. However, it + -- serves as a proxy for forcing flag choices: since all packages in a + -- solution must be linked against the same version of network, having one + -- version of network in one branch of the conditional and another version of + -- network in the other branch forces the choice to be consistent throughout. + -- (Note that the HTTP library does the same thing, though in this case the + -- dependency in network is not redundant.) + if flag(use-network-uri) + build-depends: network-uri >= 2.6 && < 2.7, + network >= 2.6 && < 2.7 + else + build-depends: network >= 2.5 && < 2.6 if impl(ghc >= 7.8) other-extensions: RoleAnnotations diff --git a/src/Hackage/Security/Client.hs b/src/Hackage/Security/Client.hs --- a/src/Hackage/Security/Client.hs +++ b/src/Hackage/Security/Client.hs @@ -270,31 +270,32 @@ -> Either VerificationError (Trusted FileInfo) -> IO () updateRoot rep mNow isRetry cachedInfo eFileInfo = do - (_newRoot :: Trusted Root, newRootFile) <- evalContT $ - getRemoteFile + rootReallyChanged <- evalContT $ do + (_newRoot :: Trusted Root, rootTempFile) <- getRemoteFile rep cachedInfo isRetry mNow (RemoteRoot (eitherToMaybe eFileInfo)) - rootReallyChanged <- + -- NOTE: It is important that we do this check within the evalContT, + -- because the temporary file will be deleted once we leave its scope. case eFileInfo of - Right _ -> - -- We are downloading the root info because the hash in the snapshot - -- changed. In this case the root definitely changed. - return True - Left _e -> do - -- We are downloading the root because of a verification error. In - -- this case the root info may or may not have changed. In most cases - -- it would suffice to compare the file version now; however, in the - -- (exceptional) circumstance where the root info has changed but - -- the file version has not, this would result in the same infinite - -- loop described above. Hence, we must compare file hashes, and they - -- must be computed on the raw file, not the parsed file. - oldRootFile <- repGetCachedRoot rep - oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile - not <$> verifyFileInfo newRootFile oldRootInfo + Right _ -> + -- We are downloading the root info because the hash in the snapshot + -- changed. In this case the root definitely changed. + return True + Left _e -> liftIO $ do + -- We are downloading the root because of a verification error. In + -- this case the root info may or may not have changed. In most cases + -- it would suffice to compare the file version now; however, in the + -- (exceptional) circumstance where the root info has changed but + -- the file version has not, this would result in the same infinite + -- loop described above. Hence, we must compare file hashes, and they + -- must be computed on the raw file, not the parsed file. + oldRootFile <- repGetCachedRoot rep + oldRootInfo <- DeclareTrusted <$> computeFileInfo oldRootFile + not <$> verifyFileInfo rootTempFile oldRootInfo when rootReallyChanged $ clearCache rep diff --git a/src/Hackage/Security/Client/Repository/Remote.hs b/src/Hackage/Security/Client/Repository/Remote.hs --- a/src/Hackage/Security/Client/Repository/Remote.hs +++ b/src/Hackage/Security/Client/Repository/Remote.hs @@ -18,8 +18,8 @@ module Hackage.Security.Client.Repository.Remote ( -- * Top-level API withRepository - , AllowContentCompression(..) - , WantCompressedIndex(..) + , RepoOpts(..) + , defaultRepoOpts -- * File sizes , FileSize(..) , fileSizeWithinBounds @@ -110,22 +110,38 @@ Top-level API -------------------------------------------------------------------------------} --- | Should we allow HTTP content compression? +-- | Repository options with a reasonable default -- --- Since content compression happens before signature verification, users who --- are concerned about potential exploits of the decompression algorithm may --- prefer to disallow content compression. -data AllowContentCompression = - AllowContentCompression - | DisallowContentCompression +-- 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. -data WantCompressedIndex = - WantCompressedIndex - | DontNeedCompressedIndex + -- | 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 + } + +-- | Default repository options +defaultRepoOpts :: RepoOpts +defaultRepoOpts = RepoOpts { + repoAllowContentCompression = True + , repoWantCompressedIndex = False + , repoAllowAdditionalMirrors = True + } + -- | Initialize the repository (and cleanup resources afterwards) -- -- We allow to specify multiple mirrors to initialize the repository. These @@ -145,8 +161,7 @@ withRepository :: HttpLib -- ^ Implementation of the HTTP protocol -> [URI] -- ^ "Out of band" list of mirrors - -> AllowContentCompression -- ^ Should we allow HTTP content compression? - -> WantCompressedIndex -- ^ Do we want a copy of the compressed index? + -> RepoOpts -- ^ Repository options -> Cache -- ^ Location of local cache -> RepoLayout -- ^ Repository layout -> (LogMessage -> IO ()) -- ^ Logger @@ -154,8 +169,7 @@ -> IO a withRepository httpLib outOfBandMirrors - allowContentCompression - wantCompressedIndex + repoOpts cache repLayout logger @@ -170,8 +184,7 @@ , cfgCache = cache , cfgCaps = caps , cfgLogger = logger - , cfgCompress = allowContentCompression - , cfgWantGz = wantCompressedIndex + , cfgOpts = repoOpts } callback Repository { repWithRemote = withRemote remoteConfig selectedMirror @@ -179,7 +192,11 @@ , repGetCachedRoot = Cache.getCachedRoot cache , repClearCache = Cache.clearCache cache , repGetFromIndex = Cache.getFromIndex cache (repoIndexLayout repLayout) - , repWithMirror = withMirror httpLib selectedMirror logger outOfBandMirrors + , repWithMirror = withMirror httpLib + selectedMirror + logger + outOfBandMirrors + repoOpts , repLog = logger , repLayout = repLayout , repDescription = "Remote repository at " ++ show outOfBandMirrors @@ -250,7 +267,7 @@ defaultHeaders = concat [ [ HttpRequestNoTransform ] , [ HttpRequestContentCompression - | AllowContentCompression <- [cfgCompress] + | repoAllowContentCompression cfgOpts ] ] @@ -260,10 +277,18 @@ -> SelectedMirror -- ^ MVar indicating currently mirror -> (LogMessage -> IO ()) -- ^ Logger -> [URI] -- ^ Out-of-band mirrors + -> RepoOpts -- ^ Repository options -> Maybe [Mirror] -- ^ TUF mirrors -> IO a -- ^ Callback -> IO a -withMirror HttpLib{..} selectedMirror logger oobMirrors tufMirrors callback = +withMirror HttpLib{..} + selectedMirror + logger + oobMirrors + repoOpts + tufMirrors + callback + = go orderedMirrors where go :: [URI] -> IO a @@ -283,7 +308,12 @@ -- TODO: We will want to make the construction of this list configurable. orderedMirrors :: [URI] - orderedMirrors = nub $ oobMirrors ++ maybe [] (map mirrorUrlBase) tufMirrors + orderedMirrors = nub $ concat [ + oobMirrors + , if repoAllowAdditionalMirrors repoOpts + then maybe [] (map mirrorUrlBase) tufMirrors + else [] + ] select :: URI -> IO a -> IO a select uri = @@ -335,11 +365,8 @@ (RemoteIndex pf fs) -> return (pf, fs) -- If the client wants the compressed index, we have no choice - case cfgWantGz of - WantCompressedIndex -> - exit $ CannotUpdate hasGz UpdateNotUsefulWantsCompressed - DontNeedCompressedIndex -> - return () + when (repoWantCompressedIndex cfgOpts) $ + exit $ CannotUpdate hasGz UpdateNotUsefulWantsCompressed -- Server must have uncompressed index available hasUn <- case formatsMember FUn formats of @@ -368,9 +395,9 @@ localSize <- liftIO $ getFileSize cachedIndex let infoGz = formatsLookup hasGz formats infoUn = formatsLookup hasUn formats - estCompFactor = case (canCompress, cfgCompress) of - (True, AllowContentCompression) -> 10 - _otherwise -> 1 + estCompFactor = if canCompress && repoAllowContentCompression cfgOpts + then 10 + else 1 estUpdateSize = (fileLength' infoUn - fromIntegral localSize) `div` estCompFactor unless (estUpdateSize < fileLength' infoGz) $ @@ -593,8 +620,7 @@ , cfgCache :: Cache , cfgCaps :: ServerCapabilities , cfgLogger :: LogMessage -> IO () - , cfgCompress :: AllowContentCompression - , cfgWantGz :: WantCompressedIndex + , cfgOpts :: RepoOpts } {------------------------------------------------------------------------------- diff --git a/src/Hackage/Security/Key.hs b/src/Hackage/Security/Key.hs --- a/src/Hackage/Security/Key.hs +++ b/src/Hackage/Security/Key.hs @@ -26,10 +26,10 @@ ) where import Control.Monad -import Data.Digest.Pure.SHA import Data.Functor.Identity import Data.Typeable (Typeable) import Text.JSON.Canonical +import qualified Crypto.Hash as CH import qualified Crypto.Sign.Ed25519 as Ed25519 import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BS.L @@ -159,8 +159,8 @@ instance HasKeyId PublicKey where keyId = KeyId - . showDigest - . sha256 + . show + . (CH.hashlazy :: BS.L.ByteString -> CH.Digest CH.SHA256) . renderCanonicalJSON . runIdentity . toJSON diff --git a/src/Hackage/Security/TUF/FileInfo.hs b/src/Hackage/Security/TUF/FileInfo.hs --- a/src/Hackage/Security/TUF/FileInfo.hs +++ b/src/Hackage/Security/TUF/FileInfo.hs @@ -11,7 +11,7 @@ import Prelude hiding (lookup) import Data.Map (Map) -import Data.Digest.Pure.SHA +import qualified Crypto.Hash as CH import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS.L @@ -50,14 +50,12 @@ -- -- TODO: Currently this will load the entire input bytestring into memory. -- We need to make this incremental, by computing the length and all hashes --- in a single traversal over the input. However, the precise way to --- do that will depend on the hashing package we will use, and we have --- yet to pick that package. +-- in a single traversal over the input. fileInfo :: BS.L.ByteString -> FileInfo fileInfo bs = FileInfo { fileInfoLength = FileLength . fromIntegral $ BS.L.length bs , fileInfoHashes = Map.fromList [ - (HashFnSHA256, Hash $ showDigest (sha256 bs)) + (HashFnSHA256, Hash $ show (CH.hashlazy bs :: CH.Digest CH.SHA256)) ] } diff --git a/src/Hackage/Security/Util/JSON.hs b/src/Hackage/Security/Util/JSON.hs --- a/src/Hackage/Security/Util/JSON.hs +++ b/src/Hackage/Security/Util/JSON.hs @@ -29,8 +29,8 @@ import Network.URI import qualified Data.Map as Map -#if !MIN_VERSION_base(4,8,0) -import System.Locale +#if !MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) #endif import Hackage.Security.Util.Path @@ -146,7 +146,7 @@ case parseTimeM False defaultTimeLocale "%FT%TZ" str of Just time -> return time Nothing -> expected "valid date-time string" (Just str) -#if !MIN_VERSION_base(4,8,0) +#if !MIN_VERSION_time(1,5,0) where parseTimeM _trim = parseTime #endif