diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Well-Typed LLP nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hackage-security.cabal b/hackage-security.cabal new file mode 100644 --- /dev/null +++ b/hackage-security.cabal @@ -0,0 +1,145 @@ +name: hackage-security +version: 0.1.0.0 +synopsis: Hackage security library +description: The hackage security library provides both server and + client utilities for securing the Hackage package server + (). It is based on The Update + Framework (), a set of + recommendations developed by security researchers at + various universities in the US as well as developers on the + Tor project (). + . + The current implementation supports only index signing, + thereby enabling untrusted mirrors. It does not yet provide + facilities for author package signing. + . + The library has two main entry points: + "Hackage.Security.Client" is the main entry point for + clients (the typical example being @cabal@), and + "Hackage.Security.Server" is the main entry point for + servers (the typical example being @hackage-server@). + . + This is a beta release. +license: BSD3 +license-file: LICENSE +author: Edsko de Vries +maintainer: edsko@well-typed.com +copyright: Copyright 2015 Well-Typed LLP +category: Distribution +build-type: Simple +cabal-version: >=1.10 + +flag base48 + description: Are we using base 4.8 or later? + 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. + exposed-modules: Hackage.Security.Client + 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.JSON + Hackage.Security.Key.Env + Hackage.Security.Server + Hackage.Security.TUF.FileMap + Hackage.Security.Util.Checked + Hackage.Security.Util.IO + Hackage.Security.Util.Lens + Hackage.Security.Util.Path + Hackage.Security.Util.Pretty + Hackage.Security.Util.Some + Text.JSON.Canonical + other-modules: Hackage.Security.Client.Formats + Hackage.Security.Key + Hackage.Security.Trusted + 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.Mirrors + Hackage.Security.TUF.Patterns + Hackage.Security.TUF.Root + Hackage.Security.TUF.Signed + Hackage.Security.TUF.Snapshot + Hackage.Security.TUF.Targets + Hackage.Security.TUF.Timestamp + Hackage.Security.Util.Base64 + Hackage.Security.Util.JSON + 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 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.23, + 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, + -- 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, + -- whatever versions are bundled with ghc: + template-haskell, + ghc-prim + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: DefaultSignatures + DeriveDataTypeable + DeriveFunctor + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NoMonomorphismRestriction + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + ViewPatterns + other-extensions: BangPatterns + CPP + OverlappingInstances + PackageImports + QuasiQuotes + TemplateHaskell + UndecidableInstances + ghc-options: -Wall + + if flag(base48) + build-depends: base >= 4.8 + else + build-depends: old-locale >= 1.0 + + if impl(ghc >= 7.8) + other-extensions: RoleAnnotations + + if impl(ghc >= 7.10) + other-extensions: AllowAmbiguousTypes +-- StaticPointers +-- ^^^ Temporarily disabled because Hackage doesn't know yet about this +-- extension and will therefore reject this package. diff --git a/src/Hackage/Security/Client.hs b/src/Hackage/Security/Client.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client.hs @@ -0,0 +1,713 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE StaticPointers #-} +#endif +-- | Main entry point into the Hackage Security framework for clients +module Hackage.Security.Client ( + -- * Checking for updates + checkForUpdates + , CheckExpiry(..) + , HasUpdates(..) + -- * Downloading targets + , downloadPackage + , getCabalFile + -- * Bootstrapping + , requiresBootstrap + , bootstrap + -- * Re-exports + , module Hackage.Security.TUF + , module Hackage.Security.Key + -- ** We only a few bits from .Repository + -- TODO: Maybe this is a sign that these should be in a different module? + , Repository -- opaque + , SomeRemoteError(..) + , LogMessage(..) + -- * Exceptions + , uncheckClientErrors + , VerificationError(..) + , InvalidPackageException(..) + , InvalidFileInIndex(..) + , LocalFileCorrupted(..) + ) where + +import Prelude hiding (log) +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Cont +import Data.Maybe (isNothing) +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 Distribution.Package (PackageIdentifier) +import Distribution.Text (display) + +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Formats +import Hackage.Security.JSON +import Hackage.Security.Key +import Hackage.Security.Key.Env (KeyEnv) +import Hackage.Security.Trusted +import Hackage.Security.Trusted.TCB +import Hackage.Security.TUF +import Hackage.Security.Util.Checked +import Hackage.Security.Util.Pretty +import Hackage.Security.Util.Stack +import Hackage.Security.Util.Some +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 + +-- | Generic logic for checking if there are updates +-- +-- This implements the logic described in Section 5.1, "The client application", +-- of the TUF spec. It checks which of the server metadata has changed, and +-- downloads all changed metadata to the local cache. (Metadata here refers +-- both to the TUF security metadata as well as the Hackage packge index.) +checkForUpdates :: (Throws VerificationError, Throws SomeRemoteError) + => Repository -> CheckExpiry -> IO HasUpdates +checkForUpdates rep checkExpiry = + withMirror rep $ limitIterations [] + where + -- More or less randomly chosen maximum iterations + -- See . + maxNumIterations :: Int + maxNumIterations = 5 + + -- The spec stipulates that on a verification error we must download new + -- root information and start over. However, in order to prevent DoS attacks + -- we limit how often we go round this loop. + -- See als . + limitIterations :: (Throws VerificationError, Throws SomeRemoteError) + => VerificationHistory -> IO HasUpdates + limitIterations history | length history >= maxNumIterations = + throwChecked $ VerificationErrorLoop (reverse history) + limitIterations history = do + -- Get all cached info + -- + -- NOTE: Although we don't normally update any cached files until the + -- whole verification process successfully completes, in case of a + -- verification error, or in case of a regular update of the root info, + -- we DO update the local files. Hence, we must re-read all local files + -- on each iteration. + cachedInfo <- getCachedInfo rep + + -- 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) + case mHasUpdates of + Left ex -> do + -- NOTE: This call to updateRoot is not itself protected by an + -- exception handler, and may therefore throw a VerificationError. + -- This is intentional: if we get verification errors during the + -- update process, _and_ we cannot update the main root info, then + -- we cannot do anything. + log rep $ LogVerificationError ex + updateRoot rep mNow AfterVerificationError cachedInfo (Left ex) + limitIterations (Right ex : history) + Right (Left RootUpdated) -> do + log rep $ LogRootUpdated + limitIterations (Left RootUpdated : history) + Right (Right hasUpdates) -> + return hasUpdates + where + isRetry :: IsRetry + isRetry = if null history then FirstAttempt else AfterVerificationError + + -- 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. + -- See also . + go :: Throws RootUpdated + => Maybe UTCTime -> IsRetry -> CachedInfo -> ContT r IO HasUpdates + go mNow isRetry cachedInfo@CachedInfo{..} = do + -- Get the new timestamp + newTS <- getRemoteFile' RemoteTimestamp + let newInfoSS = static timestampInfoSnapshot <$$> newTS + + -- Check if the snapshot has changed + if not (fileChanged cachedInfoSnapshot newInfoSS) + then return NoUpdates + else do + -- Get the new snapshot + newSS <- getRemoteFile' (RemoteSnapshot newInfoSS) + let newInfoRoot = static snapshotInfoRoot <$$> newSS + newInfoMirrors = static snapshotInfoMirrors <$$> newSS + newInfoTarGz = static snapshotInfoTarGz <$$> newSS + mNewInfoTar = trustSeq (static snapshotInfoTar <$$> newSS) + + -- If root metadata changed, download and restart + when (rootChanged cachedInfoRoot newInfoRoot) $ liftIO $ do + updateRoot rep mNow isRetry cachedInfo (Right newInfoRoot) + -- By throwing 'RootUpdated' as an exception we make sure that + -- any files previously downloaded (to temporary locations) + -- will not be cached. + throwChecked RootUpdated + + -- If mirrors changed, download and verify + when (fileChanged cachedInfoMirrors newInfoMirrors) $ + newMirrors =<< getRemoteFile' (RemoteMirrors newInfoMirrors) + + -- If index changed, download and verify + when (fileChanged cachedInfoTarGz newInfoTarGz) $ + updateIndex newInfoTarGz mNewInfoTar + + return HasUpdates + where + getRemoteFile' :: ( VerifyRole a + , FromJSON ReadJSON_Keys_Layout (Signed a) + ) + => RemoteFile (f :- ()) -> ContT r IO (Trusted a) + getRemoteFile' = liftM fst . getRemoteFile rep cachedInfo isRetry 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 () + updateIndex newInfoTarGz Nothing = do + (targetPath, tempPath) <- getRemote' rep isRetry $ + RemoteIndex (HFZ FGz) (FsGz newInfoTarGz) + verifyFileInfo' (Just newInfoTarGz) targetPath tempPath + updateIndex newInfoTarGz (Just newInfoTar) = do + (format, targetPath, tempPath) <- getRemote rep isRetry $ + RemoteIndex (HFS (HFZ FGz)) (FsUnGz newInfoTar newInfoTarGz) + case format of + Some FGz -> verifyFileInfo' (Just newInfoTarGz) targetPath tempPath + Some FUn -> verifyFileInfo' (Just newInfoTar) targetPath tempPath + + -- Unlike for other files, if we didn't have an old snapshot, consider the + -- root info unchanged (otherwise we would loop indefinitely). + -- See also + rootChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool + rootChanged Nothing _ = False + rootChanged (Just old) new = not (trustedFileInfoEqual old new) + + -- For any file other than the root we consider the file to have changed + -- if we do not yet have a local snapshot to tell us the old info. + fileChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool + fileChanged Nothing _ = True + fileChanged (Just old) new = not (trustedFileInfoEqual old new) + + -- We don't actually _do_ anything with the mirrors file until the next call + -- to 'checkUpdates', because we want to use a single server for a single + -- check-for-updates request. If validation was successful the repository + -- will have cached the mirrors file and it will be available on the next + -- request. + newMirrors :: Trusted Mirrors -> ContT r IO () + newMirrors _ = return () + +-- | Update the root metadata +-- +-- Note that the new root metadata is verified using the old root metadata, +-- and only then trusted. +-- +-- We don't always have root file information available. If we notice during +-- the normal update process that the root information has changed then the +-- snapshot will give us the new file information; but if we need to update +-- the root information due to a verification error we do not. +-- +-- We additionally delete the cached cached snapshot and timestamp. This is +-- necessary for two reasons: +-- +-- 1. If during the normal update process we notice that the root info was +-- updated (because the hash of @root.json@ in the new snapshot is different +-- from the old snapshot) we download new root info and start over, without +-- (yet) downloading a (potential) new index. This means it is important that +-- we not overwrite our local cached snapshot, because if we did we would +-- then on the next iteration conclude there were no updates and we would +-- fail to notice that we should have updated the index. However, unless we +-- do something, this means that we would conclude on the next iteration once +-- again that the root info has changed (because the hash in the new shapshot +-- still doesn't match the hash in the cached snapshot), and we would loop +-- until we throw a 'VerificationErrorLoop' exception. By deleting the local +-- snapshot we basically reset the client to its initial state, and we will +-- not try to download the root info once again. The only downside of this is +-- that we will also re-download the index after every root info change. +-- However, this should be infrequent enough that this isn't an issue. +-- See also . +-- +-- 2. Additionally, deleting the local timestamp and snapshot protects against +-- an attack where an attacker has set the file version of the snapshot or +-- timestamp to MAX_INT, thereby making further updates impossible. +-- (Such an attack would require a timestamp/snapshot key compromise.) +-- +-- However, we _ONLY_ do this when the root information has actually changed. +-- If we did this unconditionally it would mean that we delete the locally +-- cached timestamp whenever the version on the remote timestamp is invalid, +-- thereby rendering the file version on the timestamp and the snapshot useless. +-- See +updateRoot :: (Throws VerificationError, Throws SomeRemoteError) + => Repository + -> Maybe UTCTime + -> IsRetry + -> CachedInfo + -> Either VerificationError (Trusted FileInfo) + -> IO () +updateRoot rep mNow isRetry cachedInfo eFileInfo = do + (_newRoot :: Trusted Root, newRootFile) <- evalContT $ + getRemoteFile + rep + cachedInfo + isRetry + mNow + (RemoteRoot (eitherToMaybe eFileInfo)) + + rootReallyChanged <- + 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 + + when rootReallyChanged $ clearCache rep + +{------------------------------------------------------------------------------- + Convenience functions for downloading and parsing various files +-------------------------------------------------------------------------------} + +data CachedInfo = CachedInfo { + cachedRoot :: Trusted Root + , cachedKeyEnv :: KeyEnv + , cachedTimestamp :: Maybe (Trusted Timestamp) + , cachedSnapshot :: Maybe (Trusted Snapshot) + , cachedMirrors :: Maybe (Trusted Mirrors) + , cachedInfoSnapshot :: Maybe (Trusted FileInfo) + , cachedInfoRoot :: Maybe (Trusted FileInfo) + , cachedInfoMirrors :: Maybe (Trusted FileInfo) + , cachedInfoTarGz :: Maybe (Trusted FileInfo) + } + +cachedVersion :: CachedInfo -> RemoteFile fs -> Maybe FileVersion +cachedVersion CachedInfo{..} remoteFile = + case mustCache remoteFile of + CacheAs CachedTimestamp -> timestampVersion . trusted <$> cachedTimestamp + CacheAs CachedSnapshot -> snapshotVersion . trusted <$> cachedSnapshot + CacheAs CachedMirrors -> mirrorsVersion . trusted <$> cachedMirrors + CacheAs CachedRoot -> Just . rootVersion . trusted $ cachedRoot + CacheIndex -> Nothing + DontCache -> Nothing + +-- | Get all cached info (if any) +getCachedInfo :: (Applicative m, MonadIO m) => Repository -> m CachedInfo +getCachedInfo rep = do + (cachedRoot, cachedKeyEnv) <- readLocalRoot rep + cachedTimestamp <- readLocalFile rep cachedKeyEnv CachedTimestamp + cachedSnapshot <- readLocalFile rep cachedKeyEnv CachedSnapshot + cachedMirrors <- readLocalFile rep cachedKeyEnv CachedMirrors + + let cachedInfoSnapshot = fmap (static timestampInfoSnapshot <$$>) cachedTimestamp + cachedInfoRoot = fmap (static snapshotInfoRoot <$$>) cachedSnapshot + cachedInfoMirrors = fmap (static snapshotInfoMirrors <$$>) cachedSnapshot + cachedInfoTarGz = fmap (static snapshotInfoTarGz <$$>) cachedSnapshot + + return CachedInfo{..} + +readLocalRoot :: MonadIO m => Repository -> m (Trusted Root, KeyEnv) +readLocalRoot rep = do + cachedPath <- liftIO $ repGetCachedRoot rep + signedRoot <- throwErrorsUnchecked LocalFileCorrupted =<< + readJSON (repLayout 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)) +readLocalFile rep cachedKeyEnv file = do + mCachedPath <- liftIO $ repGetCached rep file + for mCachedPath $ \cachedPath -> do + signed <- throwErrorsUnchecked LocalFileCorrupted =<< + readJSON (repLayout rep) cachedKeyEnv cachedPath + return $ trustLocalFile signed + +getRemoteFile :: ( Throws VerificationError + , Throws SomeRemoteError + , VerifyRole a + , FromJSON ReadJSON_Keys_Layout (Signed a) + ) + => Repository + -> CachedInfo + -> IsRetry + -> Maybe UTCTime + -> RemoteFile (f :- ()) + -> ContT r IO (Trusted a, TempPath) +getRemoteFile rep 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 + verified <- throwErrorsChecked id $ verifyRole + cachedRoot + targetPath + (cachedVersion cachedInfo file) + mNow + signed + return (trustVerified verified, tempPath) + +{------------------------------------------------------------------------------- + Downloading target files +-------------------------------------------------------------------------------} + +-- | 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 + + -- 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 + -- . + let trustIndex :: Signed a -> Trusted a + trustIndex = trustLocalFile + + -- Get the metadata (from the previously updated index) + -- + -- 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 + + -- The path of the package, relative to the targets.json file + let filePath :: TargetPath + filePath = TargetPathRepo $ repoLayoutPkgTarGz (repLayout rep) pkgId + + 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 + + -- 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 + +-- | Get a cabal file from the index +-- +-- 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. +-- +-- Should be called only once a local index is available +-- (i.e., after 'checkForUpdates'). +-- +-- 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 + +{------------------------------------------------------------------------------- + Bootstrapping +-------------------------------------------------------------------------------} + +-- | Check if we need to bootstrap (i.e., if we have root info) +requiresBootstrap :: Repository -> IO Bool +requiresBootstrap rep = isNothing <$> repGetCached rep CachedRoot + +-- | Bootstrap the chain of trust +-- +-- New clients might need to obtain a copy of the root metadata. This however +-- represents a chicken-and-egg problem: how can we verify the root metadata +-- we downloaded? The only possibility is to be provided with a set of an +-- out-of-band set of root keys and an appropriate threshold. +-- +-- Clients who provide a threshold of 0 can do an initial "unsafe" update +-- of the root information, if they wish. +-- +-- The downloaded root information will _only_ be verified against the +-- provided keys, and _not_ against previously downloaded root info (if any). +-- It is the responsibility of the client to call `bootstrap` only when this +-- is the desired behaviour. +bootstrap :: (Throws SomeRemoteError, Throws VerificationError) + => Repository -> [KeyId] -> KeyThreshold -> IO () +bootstrap rep trustedRootKeys keyThreshold = withMirror rep $ evalContT $ do + _newRoot :: Trusted Root <- do + (targetPath, tempPath) <- getRemote' rep FirstAttempt (RemoteRoot Nothing) + signed <- throwErrorsChecked SomeRemoteError =<< + readJSON (repLayout rep) KeyEnv.empty tempPath + verified <- throwErrorsChecked id $ verifyFingerprints + trustedRootKeys + keyThreshold + targetPath + signed + return $ trustVerified verified + + clearCache rep + +{------------------------------------------------------------------------------- + Wrapper around the Repository functions (to avoid callback hell) +-------------------------------------------------------------------------------} + +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 + +-- | 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' r isRetry file = ignoreFormat <$> getRemote r isRetry file + where + ignoreFormat (_format, targetPath, tempPath) = (targetPath, tempPath) + +clearCache :: MonadIO m => Repository -> m () +clearCache r = liftIO $ repClearCache r + +log :: MonadIO m => Repository -> 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 rep callback = do + mMirrors <- repGetCached rep CachedMirrors + mirrors <- case mMirrors of + Nothing -> return Nothing + Just fp -> filterMirrors <$> + (throwErrorsUnchecked LocalFileCorrupted =<< + readJSON_NoKeys_NoLayout fp) + repWithMirror rep mirrors $ callback + where + filterMirrors :: UninterpretedSignatures Mirrors -> Maybe [Mirror] + filterMirrors = Just + . filter (canUseMirror . mirrorContent) + . mirrorsMirrors + . uninterpretedSigned + + -- Once we add support for partial mirrors, we wil need an additional + -- argument to 'repWithMirror' (here, not in the Repository API itself) + -- that tells us which files we will be requested from the mirror. + -- We can then compare that against the specification of the partial mirror + -- to see if all of those files are available from this mirror. + canUseMirror :: MirrorContent -> Bool + canUseMirror MirrorFull = True + +{------------------------------------------------------------------------------- + Exceptions +-------------------------------------------------------------------------------} + +-- | Re-throw all exceptions thrown by the client API as unchecked exceptions +uncheckClientErrors :: ( ( Throws VerificationError + , Throws SomeRemoteError + , Throws InvalidPackageException + ) => IO a ) + -> IO a +uncheckClientErrors act = handleChecked rethrowVerificationError + $ handleChecked rethrowSomeRemoteError + $ handleChecked rethrowInvalidPackageException + $ act + where + rethrowVerificationError :: VerificationError -> IO a + rethrowVerificationError = throwIO + + rethrowSomeRemoteError :: SomeRemoteError -> IO a + rethrowSomeRemoteError = throwIO + + rethrowInvalidPackageException :: InvalidPackageException -> IO a + rethrowInvalidPackageException = throwIO + +data InvalidPackageException = InvalidPackageException PackageIdentifier + deriving (Typeable) + +data LocalFileCorrupted = LocalFileCorrupted DeserializationError + deriving (Typeable) + +data InvalidFileInIndex = InvalidFileInIndex IndexFile DeserializationError + deriving (Typeable) + +#if MIN_VERSION_base(4,8,0) +deriving instance Show InvalidPackageException +deriving instance Show LocalFileCorrupted +deriving instance Show InvalidFileInIndex +instance Exception InvalidPackageException where displayException = pretty +instance Exception LocalFileCorrupted where displayException = pretty +instance Exception InvalidFileInIndex where displayException = pretty +#else +instance Show InvalidPackageException where show = pretty +instance Show LocalFileCorrupted where show = pretty +instance Show InvalidFileInIndex where show = pretty +instance Exception InvalidPackageException +instance Exception LocalFileCorrupted +instance Exception InvalidFileInIndex +#endif + +instance Pretty InvalidPackageException where + pretty (InvalidPackageException pkgId) = "Invalid package " ++ display pkgId + +instance Pretty LocalFileCorrupted where + pretty (LocalFileCorrupted err) = "Local file corrupted: " ++ pretty err + +instance Pretty InvalidFileInIndex where + pretty (InvalidFileInIndex file err) = "Invalid file " ++ pretty file + ++ "in index: " ++ pretty err + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Local files are assumed trusted +-- +-- There is no point tracking chain of trust for local files because that chain +-- would necessarily have to start at an implicitly trusted (though unverified) +-- file: the root metadata. +trustLocalFile :: Signed a -> Trusted a +trustLocalFile Signed{..} = DeclareTrusted signed + +-- | Just a simple wrapper around 'verifyFileInfo' +-- +-- Throws a VerificationError if verification failed. +verifyFileInfo' :: MonadIO m + => Maybe (Trusted FileInfo) + -> TargetPath -- ^ For error messages + -> TempPath -- ^ File to verify + -> m () +verifyFileInfo' Nothing _ _ = return () +verifyFileInfo' (Just info) targetPath tempPath = liftIO $ do + verified <- verifyFileInfo 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 + +throwErrorsUnchecked :: ( MonadIO m + , Exception e' + ) + => (e -> e') -> Either e a -> m a +throwErrorsUnchecked f (Left err) = liftIO $ throwUnchecked (f err) +throwErrorsUnchecked _ (Right a) = return a + +throwErrorsChecked :: ( Throws e' + , MonadIO m + , Exception e' + ) + => (e -> e') -> Either e a -> m a +throwErrorsChecked f (Left err) = liftIO $ throwChecked (f err) +throwErrorsChecked _ (Right a) = return a + +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right b) = Just b diff --git a/src/Hackage/Security/Client/Formats.hs b/src/Hackage/Security/Client/Formats.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Formats.hs @@ -0,0 +1,116 @@ +module Hackage.Security.Client.Formats ( + -- * Formats + -- ** Type level + FormatUn + , FormatGz + -- ** Term level + , Format(..) + , Formats(..) + -- * Key membership + , HasFormat(..) + -- ** Utility + , hasFormatAbsurd + , hasFormatGet + -- * Map-like operations + , formatsMap + , formatsMember + , formatsLookup + ) where + +import Hackage.Security.Util.Stack +import Hackage.Security.Util.TypedEmbedded + +{------------------------------------------------------------------------------- + Formats +-------------------------------------------------------------------------------} + +data FormatUn +data FormatGz + +-- | Format is a singleton type (reflection type to term level) +-- +-- NOTE: In the future we might add further compression formats. +data Format :: * -> * where + FUn :: Format FormatUn + FGz :: Format FormatGz + +deriving instance Show (Format f) +deriving instance Eq (Format f) + +instance Unify Format where + unify FUn FUn = Just Refl + unify FGz FGz = Just Refl + unify _ _ = Nothing + +{------------------------------------------------------------------------------- + Products +-------------------------------------------------------------------------------} + +-- | Available formats +-- +-- Rather than having a general list here, we enumerate all possibilities. +-- This means we are very precise about what we expect, and we avoid any runtime +-- errors about unexpect format definitions. +-- +-- NOTE: If we add additional cases here (for dealing with additional formats) +-- all calls to @error "inaccessible"@ need to be reevaluated. +data Formats :: * -> * -> * where + FsNone :: Formats () a + FsUn :: a -> Formats (FormatUn :- ()) a + FsGz :: a -> Formats (FormatGz :- ()) a + FsUnGz :: a -> a -> Formats (FormatUn :- FormatGz :- ()) a + +deriving instance Eq a => Eq (Formats fs a) +deriving instance Show a => Show (Formats fs a) + +instance Functor (Formats fs) where + fmap g = formatsMap (\_format -> g) + +{------------------------------------------------------------------------------- + Key membership +-------------------------------------------------------------------------------} + +-- | @HasFormat fs f@ is a proof that @f@ is a key in @fs@. +-- +-- See 'formatsMember' and 'formatsLookup' for typical usage. +data HasFormat :: * -> * -> * where + HFZ :: Format f -> HasFormat (f :- fs) f + HFS :: HasFormat fs f -> HasFormat (f' :- fs) f + +deriving instance Eq (HasFormat fs f) +deriving instance Show (HasFormat fs f) + +hasFormatAbsurd :: HasFormat () f -> a +hasFormatAbsurd _ = error "inaccessible" + +hasFormatGet :: HasFormat fs f -> Format f +hasFormatGet (HFZ f) = f +hasFormatGet (HFS hf) = hasFormatGet hf + +{------------------------------------------------------------------------------- + Map-like functionality +-------------------------------------------------------------------------------} + +formatsMap :: (forall f. Format f -> a -> b) -> Formats fs a -> Formats fs b +formatsMap _ FsNone = FsNone +formatsMap f (FsUn a) = FsUn (f FUn a) +formatsMap f (FsGz a) = FsGz (f FGz a) +formatsMap f (FsUnGz a a') = FsUnGz (f FUn a) (f FGz a') + +formatsMember :: Format f -> Formats fs a -> Maybe (HasFormat fs f) +formatsMember _ FsNone = Nothing +formatsMember FUn (FsUn _ ) = Just $ HFZ FUn +formatsMember FUn (FsGz _) = Nothing +formatsMember FUn (FsUnGz _ _) = Just $ HFZ FUn +formatsMember FGz (FsUn _ ) = Nothing +formatsMember FGz (FsGz _) = Just $ HFZ FGz +formatsMember FGz (FsUnGz _ _) = Just $ HFS (HFZ FGz) + +formatsLookup :: HasFormat fs f -> Formats fs a -> a +formatsLookup (HFZ FUn) (FsUn a ) = a +formatsLookup (HFZ FUn) (FsUnGz a _) = a +formatsLookup (HFZ FGz) (FsGz a) = a +formatsLookup (HFS hf) (FsUn _ ) = hasFormatAbsurd hf +formatsLookup (HFS hf) (FsGz _) = hasFormatAbsurd hf +formatsLookup (HFS hf) (FsUnGz _ a) = formatsLookup hf (FsGz a) +formatsLookup _ _ = error "inaccessible" diff --git a/src/Hackage/Security/Client/Repository.hs b/src/Hackage/Security/Client/Repository.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository.hs @@ -0,0 +1,462 @@ +-- | Abstract definition of a Repository +-- +-- Most clients should only need to import this module if they wish to define +-- their own Repository implementations. +{-# LANGUAGE CPP #-} +module Hackage.Security.Client.Repository ( + -- * Files + RemoteFile(..) + , CachedFile(..) + , IndexFile(..) + , remoteFileDefaultFormat + , remoteFileDefaultInfo + -- * Repository proper + , Repository(..) + , TempPath + , IsRetry(..) + , LogMessage(..) + , UpdateFailure(..) + , SomeRemoteError(..) + -- ** Helpers + , mirrorsUnsupported + -- * Paths + , remoteRepoPath + , remoteRepoPath' + , indexFilePath + -- * Utility + , IsCached(..) + , mustCache + ) where + +import Control.Exception +import Data.Typeable (Typeable) +import qualified Data.ByteString as BS + +import Distribution.Package +import Distribution.Text + +import Hackage.Security.Client.Formats +import Hackage.Security.Trusted +import Hackage.Security.TUF +import Hackage.Security.Util.Checked +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty +import Hackage.Security.Util.Some +import Hackage.Security.Util.Stack + +{------------------------------------------------------------------------------- + Files +-------------------------------------------------------------------------------} + +-- | 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. +-- +-- NOTE: Haddock lacks GADT support so constructors have only regular comments. +data RemoteFile :: * -> * where + -- Timestamp metadata (@timestamp.json@) + -- + -- We never have (explicit) file length available for timestamps. + RemoteTimestamp :: RemoteFile (FormatUn :- ()) + + -- Root metadata (@root.json@) + -- + -- For root information we may or may not have the file info available: + -- + -- - If during the normal update process the new snapshot tells us the root + -- information has changed, we can use the file info from the snapshot. + -- - 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 :- ()) + + -- Snapshot metadata (@snapshot.json@) + -- + -- We get file info of the snapshot from the timestamp. + RemoteSnapshot :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) + + -- Mirrors metadata (@mirrors.json@) + -- + -- We get the file info from the snapshot. + RemoteMirrors :: Trusted FileInfo -> RemoteFile (FormatUn :- ()) + + -- Index + -- + -- The index file length comes from the snapshot. + -- + -- When we request that the index is downloaded, it is up to the repository + -- to decide whether to download @00-index.tar@ or @00-index.tar.gz@. + -- The callback is told which format was requested. + -- + -- It is a bug to request a file that the repository does not provide + -- (the snapshot should make it clear which files are available). + RemoteIndex :: HasFormat fs FormatGz + -> Formats fs (Trusted FileInfo) + -> RemoteFile fs + + -- Actual package + -- + -- Package file length comes from the corresponding @targets.json@. + RemotePkgTarGz :: PackageIdentifier + -> Trusted FileInfo + -> RemoteFile (FormatGz :- ()) + +-- deriving instance Eq (RemoteFile fs) +deriving instance Show (RemoteFile fs) + +instance Pretty (RemoteFile fs) where + pretty RemoteTimestamp = "timestamp" + pretty (RemoteRoot _) = "root" + pretty (RemoteSnapshot _) = "snapshot" + pretty (RemoteMirrors _) = "mirrors" + pretty (RemoteIndex _ _) = "index" + pretty (RemotePkgTarGz pkgId _) = "package " ++ display pkgId + +-- | Files that we might request from the local cache +data CachedFile = + -- | Timestamp metadata (@timestamp.json@) + CachedTimestamp + + -- | Root metadata (@root.json@) + | CachedRoot + + -- | Snapshot metadata (@snapshot.json@) + | CachedSnapshot + + -- | Mirrors list (@mirrors.json@) + | 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 + +-- | 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 RemoteTimestamp = Some $ HFZ FUn +remoteFileDefaultFormat (RemoteRoot _) = Some $ HFZ FUn +remoteFileDefaultFormat (RemoteSnapshot _) = Some $ HFZ FUn +remoteFileDefaultFormat (RemoteMirrors _) = Some $ HFZ FUn +remoteFileDefaultFormat (RemotePkgTarGz _ _) = Some $ HFZ FGz +remoteFileDefaultFormat (RemoteIndex pf _) = Some pf + +-- | Default file info (see also 'remoteFileDefaultFormat') +remoteFileDefaultInfo :: RemoteFile fs -> Maybe (Trusted FileInfo) +remoteFileDefaultInfo RemoteTimestamp = Nothing +remoteFileDefaultInfo (RemoteRoot info) = info +remoteFileDefaultInfo (RemoteSnapshot info) = Just info +remoteFileDefaultInfo (RemoteMirrors info) = Just info +remoteFileDefaultInfo (RemotePkgTarGz _ info) = Just info +remoteFileDefaultInfo (RemoteIndex pf info) = Just $ formatsLookup pf info + +{------------------------------------------------------------------------------- + Repository proper +-------------------------------------------------------------------------------} + +-- | Repository +-- +-- This is an abstract representation of a repository. It simply provides a way +-- 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 { + -- | Get a file from the server + -- + -- Responsibilies of 'repWithRemote': + -- + -- * Download the file from the repository and make it available at a + -- temporary location + -- * Use the provided file length to protect against endless data attacks. + -- (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.) + -- + -- NOTE: Calls to 'repWithRemote' 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 + + -- | Get a cached file (if available) + , repGetCached :: CachedFile -> IO (Maybe AbsolutePath) + + -- | Get the cached root + -- + -- This is a separate method only because clients must ALWAYS have root + -- information available. + , repGetCachedRoot :: IO AbsolutePath + + -- | Clear all cached data + -- + -- In particular, this should remove the snapshot and the timestamp. + -- It would also be okay, but not required, to delete the index. + , repClearCache :: IO () + + -- | Get a file from the index + -- + -- 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) + + -- | Mirror selection + -- + -- The purpose of 'repWithMirror' is to scope mirror selection. The idea + -- is that if we have + -- + -- > repWithMirror mirrorList $ + -- > someCallback + -- + -- then the repository may pick a mirror before calling @someCallback@, + -- catch exceptions thrown by @someCallback@, and potentially try the + -- callback again with a different mirror. + -- + -- The list of mirrors may be @Nothing@ if we haven't yet downloaded the + -- list of mirrors from the repository, or when our cached list of mirrors + -- is invalid. Of course, if we did download it, then the list of mirrors + -- may still be empty. In this case the repository must fall back to its + -- primary download mechanism. + -- + -- Mirrors as currently defined (in terms of a "base URL") are inherently a + -- HTTP (or related) concept, so in repository implementations such as the + -- local-repo 'repWithMirrors' is probably just an identity operation (see + -- 'ignoreMirrors'). Conversely, HTTP implementations of repositories may + -- have other, out-of-band information (for example, coming from a cabal + -- config file) that they may use to influence mirror selection. + , repWithMirror :: forall a. Maybe [Mirror] -> IO a -> IO a + + -- | Logging + , repLog :: LogMessage -> IO () + + -- | Layout of this repository + , repLayout :: RepoLayout + + -- | Description of the repository (used in the show instance) + , repDescription :: String + } + +instance Show Repository where + show = repDescription + +-- | Helper function to implement 'repWithMirrors'. +mirrorsUnsupported :: Maybe [Mirror] -> IO a -> IO a +mirrorsUnsupported _ = id + +-- | 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 + +-- | Log messages +-- +-- We use a 'RemoteFile' rather than a 'RepoPath' here because we might not have +-- a 'RepoPath' for the file that we were trying to download (that is, for +-- example if the server does not provide an uncompressed tarball, it doesn't +-- make much sense to list the path to that non-existing uncompressed tarball). +data LogMessage = + -- | Root information was updated + -- + -- This message is issued when the root information is updated as part of + -- the normal check for updates procedure. If the root information is + -- updated because of a verification error WarningVerificationError is + -- issued instead. + LogRootUpdated + + -- | A verification error + -- + -- Verification errors can be temporary, and may be resolved later; hence + -- these are just warnings. (Verification errors that cannot be resolved + -- are thrown as exceptions.) + | LogVerificationError VerificationError + + -- | Download a file from a repository + | LogDownloading (Some RemoteFile) + + -- | Incrementally updating a file from a repository + | LogUpdating (Some RemoteFile) + + -- | Selected a particular mirror + | LogSelectedMirror MirrorDescription + + -- | Updating a file failed + -- (we will try again by downloading it whole) + | LogUpdateFailed (Some RemoteFile) UpdateFailure + + -- | We got an exception with a particular mirror + -- (we will try with a different mirror if any are available) + | LogMirrorFailed MirrorDescription SomeException + +-- | 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 + + -- | 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 + | UpdateFailed SomeException + +{------------------------------------------------------------------------------- + Exceptions thrown by specific Repository implementations +-------------------------------------------------------------------------------} + +-- | Repository-specific exceptions +-- +-- For instance, for repositories using HTTP this might correspond to a 404; +-- for local repositories this might correspond to file-not-found, etc. +data SomeRemoteError :: * where + SomeRemoteError :: Exception e => e -> SomeRemoteError + deriving (Typeable) + +#if MIN_VERSION_base(4,8,0) +deriving instance Show SomeRemoteError +instance Exception SomeRemoteError where displayException = pretty +#else +instance Exception SomeRemoteError +instance Show SomeRemoteError where show = pretty +#endif + +instance Pretty SomeRemoteError where + pretty (SomeRemoteError ex) = displayException ex + +{------------------------------------------------------------------------------- + Paths +-------------------------------------------------------------------------------} + +remoteRepoPath :: RepoLayout -> RemoteFile fs -> Formats fs RepoPath +remoteRepoPath RepoLayout{..} = go + where + go :: RemoteFile fs -> Formats fs RepoPath + go RemoteTimestamp = FsUn $ repoLayoutTimestamp + go (RemoteRoot _) = FsUn $ repoLayoutRoot + go (RemoteSnapshot _) = FsUn $ repoLayoutSnapshot + go (RemoteMirrors _) = FsUn $ repoLayoutMirrors + go (RemotePkgTarGz pId _) = FsGz $ repoLayoutPkgTarGz pId + go (RemoteIndex _ lens) = formatsMap goIndex lens + + goIndex :: Format f -> a -> RepoPath + goIndex FUn _ = repoLayoutIndexTar + goIndex FGz _ = repoLayoutIndexTarGz + +remoteRepoPath' :: RepoLayout -> RemoteFile fs -> 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 = + -- | This remote file should be cached, and we ask for it by name + CacheAs CachedFile + + -- | 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 + + -- | The index is somewhat special: it should be cached, but we never + -- ask for it directly. + -- + -- Instead, we will ask the Repository for files _from_ the index, which it + -- can serve however it likes. For instance, some repositories might keep + -- 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) + +-- | Which remote files should we cache locally? +mustCache :: RemoteFile fs -> IsCached +mustCache RemoteTimestamp = CacheAs CachedTimestamp +mustCache (RemoteRoot _) = CacheAs CachedRoot +mustCache (RemoteSnapshot _) = CacheAs CachedSnapshot +mustCache (RemoteMirrors _) = CacheAs CachedMirrors +mustCache (RemoteIndex {}) = CacheIndex +mustCache (RemotePkgTarGz _ _) = DontCache + +instance Pretty LogMessage where + pretty LogRootUpdated = + "Root info updated" + pretty (LogVerificationError err) = + "Verification error: " ++ pretty err + pretty (LogDownloading (Some file)) = + "Downloading " ++ pretty file + pretty (LogUpdating (Some file)) = + "Updating " ++ pretty file + pretty (LogSelectedMirror mirror) = + "Selected mirror " ++ mirror + pretty (LogUpdateFailed (Some file) ex) = + "Updating " ++ pretty file ++ " failed (" ++ 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 (UpdateFailed ex) = + displayException ex diff --git a/src/Hackage/Security/Client/Repository/Cache.hs b/src/Hackage/Security/Client/Repository/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/Cache.hs @@ -0,0 +1,181 @@ +-- | The files we cache from the repository +-- +-- Both the Local and the Remote repositories make use of this module. +module Hackage.Security.Client.Repository.Cache ( + Cache(..) + , getCached + , getCachedRoot + , getCachedIndex + , clearCache + , getFromIndex + , cacheRemoteFile + ) where + +import Control.Exception +import Control.Monad +import Codec.Archive.Tar.Index (TarIndex) +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 + +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Formats +import Hackage.Security.TUF +import Hackage.Security.Util.Checked +import Hackage.Security.Util.IO +import Hackage.Security.Util.Path + +-- | Location and layout of the local cache +data Cache = Cache { + cacheRoot :: AbsolutePath + , cacheLayout :: CacheLayout + } + +-- | Cache a previously downloaded remote file +cacheRemoteFile :: Cache -> TempPath -> Format f -> IsCached -> IO () +cacheRemoteFile cache tempPath 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 + 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 + + copyTo :: AbsolutePath -> IO () + copyTo fp = do + createDirectoryIfMissing True (takeDirectory fp) + atomicCopyFile tempPath fp + + ungzTo :: AbsolutePath -> IO () + ungzTo fp = do + createDirectoryIfMissing True (takeDirectory fp) + compressed <- readLazyByteString tempPath + atomicWriteFile fp $ GZip.decompress compressed + +-- | Rebuild the tarball index +-- +-- TODO: Should we attempt to rebuild this incrementally? +-- TODO: Use throwChecked rather than throwUnchecked, and deal with the fallout. +-- See . +rebuildTarIndex :: Cache -> IO () +rebuildTarIndex cache = do + entries <- Tar.read <$> readLazyByteString (cachedIndexTarPath cache) + case TarIndex.build entries of + Left ex -> throwUnchecked ex + Right index -> + atomicWithFile (cachedIndexIdxPath cache) $ \h -> do + hSetBuffering h (BlockBuffering Nothing) + BS.Builder.hPutBuilder h $ TarIndex.serialise index + +-- | Get a cached file (if available) +getCached :: Cache -> CachedFile -> IO (Maybe AbsolutePath) +getCached cache cachedFile = do + exists <- doesFileExist localPath + if exists then return $ Just localPath + else return $ Nothing + where + localPath = cachedFilePath cache cachedFile + +-- | Get the cached index (if available) +getCachedIndex :: Cache -> IO (Maybe AbsolutePath) +getCachedIndex cache = do + exists <- doesFileExist localPath + if exists then return $ Just localPath + else return $ Nothing + where + localPath = cachedIndexTarPath cache + +-- | 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 = 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) + 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 + + -- 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 + +-- | Delete a previously downloaded remote file +clearCache :: Cache -> IO () +clearCache cache = void . handleDoesNotExist $ do + removeFile $ cachedFilePath cache CachedTimestamp + removeFile $ cachedFilePath cache CachedSnapshot + +{------------------------------------------------------------------------------- + Auxiliary: paths +-------------------------------------------------------------------------------} + +cachedFilePath :: Cache -> CachedFile -> AbsolutePath +cachedFilePath Cache{cacheLayout=CacheLayout{..}, ..} file = + anchorCachePath cacheRoot $ go file + where + go :: CachedFile -> CachePath + go CachedRoot = cacheLayoutRoot + go CachedTimestamp = cacheLayoutTimestamp + 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 + +cachedIndexIdxPath :: Cache -> AbsolutePath +cachedIndexIdxPath Cache{..} = + anchorCachePath cacheRoot $ cacheLayoutIndexIdx cacheLayout diff --git a/src/Hackage/Security/Client/Repository/HttpLib.hs b/src/Hackage/Security/Client/Repository/HttpLib.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/HttpLib.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} +-- | Abstracting over HTTP libraries +module Hackage.Security.Client.Repository.HttpLib ( + HttpLib(..) + , HttpRequestHeader(..) + , HttpResponseHeader(..) + , ProxyConfig(..) + -- ** Body reader + , BodyReader + , bodyReaderFromBS + ) where + +import Data.IORef +import Network.URI hiding (uriPath, path) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L + +import Hackage.Security.Util.Checked +import Hackage.Security.Client.Repository (SomeRemoteError) + +{------------------------------------------------------------------------------- + Abstraction over HTTP clients (such as HTTP, http-conduit, etc.) +-------------------------------------------------------------------------------} + +-- | Abstraction over HTTP clients +-- +-- This avoids insisting on a particular implementation (such as the HTTP +-- package) and allows for other implementations (such as a conduit based one). +-- +-- NOTE: Library-specific exceptions MUST be wrapped in 'SomeRemoteError'. +data HttpLib = HttpLib { + -- | Download a file + httpGet :: forall a. Throws SomeRemoteError + => [HttpRequestHeader] + -> URI + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a + + -- | Download a byte range + -- + -- Range is starting and (exclusive) end offset in bytes. + , httpGetRange :: forall a. Throws SomeRemoteError + => [HttpRequestHeader] + -> URI + -> (Int, Int) + -> ([HttpResponseHeader] -> BodyReader -> IO a) + -> IO a + } + +-- | Additional request headers +-- +-- Since different libraries represent headers differently, here we just +-- abstract over the few request headers that we might want to set +data HttpRequestHeader = + -- | Set @Cache-Control: max-age=0@ + HttpRequestMaxAge0 + + -- | 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) + +-- | Response headers +-- +-- Since different libraries represent headers differently, here we just +-- abstract over the few response headers that we might want to know about. +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 +-- +-- Although actually setting the proxy is the purview of the initialization +-- function for individual 'HttpLib' implementations and therefore outside +-- the scope of this module, we offer this 'ProxyConfiguration' type here as a +-- way to uniformly configure proxies across all 'HttpLib's. +data ProxyConfig a = + -- | Don't use a proxy + ProxyConfigNone + + -- | Use this specific proxy + -- + -- Individual HTTP backends use their own types for specifying proxies. + | ProxyConfigUse a + + -- | Use automatic proxy settings + -- + -- What precisely automatic means is 'HttpLib' specific, though + -- typically it will involve looking at the @HTTP_PROXY@ environment + -- variable or the (Windows) registry. + | ProxyConfigAuto + +{------------------------------------------------------------------------------- + Body readers +-------------------------------------------------------------------------------} + +-- | An @IO@ action that represents an incoming response body coming from the +-- server. +-- +-- The action gets a single chunk of data from the response body, or an empty +-- bytestring if no more data is available. +-- +-- This definition is copied from the @http-client@ package. +type BodyReader = IO BS.ByteString + +-- | Construct a 'Body' reader from a lazy bytestring +-- +-- This is appropriate if the lazy bytestring is constructed, say, by calling +-- 'hGetContents' on a network socket, and the chunks of the bytestring +-- correspond to the chunks as they are returned from the OS network layer. +-- +-- If the lazy bytestring needs to be re-chunked this function is NOT suitable. +bodyReaderFromBS :: BS.L.ByteString -> IO BodyReader +bodyReaderFromBS lazyBS = do + chunks <- newIORef $ BS.L.toChunks lazyBS + -- NOTE: Lazy bytestrings invariant: no empty chunks + let br = do bss <- readIORef chunks + case bss of + [] -> return BS.empty + (bs:bss') -> writeIORef chunks bss' >> return bs + return br diff --git a/src/Hackage/Security/Client/Repository/Local.hs b/src/Hackage/Security/Client/Repository/Local.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/Local.hs @@ -0,0 +1,63 @@ +-- | Local repository +module Hackage.Security.Client.Repository.Local ( + LocalRepo + , withRepository + ) where + +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Repository.Cache +import Hackage.Security.Client.Formats +import Hackage.Security.TUF +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty +import Hackage.Security.Util.Some + +-- | Location of the repository +-- +-- Note that we regard the local repository as immutable; we cache files just +-- like we do for remote repositories. +type LocalRepo = Path (Rooted Absolute) + +-- | Initialize the repository (and cleanup resources afterwards) +-- +-- Like a remote repository, a local repository takes a RepoLayout as argument; +-- but where the remote repository interprets this RepoLayout relative to a URL, +-- the local repository interprets it relative to a local directory. +-- +-- 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 + -> IO a +withRepository repo cache repLayout logger callback = callback Repository { + repWithRemote = withRemote repLayout repo cache + , repGetCached = getCached cache + , repGetCachedRoot = getCachedRoot cache + , repClearCache = clearCache cache + , repGetFromIndex = getFromIndex cache (repoIndexLayout repLayout) + , repWithMirror = mirrorsUnsupported + , repLog = logger + , repLayout = repLayout + , 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 + 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 diff --git a/src/Hackage/Security/Client/Repository/Remote.hs b/src/Hackage/Security/Client/Repository/Remote.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Client/Repository/Remote.hs @@ -0,0 +1,646 @@ +-- | An implementation of Repository that talks to repositories over HTTP. +-- +-- This implementation is itself parameterized over a 'HttpClient', so that it +-- it not tied to a specific library; for instance, 'HttpClient' can be +-- implemented with the @HTTP@ library, the @http-client@ libary, or others. +-- +-- It would also be possible to give _other_ Repository implementations that +-- talk to repositories over HTTP, if you want to make other design decisions +-- than we did here, in particular: +-- +-- * We attempt to do incremental downloads of the index when possible. +-- * We reuse the "Repository.Local" to deal with the local cache. +-- * We download @timestamp.json@ and @snapshot.json@ together. This is +-- implemented here because: +-- - One level down (HttpClient) we have no access to the local cache +-- - One level up (Repository API) would require _all_ Repositories to +-- implement this optimization. +module Hackage.Security.Client.Repository.Remote ( + -- * Top-level API + withRepository + , AllowContentCompression(..) + , WantCompressedIndex(..) + -- * File sizes + , FileSize(..) + , fileSizeWithinBounds + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad.Cont +import Control.Monad.Except +import Data.List (nub) +import Network.URI hiding (uriPath, path) +import System.IO +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L + +import Hackage.Security.Client.Formats +import Hackage.Security.Client.Repository +import Hackage.Security.Client.Repository.Cache (Cache) +import Hackage.Security.Client.Repository.HttpLib +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.Some +import qualified Hackage.Security.Client.Repository.Cache as Cache + +{------------------------------------------------------------------------------- + Server capabilities +-------------------------------------------------------------------------------} + +-- | Server capabilities +-- +-- As the library interacts with the server and receives replies, we may +-- discover more information about the server's capabilities; for instance, +-- we may discover that it supports incremental downloads. +newtype ServerCapabilities = SC (MVar ServerCapabilities_) + +-- | Internal type recording the various server capabilities we support +data ServerCapabilities_ = ServerCapabilities { + -- | Does the server support range requests? + serverAcceptRangesBytes :: Bool + + -- | Did the server apply content compression previously? + -- + -- We use this as a heuristic to decide whether we want to do an + -- incremental update of the index or not. + , serverUsedContentCompression :: Bool + } + +newServerCapabilities :: IO ServerCapabilities +newServerCapabilities = SC <$> newMVar ServerCapabilities { + serverAcceptRangesBytes = False + , serverUsedContentCompression = False + } + +updateServerCapabilities :: ServerCapabilities -> [HttpResponseHeader] -> IO () +updateServerCapabilities (SC mv) responseHeaders = modifyMVar_ mv $ \caps -> + return $ caps { + serverAcceptRangesBytes = serverAcceptRangesBytes caps + || HttpResponseAcceptRangesBytes `elem` responseHeaders + , serverUsedContentCompression = serverUsedContentCompression caps + || HttpResponseContentCompression `elem` responseHeaders + } + +checkServerCapability :: MonadIO m + => ServerCapabilities -> (ServerCapabilities_ -> a) -> m a +checkServerCapability (SC mv) f = liftIO $ withMVar mv $ return . f + +{------------------------------------------------------------------------------- + File size +-------------------------------------------------------------------------------} + +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 + + -- | 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 + +fileSizeWithinBounds :: Int -> FileSize -> Bool +fileSizeWithinBounds sz (FileSizeExact sz') = sz <= sz' +fileSizeWithinBounds sz (FileSizeBound sz') = sz <= sz' + +{------------------------------------------------------------------------------- + Top-level API +-------------------------------------------------------------------------------} + +-- | 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. +data AllowContentCompression = + AllowContentCompression + | DisallowContentCompression + +-- | Do we want to a copy of the compressed index? +-- +-- This is important for mirroring clients only. +data WantCompressedIndex = + WantCompressedIndex + | DontNeedCompressedIndex + +-- | Initialize the repository (and cleanup resources afterwards) +-- +-- We allow to specify multiple mirrors to initialize the repository. These +-- are mirrors that can be found "out of band" (out of the scope of the TUF +-- protocol), for example in a @cabal.config@ file. The TUF protocol itself +-- will specify that any of these mirrors can serve a @mirrors.json@ file +-- that itself contains mirrors; we consider these as _additional_ mirrors +-- to the ones that are passed here. +-- +-- NOTE: The list of mirrors should be non-empty (and should typically include +-- the primary server). +-- +-- TODO: In the future we could allow finer control over precisely which +-- mirrors we use (which combination of the mirrors that are passed as arguments +-- 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 + -> AllowContentCompression -- ^ Should we allow HTTP content compression? + -> WantCompressedIndex -- ^ Do we want a copy of the compressed index? + -> Cache -- ^ Location of local cache + -> RepoLayout -- ^ Repository layout + -> (LogMessage -> IO ()) -- ^ Logger + -> (Repository -> IO a) -- ^ Callback + -> IO a +withRepository httpLib + outOfBandMirrors + allowContentCompression + wantCompressedIndex + cache + repLayout + logger + callback + = do + selectedMirror <- newMVar Nothing + caps <- newServerCapabilities + let remoteConfig mirror = RemoteConfig { + cfgLayout = repLayout + , cfgHttpLib = httpLib + , cfgBase = mirror + , cfgCache = cache + , cfgCaps = caps + , cfgLogger = logger + , cfgCompress = allowContentCompression + , cfgWantGz = wantCompressedIndex + } + callback Repository { + repWithRemote = withRemote remoteConfig selectedMirror + , repGetCached = Cache.getCached cache + , repGetCachedRoot = Cache.getCachedRoot cache + , repClearCache = Cache.clearCache cache + , repGetFromIndex = Cache.getFromIndex cache (repoIndexLayout repLayout) + , repWithMirror = withMirror httpLib selectedMirror logger outOfBandMirrors + , repLog = logger + , repLayout = repLayout + , repDescription = "Remote repository at " ++ show outOfBandMirrors + } + +{------------------------------------------------------------------------------- + Implementations of the various methods of Repository +-------------------------------------------------------------------------------} + +-- | 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 +-- scope of 'repWithMirror'. +type SelectedMirror = MVar (Maybe URI) + +-- | Get the selected mirror +-- +-- Throws an exception if no mirror was selected (this would be a bug in the +-- client code). +-- +-- NOTE: Cannot use 'withMVar' here, because the callback would be inside the +-- scope of the withMVar, and there might be further calls to 'withRemote' made +-- by the callback argument to 'withRemote', leading to deadlock. +getSelectedMirror :: SelectedMirror -> IO URI +getSelectedMirror selectedMirror = do + mBaseURI <- readMVar selectedMirror + case mBaseURI of + Nothing -> internalError "Internal error: no mirror selected" + 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 + +-- | HTTP options +-- +-- We want to make sure caches don't transform files in any way (as this will +-- 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 -> [HttpRequestHeader] +httpRequestHeaders RemoteConfig{..} isRetry = + case isRetry of + FirstAttempt -> defaultHeaders + AfterVerificationError -> HttpRequestMaxAge0 : defaultHeaders + where + -- Headers we provide for _every_ attempt, first or not + defaultHeaders :: [HttpRequestHeader] + defaultHeaders = concat [ + [ HttpRequestNoTransform ] + , [ HttpRequestContentCompression + | AllowContentCompression <- [cfgCompress] + ] + ] + +-- | Mirror selection +withMirror :: forall a. + HttpLib -- ^ HTTP client + -> SelectedMirror -- ^ MVar indicating currently mirror + -> (LogMessage -> IO ()) -- ^ Logger + -> [URI] -- ^ Out-of-band mirrors + -> Maybe [Mirror] -- ^ TUF mirrors + -> IO a -- ^ Callback + -> IO a +withMirror HttpLib{..} selectedMirror logger oobMirrors tufMirrors callback = + go orderedMirrors + where + go :: [URI] -> IO a + -- Empty list of mirrors is a bug + go [] = internalError "No mirrors configured" + -- If we only have a single mirror left, let exceptions be thrown up + go [m] = do + logger $ LogSelectedMirror (show m) + select m $ callback + -- Otherwise, catch exceptions and if any were thrown, try with different + -- mirror + go (m:ms) = do + logger $ LogSelectedMirror (show m) + catchChecked (select m callback) $ \ex -> do + logger $ LogMirrorFailed (show m) ex + go ms + + -- TODO: We will want to make the construction of this list configurable. + orderedMirrors :: [URI] + orderedMirrors = nub $ oobMirrors ++ maybe [] (map mirrorUrlBase) tufMirrors + + select :: URI -> IO a -> IO a + select uri = + bracket_ (modifyMVar_ selectedMirror $ \_ -> return $ Just uri) + (modifyMVar_ selectedMirror $ \_ -> return Nothing) + +{------------------------------------------------------------------------------- + Download methods +-------------------------------------------------------------------------------} + +-- | Download method (downloading or updating) +data DownloadMethod fs = + -- | Download this file (we never attempt to update this type of file) + forall f. NeverUpdated { + downloadFormat :: HasFormat fs f + } + + -- | Download this file (we cannot update this file right now) + | forall f. CannotUpdate { + downloadFormat :: HasFormat fs f + , downloadReason :: UpdateFailure + } + + -- | 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. Update { + updateFormat :: HasFormat fs f + , updateInfo :: Trusted FileInfo + , updateLocal :: AbsolutePath + , updateTrailer :: Integer + } + +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 + case cfgWantGz of + WantCompressedIndex -> + exit $ CannotUpdate hasGz UpdateNotUsefulWantsCompressed + DontNeedCompressedIndex -> + return () + + -- 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 + + -- 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 + + -- 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 + + -- File sizes + canCompress <- checkServerCapability cfgCaps serverUsedContentCompression + localSize <- liftIO $ getFileSize cachedIndex + let infoGz = formatsLookup hasGz formats + infoUn = formatsLookup hasUn formats + estCompFactor = case (canCompress, cfgCompress) of + (True, AllowContentCompression) -> 10 + _otherwise -> 1 + estUpdateSize = (fileLength' infoUn - fromIntegral localSize) + `div` estCompFactor + unless (estUpdateSize < fileLength' infoGz) $ + exit $ CannotUpdate hasGz UpdateTooLarge + + -- If all these checks pass try to do an incremental update. + return Update { + updateFormat = hasUn + , updateInfo = infoUn + , updateLocal = cachedIndex + , updateTrailer = trailerLength + } + +-- | 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 = go + where + go :: (Throws VerificationError, Throws SomeRemoteError) + => DownloadMethod fs -> IO a + go NeverUpdated{..} = do + cfgLogger $ LogDownloading (Some remoteFile) + download downloadFormat + go CannotUpdate{..} = do + cfgLogger $ LogUpdateFailed (Some remoteFile) downloadReason + cfgLogger $ LogDownloading (Some remoteFile) + download downloadFormat + go Update{..} = do + cfgLogger $ LogUpdating (Some remoteFile) + -- Attempt to download the file incrementally. + let updateFailed :: SomeException -> IO a + updateFailed ex = do + let failure = UpdateFailed ex + cfgLogger $ LogUpdateFailed (Some remoteFile) failure + go $ CannotUpdate updateFormat failure + + -- 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 + + headers :: [HttpRequestHeader] + headers = httpRequestHeaders cfg isRetry + + -- 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 + httpGet headers uri $ \responseHeaders bodyReader -> do + updateServerCapabilities cfgCaps responseHeaders + execBodyReader targetPath sz h bodyReader + hClose h + verifyAndCache format 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 + updateServerCapabilities cfgCaps responseHeaders + execBodyReader targetPath rangeSz h bodyReader + hClose h + verifyAndCache format tempPath + where + targetPath = TargetPathRepo repoLayoutIndexTar + uri = modifyUriPath cfgBase (`anchorRepoPathRemotely` repoLayoutIndexTar) + RepoLayout{repoLayoutIndexTar} = cfgLayout + + -- | 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 + + HttpLib{..} = cfgHttpLib + +-- | 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 + => TargetPath -- ^ File source (for error msgs only) + -> FileSize -- ^ Maximum file size + -> Handle -- ^ Handle to write data too + -> BodyReader -- ^ The action to give us blocks from the file + -> IO () +execBodyReader file mlen h br = go 0 + where + go :: Int -> IO () + go sz = do + unless (sz `fileSizeWithinBounds` mlen) $ + throwChecked $ VerificationErrorFileTooLarge file + bs <- br + if BS.null bs + then return () + else BS.hPut h bs >> go (sz + BS.length bs) + +{------------------------------------------------------------------------------- + Information about remote files +-------------------------------------------------------------------------------} + +remoteFileURI :: RepoLayout -> URI -> RemoteFile fs -> 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 (RemoteTimestamp) = + FsUn $ FileSizeBound fileSizeBoundTimestamp +remoteFileSize (RemoteRoot mLen) = + FsUn $ maybe (FileSizeBound fileSizeBoundRoot) + (FileSizeExact . fileLength') + mLen +remoteFileSize (RemoteSnapshot len) = + FsUn $ FileSizeExact (fileLength' len) +remoteFileSize (RemoteMirrors len) = + FsUn $ FileSizeExact (fileLength' len) +remoteFileSize (RemoteIndex _ lens) = + fmap (FileSizeExact . fileLength') lens +remoteFileSize (RemotePkgTarGz _pkgId len) = + FsGz $ FileSizeExact (fileLength' len) + +-- | Bound on the size of the timestamp +-- +-- This is intended as a permissive rather than tight bound. +-- +-- The timestamp signed with a single key is 420 bytes; the signature makes up +-- 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 = 4096 + +-- | Bound on the size of the root +-- +-- This is intended as a permissive rather than tight bound. +-- +-- The variable parts of the root metadata are +-- +-- * Signatures, each of which are about 200 bytes +-- * A key environment (mapping from key IDs to public keys), each is of +-- which is also about 200 bytes +-- * Mirrors, root, snapshot, targets, and timestamp role specifications. +-- These contains key IDs, each of which is about 80 bytes. +-- +-- A skeleton root metadata is about 580 bytes. Allowing for +-- +-- * 100 signatures +-- * 100 mirror keys, 1000 root keys, 100 snapshot keys, 1000 target keys, +-- 100 timestamp keys +-- * the corresponding 2300 entries in the key environment +-- +-- 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 = 2 * 1024 * 2014 + +{------------------------------------------------------------------------------- + Configuration +-------------------------------------------------------------------------------} + +-- | Remote repository configuration +-- +-- This is purely for internal convenience. +data RemoteConfig = RemoteConfig { + cfgLayout :: RepoLayout + , cfgHttpLib :: HttpLib + , cfgBase :: URI + , cfgCache :: Cache + , cfgCaps :: ServerCapabilities + , cfgLogger :: LogMessage -> IO () + , cfgCompress :: AllowContentCompression + , cfgWantGz :: WantCompressedIndex + } + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Template for the local file we use to download a URI to +uriTemplate :: URI -> String +uriTemplate = unFragment . takeFileName . uriPath + +fileLength' :: Trusted FileInfo -> Int +fileLength' = fileLength . fileInfoLength . trusted + +{------------------------------------------------------------------------------- + Auxiliary: multiple exit points +-------------------------------------------------------------------------------} + +-- | Multiple exit points +-- +-- We can simulate the imperative code +-- +-- > if (cond1) +-- > return exp1; +-- > if (cond2) +-- > return exp2; +-- > if (cond3) +-- > return exp3; +-- > return exp4; +-- +-- as +-- +-- > choose $ do +-- > when (cond1) $ +-- > exit exp1 +-- > when (cond) $ +-- > exit exp2 +-- > when (cond) +-- > exit exp3 +-- > return exp4 +multipleExitPoints :: Monad m => ExceptT a m a -> m a +multipleExitPoints = liftM aux . runExceptT + where + aux :: Either a a -> a + aux (Left a) = a + aux (Right a) = a + +-- | Function exit point (see 'multipleExitPoints') +exit :: Monad m => e -> ExceptT e m a +exit = throwError diff --git a/src/Hackage/Security/JSON.hs b/src/Hackage/Security/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/JSON.hs @@ -0,0 +1,328 @@ +-- | Hackage-specific wrappers around the Util.JSON module +{-# LANGUAGE CPP #-} +module Hackage.Security.JSON ( + -- * Deserialization errors + DeserializationError(..) + , validate + , verifyType + -- * MonadKeys + , MonadKeys(..) + , addKeys + , withKeys + , lookupKey + , readKeyAsId + -- * Reader monads + , ReadJSON_Keys_Layout + , ReadJSON_Keys_NoLayout + , ReadJSON_NoKeys_NoLayout + , runReadJSON_Keys_Layout + , runReadJSON_Keys_NoLayout + , runReadJSON_NoKeys_NoLayout + -- ** Utility + , parseJSON_Keys_Layout + , parseJSON_Keys_NoLayout + , parseJSON_NoKeys_NoLayout + , readJSON_Keys_Layout + , readJSON_Keys_NoLayout + , readJSON_NoKeys_NoLayout + -- * Writing + , WriteJSON + , runWriteJSON + -- ** Utility + , renderJSON + , renderJSON_NoLayout + , writeJSON + , writeJSON_NoLayout + , writeKeyAsId + -- * Re-exports + , module Hackage.Security.Util.JSON + ) where + +import Control.Arrow (first, second) +import Control.Exception +import Control.Monad.Except +import Control.Monad.Reader +import Data.Functor.Identity +import Data.Typeable (Typeable) +import qualified Data.ByteString.Lazy as BS.L + +import Hackage.Security.Key +import Hackage.Security.Key.Env (KeyEnv) +import Hackage.Security.TUF.Layout +import Hackage.Security.Util.IO +import Hackage.Security.Util.JSON +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty +import Hackage.Security.Util.Some +import Text.JSON.Canonical +import qualified Hackage.Security.Key.Env as KeyEnv + +{------------------------------------------------------------------------------- + Deserialization errors +-------------------------------------------------------------------------------} + +data DeserializationError = + -- | Malformed JSON has syntax errors in the JSON itself + -- (i.e., we cannot even parse it to a JSValue) + DeserializationErrorMalformed String + + -- | Invalid JSON has valid syntax but invalid structure + -- + -- The string gives a hint about what we expected instead + | DeserializationErrorSchema String + + -- | The JSON file contains a key ID of an unknown key + | DeserializationErrorUnknownKey KeyId + + -- | Some verification step failed + | DeserializationErrorValidation String + + -- | Wrong file type + -- + -- Records actual and expected types. + | DeserializationErrorFileType String String + deriving (Typeable) + +#if MIN_VERSION_base(4,8,0) +deriving instance Show DeserializationError +instance Exception DeserializationError where displayException = pretty +#else +instance Show DeserializationError where show = pretty +instance Exception DeserializationError +#endif + +instance Pretty DeserializationError where + pretty (DeserializationErrorMalformed str) = + "Malformed: " ++ str + pretty (DeserializationErrorSchema str) = + "Schema error: " ++ str + pretty (DeserializationErrorUnknownKey kId) = + "Unknown key: " ++ keyIdString kId + pretty (DeserializationErrorValidation str) = + "Invalid: " ++ str + pretty (DeserializationErrorFileType actualType expectedType) = + "Expected file of type " ++ show expectedType + ++ " but got file of type " ++ show actualType + +validate :: MonadError DeserializationError m => String -> Bool -> m () +validate _ True = return () +validate msg False = throwError $ DeserializationErrorValidation msg + +verifyType :: (ReportSchemaErrors m, MonadError DeserializationError m) + => JSValue -> String -> m () +verifyType enc expectedType = do + actualType <- fromJSField enc "_type" + unless (actualType == expectedType) $ + throwError $ DeserializationErrorFileType actualType expectedType + +{------------------------------------------------------------------------------- + Access to keys +-------------------------------------------------------------------------------} + +-- | MonadReader-like monad, specialized to key environments +class (ReportSchemaErrors m, MonadError DeserializationError m) => MonadKeys m where + localKeys :: (KeyEnv -> KeyEnv) -> m a -> m a + askKeys :: m KeyEnv + +readKeyAsId :: MonadKeys m => JSValue -> m (Some PublicKey) +readKeyAsId (JSString kId) = lookupKey (KeyId kId) +readKeyAsId val = expected' "key ID" val + +addKeys :: MonadKeys m => KeyEnv -> m a -> m a +addKeys keys = localKeys (KeyEnv.union keys) + +withKeys :: MonadKeys m => KeyEnv -> m a -> m a +withKeys keys = localKeys (const keys) + +lookupKey :: MonadKeys m => KeyId -> m (Some PublicKey) +lookupKey kId = do + keyEnv <- askKeys + case KeyEnv.lookup kId keyEnv of + Just key -> return key + Nothing -> throwError $ DeserializationErrorUnknownKey kId + +{------------------------------------------------------------------------------- + Reading +-------------------------------------------------------------------------------} + +newtype ReadJSON_Keys_Layout a = ReadJSON_Keys_Layout { + unReadJSON_Keys_Layout :: ExceptT DeserializationError (Reader (RepoLayout, KeyEnv)) a + } + deriving ( Functor + , Applicative + , Monad + , MonadError DeserializationError + ) + +newtype ReadJSON_Keys_NoLayout a = ReadJSON_Keys_NoLayout { + unReadJSON_Keys_NoLayout :: ExceptT DeserializationError (Reader KeyEnv) a + } + deriving ( Functor + , Applicative + , Monad + , MonadError DeserializationError + ) + +newtype ReadJSON_NoKeys_NoLayout a = ReadJSON_NoKeys_NoLayout { + unReadJSON_NoKeys_NoLayout :: Except DeserializationError a + } + deriving ( Functor + , Applicative + , Monad + , MonadError DeserializationError + ) + +instance ReportSchemaErrors ReadJSON_Keys_Layout where + expected str mgot = throwError $ expectedError str mgot +instance ReportSchemaErrors ReadJSON_Keys_NoLayout where + expected str mgot = throwError $ expectedError str mgot +instance ReportSchemaErrors ReadJSON_NoKeys_NoLayout where + expected str mgot = throwError $ expectedError str mgot + +expectedError :: Expected -> Maybe Got -> DeserializationError +expectedError str mgot = DeserializationErrorSchema msg + where + msg = case mgot of + Nothing -> "Expected " ++ str + Just got -> "Expected " ++ str ++ " but got " ++ got + +instance MonadReader RepoLayout ReadJSON_Keys_Layout where + ask = ReadJSON_Keys_Layout $ fst `liftM` ask + local f act = ReadJSON_Keys_Layout $ local (first f) act' + where + act' = unReadJSON_Keys_Layout act + +instance MonadKeys ReadJSON_Keys_Layout where + askKeys = ReadJSON_Keys_Layout $ snd `liftM` ask + localKeys f act = ReadJSON_Keys_Layout $ local (second f) act' + where + act' = unReadJSON_Keys_Layout act + +instance MonadKeys ReadJSON_Keys_NoLayout where + askKeys = ReadJSON_Keys_NoLayout $ ask + localKeys f act = ReadJSON_Keys_NoLayout $ local f act' + where + act' = unReadJSON_Keys_NoLayout act + +runReadJSON_Keys_Layout :: KeyEnv + -> RepoLayout + -> ReadJSON_Keys_Layout a + -> Either DeserializationError a +runReadJSON_Keys_Layout keyEnv repoLayout act = + runReader (runExceptT (unReadJSON_Keys_Layout act)) (repoLayout, keyEnv) + +runReadJSON_Keys_NoLayout :: KeyEnv + -> ReadJSON_Keys_NoLayout a + -> Either DeserializationError a +runReadJSON_Keys_NoLayout keyEnv act = + runReader (runExceptT (unReadJSON_Keys_NoLayout act)) keyEnv + +runReadJSON_NoKeys_NoLayout :: ReadJSON_NoKeys_NoLayout a + -> Either DeserializationError a +runReadJSON_NoKeys_NoLayout act = + runExcept (unReadJSON_NoKeys_NoLayout act) + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +parseJSON_Keys_Layout :: FromJSON ReadJSON_Keys_Layout a + => KeyEnv + -> RepoLayout + -> BS.L.ByteString + -> Either DeserializationError a +parseJSON_Keys_Layout keyEnv repoLayout bs = + case parseCanonicalJSON bs of + Left err -> Left (DeserializationErrorMalformed err) + Right val -> runReadJSON_Keys_Layout keyEnv repoLayout (fromJSON val) + +parseJSON_Keys_NoLayout :: FromJSON ReadJSON_Keys_NoLayout a + => KeyEnv + -> BS.L.ByteString + -> Either DeserializationError a +parseJSON_Keys_NoLayout keyEnv bs = + case parseCanonicalJSON bs of + Left err -> Left (DeserializationErrorMalformed err) + Right val -> runReadJSON_Keys_NoLayout keyEnv (fromJSON val) + +parseJSON_NoKeys_NoLayout :: FromJSON ReadJSON_NoKeys_NoLayout a + => BS.L.ByteString + -> Either DeserializationError a +parseJSON_NoKeys_NoLayout bs = + case parseCanonicalJSON bs of + Left err -> Left (DeserializationErrorMalformed err) + Right val -> runReadJSON_NoKeys_NoLayout (fromJSON val) + +readJSON_Keys_Layout :: ( IsFileSystemRoot root + , FromJSON ReadJSON_Keys_Layout a + ) + => KeyEnv + -> RepoLayout + -> Path (Rooted root) + -> IO (Either DeserializationError a) +readJSON_Keys_Layout keyEnv repoLayout fp = do + withFileInReadMode fp $ \h -> do + bs <- BS.L.hGetContents h + evaluate $ parseJSON_Keys_Layout keyEnv repoLayout bs + +readJSON_Keys_NoLayout :: ( IsFileSystemRoot root + , FromJSON ReadJSON_Keys_NoLayout a + ) + => KeyEnv + -> Path (Rooted root) + -> IO (Either DeserializationError a) +readJSON_Keys_NoLayout keyEnv fp = do + withFileInReadMode fp $ \h -> do + bs <- BS.L.hGetContents h + evaluate $ parseJSON_Keys_NoLayout keyEnv bs + +readJSON_NoKeys_NoLayout :: ( IsFileSystemRoot root + , FromJSON ReadJSON_NoKeys_NoLayout a + ) + => Path (Rooted root) + -> IO (Either DeserializationError a) +readJSON_NoKeys_NoLayout fp = do + withFileInReadMode fp $ \h -> do + bs <- BS.L.hGetContents h + evaluate $ parseJSON_NoKeys_NoLayout bs + +{------------------------------------------------------------------------------- + Writing +-------------------------------------------------------------------------------} + +newtype WriteJSON a = WriteJSON { + unWriteJSON :: Reader RepoLayout a + } + deriving ( Functor + , Applicative + , Monad + , MonadReader RepoLayout + ) + +runWriteJSON :: RepoLayout -> WriteJSON a -> a +runWriteJSON repoLayout act = runReader (unWriteJSON act) repoLayout + +{------------------------------------------------------------------------------- + Writing: Utility +-------------------------------------------------------------------------------} + +-- | Render to canonical JSON format +renderJSON :: ToJSON WriteJSON a => RepoLayout -> a -> BS.L.ByteString +renderJSON repoLayout = renderCanonicalJSON . runWriteJSON repoLayout . toJSON + +-- | Variation on 'renderJSON' for files that don't require the repo layout +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_NoLayout :: ToJSON Identity a => AbsolutePath -> a -> IO () +writeJSON_NoLayout fp a = + atomicWithFile fp $ \h -> + BS.L.hPut h $ renderJSON_NoLayout a + +writeKeyAsId :: Some PublicKey -> JSValue +writeKeyAsId = JSString . keyIdString . someKeyId diff --git a/src/Hackage/Security/Key.hs b/src/Hackage/Security/Key.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Key.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +module Hackage.Security.Key ( + -- * Key types + Ed25519 + -- * Types abstracting over key types + , Key(..) + , PublicKey(..) + , PrivateKey(..) + -- * Key types in isolation + , KeyType(..) + -- * Hiding key types + , somePublicKey + , somePublicKeyType + , someKeyId + -- * Operations on keys + , publicKey + , privateKey + , createKey + , createKey' + -- * Key IDs + , KeyId(..) + , HasKeyId(..) + -- * Signing + , sign + , verify + ) where + +import Control.Monad +import Data.Digest.Pure.SHA +import Data.Functor.Identity +import Data.Typeable (Typeable) +import Text.JSON.Canonical +import qualified Crypto.Sign.Ed25519 as Ed25519 +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L + +#if !MIN_VERSION_base(4,7,0) +import qualified Data.Typeable as Typeable +#endif + +import Hackage.Security.Util.JSON +import Hackage.Security.Util.Some +import Hackage.Security.Util.TypedEmbedded +import qualified Hackage.Security.Util.Base64 as B64 + +{------------------------------------------------------------------------------- + Generalization over key types +-------------------------------------------------------------------------------} + +data Ed25519 + +data Key a where + KeyEd25519 :: Ed25519.PublicKey -> Ed25519.SecretKey -> Key Ed25519 + deriving (Typeable) + +data PublicKey a where + PublicKeyEd25519 :: Ed25519.PublicKey -> PublicKey Ed25519 + deriving (Typeable) + +data PrivateKey a where + PrivateKeyEd25519 :: Ed25519.SecretKey -> PrivateKey Ed25519 + deriving (Typeable) + +deriving instance Show (Key typ) +deriving instance Show (PublicKey typ) +deriving instance Show (PrivateKey typ) + +deriving instance Eq (Key typ) +deriving instance Eq (PublicKey typ) +deriving instance Eq (PrivateKey typ) + +instance SomeShow Key where someShow = DictShow +instance SomeShow PublicKey where someShow = DictShow +instance SomeShow PrivateKey where someShow = DictShow + +instance SomeEq Key where someEq = DictEq +instance SomeEq PublicKey where someEq = DictEq +instance SomeEq PrivateKey where someEq = DictEq + +publicKey :: Key a -> PublicKey a +publicKey (KeyEd25519 pub _pri) = PublicKeyEd25519 pub + +privateKey :: Key a -> PrivateKey a +privateKey (KeyEd25519 _pub pri) = PrivateKeyEd25519 pri + +{------------------------------------------------------------------------------- + Sometimes it's useful to talk about the type of a key independent of the key +-------------------------------------------------------------------------------} + +data KeyType typ where + KeyTypeEd25519 :: KeyType Ed25519 + +deriving instance Show (KeyType typ) +deriving instance Eq (KeyType typ) + +instance SomeShow KeyType where someShow = DictShow +instance SomeEq KeyType where someEq = DictEq + +instance Unify KeyType where + unify KeyTypeEd25519 KeyTypeEd25519 = Just Refl + +type instance TypeOf Key = KeyType +type instance TypeOf PublicKey = KeyType +type instance TypeOf PrivateKey = KeyType + +instance Typed Key where + typeOf (KeyEd25519 _ _) = KeyTypeEd25519 + +instance Typed PublicKey where + typeOf (PublicKeyEd25519 _) = KeyTypeEd25519 + +instance Typed PrivateKey where + typeOf (PrivateKeyEd25519 _) = KeyTypeEd25519 + +{------------------------------------------------------------------------------- + We don't always know the key type +-------------------------------------------------------------------------------} + +somePublicKey :: Some Key -> Some PublicKey +somePublicKey (Some key) = Some (publicKey key) + +somePublicKeyType :: Some PublicKey -> Some KeyType +somePublicKeyType (Some pub) = Some (typeOf pub) + +someKeyId :: HasKeyId key => Some key -> KeyId +someKeyId (Some a) = keyId a + +{------------------------------------------------------------------------------- + Creating keys +-------------------------------------------------------------------------------} + +createKey :: KeyType key -> IO (Key key) +createKey KeyTypeEd25519 = uncurry KeyEd25519 <$> Ed25519.createKeypair + +createKey' :: KeyType key -> IO (Some Key) +createKey' = liftM Some . createKey + +{------------------------------------------------------------------------------- + Key IDs +-------------------------------------------------------------------------------} + +-- | The key ID of a key, by definition, is the hexdigest of the SHA-256 hash of +-- the canonical JSON form of the key where the private object key is excluded. +-- +-- NOTE: The FromJSON and ToJSON instances for KeyId are ntentially omitted. Use +-- writeKeyAsId instead. +newtype KeyId = KeyId { keyIdString :: String } + deriving (Show, Eq, Ord) + +instance Monad m => ToObjectKey m KeyId where + toObjectKey = return . keyIdString + +instance Monad m => FromObjectKey m KeyId where + fromObjectKey = return . KeyId + +-- | Compute the key ID of a key +class HasKeyId key where + keyId :: key typ -> KeyId + +instance HasKeyId PublicKey where + keyId = KeyId + . showDigest + . sha256 + . renderCanonicalJSON + . runIdentity + . toJSON + +instance HasKeyId Key where + keyId = keyId . publicKey + +{------------------------------------------------------------------------------- + Signing +-------------------------------------------------------------------------------} + +-- | Sign a bytestring and return the signature +-- +-- TODO: It is unfortunate that we have to convert to a strict bytestring for +-- ed25519 +sign :: PrivateKey typ -> BS.L.ByteString -> BS.ByteString +sign (PrivateKeyEd25519 pri) = + Ed25519.unSignature . Ed25519.sign' pri . BS.concat . BS.L.toChunks + +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) + +{------------------------------------------------------------------------------- + JSON encoding and decoding +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m (Key typ) where + toJSON key = case key of + KeyEd25519 pub pri -> + enc "ed25519" (Ed25519.unPublicKey pub) (Ed25519.unSecretKey pri) + where + enc :: String -> BS.ByteString -> BS.ByteString -> m JSValue + enc tag pub pri = mkObject [ + ("keytype", return $ JSString tag) + , ("keyval", mkObject [ + ("public", toJSON (B64.fromByteString pub)) + , ("private", toJSON (B64.fromByteString pri)) + ]) + ] + +instance ReportSchemaErrors m => FromJSON m (Some Key) where + fromJSON enc = do + (tag, pub, pri) <- dec enc + case tag of + "ed25519" -> return . Some $ + KeyEd25519 (Ed25519.PublicKey pub) (Ed25519.SecretKey pri) + _otherwise -> + expected "valid key type" (Just tag) + where + dec :: JSValue -> m (String, BS.ByteString, BS.ByteString) + dec obj = do + tag <- fromJSField obj "keytype" + val <- fromJSField obj "keyval" + pub <- fromJSField val "public" + pri <- fromJSField val "private" + return (tag, B64.toByteString pub, B64.toByteString pri) + +instance Monad m => ToJSON m (PublicKey typ) where + toJSON key = case key of + PublicKeyEd25519 pub -> + enc "ed25519" (Ed25519.unPublicKey pub) + where + enc :: String -> BS.ByteString -> m JSValue + enc tag pub = mkObject [ + ("keytype", return $ JSString tag) + , ("keyval", mkObject [ + ("public", toJSON (B64.fromByteString pub)) + ]) + ] + +instance Monad m => ToJSON m (Some Key) where toJSON (Some a) = toJSON a +instance Monad m => ToJSON m (Some PublicKey) where toJSON (Some a) = toJSON a +instance Monad m => ToJSON m (Some KeyType) where toJSON (Some a) = toJSON a + +instance ReportSchemaErrors m => FromJSON m (Some PublicKey) where + fromJSON enc = do + (tag, pub) <- dec enc + case tag of + "ed25519" -> return . Some $ + PublicKeyEd25519 (Ed25519.PublicKey pub) + _otherwise -> + expected "valid key type" (Just tag) + where + dec :: JSValue -> m (String, BS.ByteString) + dec obj = do + tag <- fromJSField obj "keytype" + val <- fromJSField obj "keyval" + pub <- fromJSField val "public" + return (tag, B64.toByteString pub) + +instance Monad m => ToJSON m (KeyType typ) where + toJSON KeyTypeEd25519 = return $ JSString "ed25519" + +instance ReportSchemaErrors m => FromJSON m (Some KeyType) where + fromJSON enc = do + tag <- fromJSON enc + case tag of + "ed25519" -> return . Some $ KeyTypeEd25519 + _otherwise -> expected "valid key type" (Just tag) + +{------------------------------------------------------------------------------- + Orphans + + Pre-7.8 (base 4.7) we cannot have Typeable instance for higher-kinded types. + Instead, here we provide some instance for specific instantiations. +-------------------------------------------------------------------------------} + +#if !MIN_VERSION_base(4,7,0) +tyConKey, tyConPublicKey, tyConPrivateKey :: Typeable.TyCon +tyConKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "Key" +tyConPublicKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PublicKey" +tyConPrivateKey = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Key" "PrivateKey" + +instance Typeable (Some Key) where + typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConKey []] + +instance Typeable (Some PublicKey) where + typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPublicKey []] + +instance Typeable (Some PrivateKey) where + typeOf _ = Typeable.mkTyConApp tyConSome [Typeable.mkTyConApp tyConPrivateKey []] +#endif diff --git a/src/Hackage/Security/Key/Env.hs b/src/Hackage/Security/Key/Env.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Key/Env.hs @@ -0,0 +1,90 @@ +module Hackage.Security.Key.Env ( + KeyEnv -- opaque + , keyEnvMap + -- * Convenience constructors + , fromPublicKeys + , fromKeys + -- * The usual accessors + , empty + , null + , insert + , lookup + , union + ) where + +import Prelude hiding (lookup, null) +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map + +import Hackage.Security.Key +import Hackage.Security.Util.JSON +import Hackage.Security.Util.Some + +{------------------------------------------------------------------------------- + Main datatype +-------------------------------------------------------------------------------} + +-- | A key environment is a mapping from key IDs to the corresponding keys. +-- +-- It should satisfy the invariant that these key IDs actually match the keys; +-- see 'checkKeyEnvInvariant'. +newtype KeyEnv = KeyEnv { + keyEnvMap :: Map KeyId (Some PublicKey) + } + deriving (Show) + +-- | Verify that each key ID is mapped to a key with that ID +checkKeyEnvInvariant :: KeyEnv -> Bool +checkKeyEnvInvariant = all (uncurry go) . Map.toList . keyEnvMap + where + go :: KeyId -> Some PublicKey -> Bool + go kId key = kId == someKeyId key + +{------------------------------------------------------------------------------- + Convenience constructors +-------------------------------------------------------------------------------} + +fromPublicKeys :: [Some PublicKey] -> KeyEnv +fromPublicKeys = KeyEnv . Map.fromList . map aux + where + aux :: Some PublicKey -> (KeyId, Some PublicKey) + aux pub = (someKeyId pub, pub) + +fromKeys :: [Some Key] -> KeyEnv +fromKeys = fromPublicKeys . map somePublicKey + +{------------------------------------------------------------------------------- + The usual accessors +-------------------------------------------------------------------------------} + +empty :: KeyEnv +empty = KeyEnv Map.empty + +null :: KeyEnv -> Bool +null (KeyEnv env) = Map.null env + +insert :: Some PublicKey -> KeyEnv -> KeyEnv +insert key (KeyEnv env) = KeyEnv $ Map.insert (someKeyId key) key env + +lookup :: KeyId -> KeyEnv -> Maybe (Some PublicKey) +lookup kId (KeyEnv env) = Map.lookup kId env + +union :: KeyEnv -> KeyEnv -> KeyEnv +union (KeyEnv env) (KeyEnv env') = KeyEnv (env `Map.union` env') + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m KeyEnv where + toJSON (KeyEnv keyEnv) = toJSON keyEnv + +instance ReportSchemaErrors m => FromJSON m KeyEnv where + fromJSON enc = do + keyEnv <- KeyEnv <$> fromJSON enc + -- We should really use 'validate', but that causes module import cycles. + -- Sigh. + unless (checkKeyEnvInvariant keyEnv) $ + expected "valid key environment" Nothing + return keyEnv diff --git a/src/Hackage/Security/Server.hs b/src/Hackage/Security/Server.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Server.hs @@ -0,0 +1,29 @@ +-- | Main entry point into the Hackage Security framework for clients +module Hackage.Security.Server ( + -- * Re-exports + module Hackage.Security.JSON + , module Hackage.Security.Key + , module Hackage.Security.TUF + ) where + +import Hackage.Security.JSON ( + ToJSON(..) + , FromJSON(..) + , DeserializationError(..) + , ReadJSON_Keys_Layout + , ReadJSON_Keys_NoLayout + , ReadJSON_NoKeys_NoLayout + , parseJSON_Keys_Layout + , parseJSON_Keys_NoLayout + , parseJSON_NoKeys_NoLayout + , readJSON_Keys_Layout + , readJSON_Keys_NoLayout + , readJSON_NoKeys_NoLayout + , WriteJSON + , renderJSON + , renderJSON_NoLayout + , writeJSON + , writeJSON_NoLayout + ) +import Hackage.Security.Key +import Hackage.Security.TUF diff --git a/src/Hackage/Security/TUF.hs b/src/Hackage/Security/TUF.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF.hs @@ -0,0 +1,35 @@ +-- | Export all the TUF datatypes +module Hackage.Security.TUF ( + module Hackage.Security.TUF.Common + , module Hackage.Security.TUF.FileInfo + , module Hackage.Security.TUF.FileMap + , module Hackage.Security.TUF.Header + , module Hackage.Security.TUF.Layout + , module Hackage.Security.TUF.Mirrors + , module Hackage.Security.TUF.Patterns + , module Hackage.Security.TUF.Root + , module Hackage.Security.TUF.Signed + , module Hackage.Security.TUF.Snapshot + , module Hackage.Security.TUF.Targets + , module Hackage.Security.TUF.Timestamp + ) where + +import Hackage.Security.TUF.Common +import Hackage.Security.TUF.FileInfo +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Mirrors +import Hackage.Security.TUF.Patterns +import Hackage.Security.TUF.Root +import Hackage.Security.TUF.Signed +import Hackage.Security.TUF.Snapshot +import Hackage.Security.TUF.Targets +import Hackage.Security.TUF.Timestamp + +-- FileMap is intended for qualified imports, so we only export a subset +import Hackage.Security.TUF.FileMap ( + FileMap + , TargetPath(..) + , FileChange(..) + , fileMapChanges + ) diff --git a/src/Hackage/Security/TUF/Common.hs b/src/Hackage/Security/TUF/Common.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Common.hs @@ -0,0 +1,53 @@ +-- | Simple type wrappers +module Hackage.Security.TUF.Common ( + -- * Types + FileLength(..) + , Hash(..) + , KeyThreshold(..) + ) where + +import Hackage.Security.JSON + +{------------------------------------------------------------------------------- + Simple types +-------------------------------------------------------------------------------} + +-- | File length +-- +-- Having verified file length information means we can protect against +-- endless data attacks and similar. +newtype FileLength = FileLength { fileLength :: Int } + 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 + deriving (Eq, Ord, Show) + +-- | File hash +newtype Hash = Hash String + deriving (Eq, Ord, Show) + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m KeyThreshold where + toJSON (KeyThreshold i) = toJSON i + +instance Monad m => ToJSON m FileLength where + toJSON (FileLength i) = toJSON i + +instance Monad m => ToJSON m Hash where + toJSON (Hash str) = toJSON str + +instance ReportSchemaErrors m => FromJSON m KeyThreshold where + fromJSON enc = KeyThreshold <$> fromJSON enc + +instance ReportSchemaErrors m => FromJSON m FileLength where + fromJSON enc = FileLength <$> fromJSON enc + +instance ReportSchemaErrors m => FromJSON m Hash where + fromJSON enc = Hash <$> fromJSON enc diff --git a/src/Hackage/Security/TUF/FileInfo.hs b/src/Hackage/Security/TUF/FileInfo.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/FileInfo.hs @@ -0,0 +1,98 @@ +-- | Information about files +module Hackage.Security.TUF.FileInfo ( + FileInfo(..) + , HashFn(..) + , Hash(..) + -- * Utility + , fileInfo + , computeFileInfo + , knownFileInfoEqual + ) where + +import Prelude hiding (lookup) +import Data.Map (Map) +import Data.Digest.Pure.SHA +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS.L + +import Hackage.Security.JSON +import Hackage.Security.TUF.Common +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +data HashFn = HashFnSHA256 + deriving (Show, Eq, Ord) + +-- | File information +-- +-- This intentionally does not have an 'Eq' instance; see 'knownFileInfoEqual' +-- and 'verifyFileInfo' instead. +-- +-- NOTE: Throughout we compute file information always over the raw bytes. +-- For example, when @timestamp.json@ lists the hash of @snapshot.json@, this +-- hash is computed over the actual @snapshot.json@ file (as opposed to the +-- canonical form of the embedded JSON). This brings it in line with the hash +-- computed over target files, where that is the only choice available. +data FileInfo = FileInfo { + fileInfoLength :: FileLength + , fileInfoHashes :: Map HashFn Hash + } + deriving (Show) + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +-- | Compute 'FileInfo' +-- +-- 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. +fileInfo :: BS.L.ByteString -> FileInfo +fileInfo bs = FileInfo { + fileInfoLength = FileLength . fromIntegral $ BS.L.length bs + , fileInfoHashes = Map.fromList [ + (HashFnSHA256, Hash $ showDigest (sha256 bs)) + ] + } + +-- | Compute 'FileInfo' +computeFileInfo :: IsFileSystemRoot root => Path (Rooted root) -> IO FileInfo +computeFileInfo fp = fileInfo <$> readLazyByteString fp + +-- | Compare known file info +-- +-- This should be used only when the FileInfo is already known. If we want to +-- compare known FileInfo against a file on disk we should delay until we know +-- have confirmed that the file lengths don't match (see 'verifyFileInfo'). +knownFileInfoEqual :: FileInfo -> FileInfo -> Bool +knownFileInfoEqual a b = (==) (fileInfoLength a, fileInfoHashes a) + (fileInfoLength b, fileInfoHashes b) + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToObjectKey m HashFn where + toObjectKey HashFnSHA256 = return "sha256" + +instance ReportSchemaErrors m => FromObjectKey m HashFn where + fromObjectKey "sha256" = return HashFnSHA256 + fromObjectKey str = expected "valid hash function" (Just str) + +instance Monad m => ToJSON m FileInfo where + toJSON FileInfo{..} = mkObject [ + ("length", toJSON fileInfoLength) + , ("hashes", toJSON fileInfoHashes) + ] + +instance ReportSchemaErrors m => FromJSON m FileInfo where + fromJSON enc = do + fileInfoLength <- fromJSField enc "length" + fileInfoHashes <- fromJSField enc "hashes" + return FileInfo{..} diff --git a/src/Hackage/Security/TUF/FileMap.hs b/src/Hackage/Security/TUF/FileMap.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/FileMap.hs @@ -0,0 +1,134 @@ +-- | Information about files +-- +-- Intended to be double imported +-- +-- > import Hackage.Security.TUF.FileMap (FileMap) +-- > import qualified Hackage.Security.TUF.FileMap as FileMap +module Hackage.Security.TUF.FileMap ( + FileMap -- opaque + , TargetPath(..) + -- * Standard accessors + , empty + , lookup + , (!) + , insert + , fromList + -- * Convenience accessors + , lookupM + -- * Comparing file maps + , FileChange(..) + , fileMapChanges + ) where + +import Prelude hiding (lookup) +import Control.Arrow (second) +import Data.Map (Map) +import qualified Data.Map as Map + +import Hackage.Security.JSON +import Hackage.Security.TUF.FileInfo +import Hackage.Security.TUF.Layout +import Hackage.Security.Util.Path +import Hackage.Security.Util.Pretty + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +-- | Mapping from paths to file info +-- +-- File maps are used in target files; the paths are relative to the location +-- of the target files containing the file map. +newtype FileMap = FileMap { fileMap :: Map TargetPath FileInfo } + deriving (Show) + +-- | Entries in 'FileMap' either talk about the repository or the index +data TargetPath = + TargetPathRepo RepoPath + | TargetPathIndex IndexPath + deriving (Show, Eq, Ord) + +instance Pretty TargetPath where + pretty (TargetPathRepo path) = pretty path + pretty (TargetPathIndex path) = pretty path + +{------------------------------------------------------------------------------- + Standard accessors +-------------------------------------------------------------------------------} + +empty :: FileMap +empty = FileMap Map.empty + +lookup :: TargetPath -> FileMap -> Maybe FileInfo +lookup fp = Map.lookup fp . fileMap + +(!) :: FileMap -> TargetPath -> FileInfo +fm ! fp = fileMap fm Map.! fp + +insert :: TargetPath -> FileInfo -> FileMap -> FileMap +insert fp nfo = FileMap . Map.insert fp nfo . fileMap + +fromList :: [(TargetPath, FileInfo)] -> FileMap +fromList = FileMap . Map.fromList + +{------------------------------------------------------------------------------- + Convenience accessors +-------------------------------------------------------------------------------} + +lookupM :: Monad m => FileMap -> TargetPath -> m FileInfo +lookupM m fp = + case lookup fp m of + Nothing -> fail $ "No entry for " ++ pretty fp ++ " in filemap" + Just nfo -> return nfo + +{------------------------------------------------------------------------------- + Comparing filemaps +-------------------------------------------------------------------------------} + +data FileChange = + -- | File got added or modified; we record the new file info + FileChanged FileInfo + + -- | File got deleted + | FileDeleted + deriving (Show) + +fileMapChanges :: FileMap -- ^ Old + -> FileMap -- ^ New + -> Map TargetPath FileChange +fileMapChanges (FileMap a) (FileMap b) = + Map.fromList $ go (Map.toList a) (Map.toList b) + where + -- Assumes the old and new lists are sorted alphabetically + -- (Map.toList guarantees this) + go :: [(TargetPath, FileInfo)] + -> [(TargetPath, FileInfo)] + -> [(TargetPath, FileChange)] + go [] new = map (second FileChanged) new + go old [] = map (second (const FileDeleted)) old + go old@((fp, nfo):old') new@((fp', nfo'):new') + | fp < fp' = (fp , FileDeleted ) : go old' new + | fp > fp' = (fp', FileChanged nfo') : go old new' + | knownFileInfoEqual nfo nfo' = (fp , FileChanged nfo') : go old' new' + | otherwise = go old' new' + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m FileMap where + toJSON (FileMap metaFiles) = toJSON metaFiles + +instance ReportSchemaErrors m => FromJSON m FileMap where + fromJSON enc = FileMap <$> fromJSON enc + +instance Monad m => ToObjectKey m TargetPath where + toObjectKey = return . pretty + +instance ReportSchemaErrors m => FromObjectKey m TargetPath where + fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) = + return . TargetPathRepo . rootPath Rooted . fromUnrootedFilePath $ path + fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) = + return . TargetPathIndex . rootPath Rooted . fromUnrootedFilePath $ path + fromObjectKey str = + expected "target path" (Just str) diff --git a/src/Hackage/Security/TUF/Header.hs b/src/Hackage/Security/TUF/Header.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Header.hs @@ -0,0 +1,119 @@ +-- | Header used by all TUF types +module Hackage.Security.TUF.Header ( + HasHeader(..) + , FileVersion(..) + , FileExpires(..) + , Header(..) + -- ** Utility + , expiresInDays + , expiresNever + , isExpired + , versionInitial + , versionIncrement + ) where + +import Data.Time +import Data.Typeable (Typeable) + +import Hackage.Security.JSON +import Hackage.Security.Util.Lens + +{------------------------------------------------------------------------------- + TUF header +-------------------------------------------------------------------------------} + +class HasHeader a where + -- | File expiry date + fileExpires :: Lens' a FileExpires + + -- | File version (monotonically increasing counter) + fileVersion :: Lens' a FileVersion + +-- | File version +-- +-- The file version is a flat integer which must monotonically increase on +-- every file update. +-- +-- '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 + deriving (Eq, Ord, Typeable) + +instance Show FileVersion where + show (FileVersion v) = show v + +instance Read FileVersion where + readsPrec p = map (\(v, xs) -> (FileVersion v, xs)) . readsPrec p + +-- | File expiry date +-- +-- A 'Nothing' value here means no expiry. That makes it possible to set some +-- files to never expire. (Note that not having the Maybe in the type here still +-- allows that, because you could set an expiry date 2000 years into the future. +-- By having the Maybe here we avoid the _need_ for such encoding issues.) +newtype FileExpires = FileExpires (Maybe UTCTime) + deriving (Eq, Ord, Show, Typeable) + +-- | Occassionally it is useful to read only a header from a file. +-- +-- 'HeaderOnly' intentionally only has a 'FromJSON' instance (no 'ToJSON'). +data Header = Header { + headerExpires :: FileExpires + , headerVersion :: FileVersion + } + +instance HasHeader Header where + fileExpires f x = (\y -> x { headerExpires = y }) <$> f (headerExpires x) + fileVersion f x = (\y -> x { headerVersion = y }) <$> f (headerVersion x) + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +expiresNever :: FileExpires +expiresNever = FileExpires Nothing + +expiresInDays :: UTCTime -> Integer -> FileExpires +expiresInDays now n = + FileExpires . Just $ addUTCTime (fromInteger n * oneDay) now + +isExpired :: UTCTime -> FileExpires -> Bool +isExpired _ (FileExpires Nothing) = False +isExpired now (FileExpires (Just e)) = e < now + +versionInitial :: FileVersion +versionInitial = FileVersion 1 + +versionIncrement :: FileVersion -> FileVersion +versionIncrement (FileVersion i) = FileVersion (i + 1) + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m FileVersion where + toJSON (FileVersion i) = toJSON i + +instance Monad m => ToJSON m FileExpires where + toJSON (FileExpires (Just e)) = toJSON e + toJSON (FileExpires Nothing) = return JSNull + +instance ReportSchemaErrors m => FromJSON m FileVersion where + fromJSON enc = FileVersion <$> fromJSON enc + +instance ReportSchemaErrors m => FromJSON m FileExpires where + fromJSON JSNull = return $ FileExpires Nothing + fromJSON enc = FileExpires . Just <$> fromJSON enc + +instance ReportSchemaErrors m => FromJSON m Header where + fromJSON enc = do + headerExpires <- fromJSField enc "expires" + headerVersion <- fromJSField enc "version" + return Header{..} + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +oneDay :: NominalDiffTime +oneDay = 24 * 60 * 60 diff --git a/src/Hackage/Security/TUF/Layout.hs b/src/Hackage/Security/TUF/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Layout.hs @@ -0,0 +1,228 @@ +module Hackage.Security.TUF.Layout ( + -- * Repository layout + RepoRoot + , RepoPath + , RepoLayout(..) + , hackageRepoLayout + , cabalLocalRepoLayout + , anchorRepoPathLocally + , anchorRepoPathRemotely + -- * Index tarball layout + , IndexRoot + , IndexPath + , IndexLayout(..) + , hackageIndexLayout + -- * Cache layout + , CacheRoot + , CachePath + , CacheLayout(..) + , cabalCacheLayout + , anchorCachePath + ) where + +import Distribution.Package +import Distribution.Text + +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + Repository layout +-------------------------------------------------------------------------------} + +-- | The root of the repository +-- +-- Repository roots can be anchored at a remote URL or a local directory. +-- +-- Note that even for remote repos 'RepoRoot' is (potentially) different from +-- 'WebRoot' -- for a repository located at, say, @http://hackage.haskell.org@ +-- they happen to coincide, but for one location at +-- @http://example.com/some/subdirectory@ they do not. +data RepoRoot + +-- | Paths relative to the root of the repository +type RepoPath = Path (Rooted RepoRoot) + +instance IsRoot RepoRoot where showRoot _ = "" + +-- | Layout of a repository +data RepoLayout = RepoLayout { + -- | TUF root metadata + repoLayoutRoot :: RepoPath + + -- | TUF timestamp + , repoLayoutTimestamp :: RepoPath + + -- | TUF snapshot + , repoLayoutSnapshot :: RepoPath + + -- | TUF mirrors list + , repoLayoutMirrors :: RepoPath + + -- | Compressed index tarball + , repoLayoutIndexTarGz :: RepoPath + + -- | Uncompressed index tarball + , repoLayoutIndexTar :: RepoPath + + -- | Path to the package tarball + , repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath + + -- | Layout of the index + -- + -- Since the repository hosts the index, the layout of the index is + -- not independent of the layout of the repository. + , repoIndexLayout :: IndexLayout + } + +-- | The layout used on Hackage +hackageRepoLayout :: RepoLayout +hackageRepoLayout = RepoLayout { + repoLayoutRoot = rp $ fragment' "root.json" + , repoLayoutTimestamp = rp $ fragment' "timestamp.json" + , repoLayoutSnapshot = rp $ fragment' "snapshot.json" + , repoLayoutMirrors = rp $ fragment' "mirrors.json" + , repoLayoutIndexTarGz = rp $ fragment' "01-index.tar.gz" + , repoLayoutIndexTar = rp $ fragment' "01-index.tar" + , repoLayoutPkgTarGz = \pkgId -> rp $ fragment' "package" pkgFile pkgId + , repoIndexLayout = hackageIndexLayout + } + where + pkgFile :: PackageIdentifier -> UnrootedPath + pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz" + + rp :: UnrootedPath -> RepoPath + rp = rootPath Rooted + +-- | Layout used by cabal for ("legacy") local repos +-- +-- Obviously, such repos do not normally contain any of the TUF files, so their +-- location is more or less arbitrary here. +cabalLocalRepoLayout :: RepoLayout +cabalLocalRepoLayout = hackageRepoLayout { + repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId pkgFile pkgId + } + where + pkgLoc :: PackageIdentifier -> UnrootedPath + pkgLoc pkgId = joinFragments [ + mkFragment $ display (packageName pkgId) + , mkFragment $ display (packageVersion pkgId) + ] + + pkgFile :: PackageIdentifier -> UnrootedPath + pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz" + + rp :: UnrootedPath -> RepoPath + rp = rootPath Rooted + +anchorRepoPathLocally :: IsFileSystemRoot root + => Path (Rooted root) -> RepoPath -> Path (Rooted root) +anchorRepoPathLocally localRoot repoPath = localRoot unrootPath' repoPath + +anchorRepoPathRemotely :: URIPath -> RepoPath -> URIPath +anchorRepoPathRemotely remoteRoot repoPath = remoteRoot unrootPath' repoPath + +{------------------------------------------------------------------------------- + Index layout +-------------------------------------------------------------------------------} + +-- | The root of the index tarball +data IndexRoot + +-- | Paths relative to the root of the index tarball +type IndexPath = Path (Rooted RepoRoot) + +instance IsRoot IndexRoot where showRoot _ = "" + +-- | Layout of the files within the index tarball +data IndexLayout = IndexLayout { + -- | TUF metadata for a package + indexLayoutPkgMetadata :: PackageIdentifier -> IndexPath + + -- | Package .cabal file + , indexLayoutPkgCabal :: PackageIdentifier -> IndexPath + } + +-- | The layout of the index as maintained on Hackage +hackageIndexLayout :: IndexLayout +hackageIndexLayout = IndexLayout { + indexLayoutPkgMetadata = \pkgId -> rp $ pkgLoc pkgId pkgMetadata + , indexLayoutPkgCabal = \pkgId -> rp $ pkgLoc pkgId pkgCabal pkgId + } + where + pkgLoc :: PackageIdentifier -> UnrootedPath + pkgLoc pkgId = joinFragments [ + mkFragment $ display (packageName pkgId) + , mkFragment $ display (packageVersion pkgId) + ] + + pkgCabal :: PackageIdentifier -> UnrootedPath + pkgCabal pkgId = fragment' (display (packageName pkgId)) <.> "cabal" + + pkgMetadata :: UnrootedPath + pkgMetadata = fragment' "package" <.> "json" + + rp :: UnrootedPath -> IndexPath + rp = rootPath Rooted + +{------------------------------------------------------------------------------- + Cache layout +-------------------------------------------------------------------------------} + +-- | The cache directory +data CacheRoot +type CachePath = Path (Rooted CacheRoot) + +instance IsRoot CacheRoot where showRoot _ = "" + +-- | Location of the various files we cache +-- +-- Although the generic TUF algorithms do not care how we organize the cache, +-- we nonetheless specity this here because as long as there are tools which +-- access files in the cache directly we need to define the cache layout. +-- See also comments for 'defaultCacheLayout'. +data CacheLayout = CacheLayout { + -- | TUF root metadata + cacheLayoutRoot :: CachePath + + -- | TUF timestamp + , cacheLayoutTimestamp :: CachePath + + -- | TUF snapshot + , cacheLayoutSnapshot :: CachePath + + -- | TUF mirrors list + , cacheLayoutMirrors :: CachePath + + -- | Uncompressed index tarball + , cacheLayoutIndexTar :: CachePath + + -- | Index to the uncompressed index tarball + , cacheLayoutIndexIdx :: CachePath + + -- | Compressed index tarball (if cached) + , cacheLayoutIndexTarGz :: Maybe CachePath + } + +-- | The cache layout cabal-install uses +-- +-- We cache the index as @/00-index.tar@; this is important because +-- `cabal-install` expects to find it there (and does not currently go through +-- the hackage-security library to get files from the index). +cabalCacheLayout :: CacheLayout +cabalCacheLayout = CacheLayout { + cacheLayoutRoot = rp $ fragment' "root.json" + , cacheLayoutTimestamp = rp $ fragment' "timestamp.json" + , cacheLayoutSnapshot = rp $ fragment' "snapshot.json" + , cacheLayoutMirrors = rp $ fragment' "mirrors.json" + , cacheLayoutIndexTar = rp $ fragment' "00-index.tar" + , cacheLayoutIndexIdx = rp $ fragment' "00-index.tar.idx" + , cacheLayoutIndexTarGz = Nothing + } + where + rp :: UnrootedPath -> CachePath + rp = rootPath Rooted + +-- | Anchor a cache path to the location of the cache +anchorCachePath :: IsFileSystemRoot root + => Path (Rooted root) -> CachePath -> Path (Rooted root) +anchorCachePath cacheRoot cachePath = cacheRoot unrootPath' cachePath diff --git a/src/Hackage/Security/TUF/Mirrors.hs b/src/Hackage/Security/TUF/Mirrors.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Mirrors.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE UndecidableInstances #-} +module Hackage.Security.TUF.Mirrors ( + -- * TUF types + Mirrors(..) + , Mirror(..) + , MirrorContent(..) + -- ** Utility + , MirrorDescription + , describeMirror + ) where + +import Control.Monad.Except +import Network.URI + +import Hackage.Security.JSON +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.Signed + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +data Mirrors = Mirrors { + mirrorsVersion :: FileVersion + , mirrorsExpires :: FileExpires + , mirrorsMirrors :: [Mirror] + } + +-- | Definition of a mirror +-- +-- NOTE: Unlike the TUF specification, we require that all mirrors must have +-- the same format. That is, we omit @metapath@ and @targetspath@. +data Mirror = Mirror { + mirrorUrlBase :: URI + , mirrorContent :: MirrorContent + } + deriving Show + +-- | Full versus partial mirrors +-- +-- The TUF spec explicitly allows for partial mirrors, with the mirrors file +-- specifying (through patterns) what is available from partial mirrors. +-- +-- For now we only support full mirrors; if we wanted to add partial mirrors, +-- we would add a second @MirrorPartial@ constructor here with arguments +-- corresponding to TUF's @metacontent@ and @targetscontent@ fields. +data MirrorContent = + MirrorFull + deriving Show + +instance HasHeader Mirrors where + fileVersion f x = (\y -> x { mirrorsVersion = y }) <$> f (mirrorsVersion x) + fileExpires f x = (\y -> x { mirrorsExpires = y }) <$> f (mirrorsExpires x) + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +type MirrorDescription = String + +-- | Give a human-readable description of a particular mirror +-- +-- (for use in error messages) +describeMirror :: Mirror -> MirrorDescription +describeMirror = show . mirrorUrlBase + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m Mirror where + toJSON Mirror{..} = mkObject $ concat [ + [ ("urlbase", toJSON mirrorUrlBase) ] + , case mirrorContent of + MirrorFull -> [] + ] + +instance Monad m => ToJSON m Mirrors where + toJSON Mirrors{..} = mkObject [ + ("_type" , return $ JSString "Mirrorlist") + , ("version" , toJSON mirrorsVersion) + , ("expires" , toJSON mirrorsExpires) + , ("mirrors" , toJSON mirrorsMirrors) + ] + +instance ReportSchemaErrors m => FromJSON m Mirror where + fromJSON enc = do + mirrorUrlBase <- fromJSField enc "urlbase" + let mirrorContent = MirrorFull + return Mirror{..} + +instance ( MonadError DeserializationError m + , ReportSchemaErrors m + ) => FromJSON m Mirrors where + fromJSON enc = do + verifyType enc "Mirrorlist" + mirrorsVersion <- fromJSField enc "version" + mirrorsExpires <- fromJSField enc "expires" + mirrorsMirrors <- fromJSField enc "mirrors" + return Mirrors{..} + +instance MonadKeys m => FromJSON m (Signed Mirrors) where + fromJSON = signedFromJSON diff --git a/src/Hackage/Security/TUF/Patterns.hs b/src/Hackage/Security/TUF/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Patterns.hs @@ -0,0 +1,338 @@ +-- | Patterns and replacements +{-# LANGUAGE TemplateHaskell #-} +module Hackage.Security.TUF.Patterns ( + -- * Patterns and replacements + FileName + , Directory + , Extension + , BaseName + , Pattern(..) + , Replacement(..) + , Delegation(..) + -- ** Utility + , identityReplacement + , matchDelegation + -- ** Parsing and quasi-quoting + , parseDelegation + , qqd + ) where + +import Control.Monad.Except +import Language.Haskell.TH +import System.FilePath +import qualified Language.Haskell.TH.Syntax as TH + +import Hackage.Security.JSON +import Hackage.Security.Util.Some +import Hackage.Security.Util.Stack +import Hackage.Security.Util.TypedEmbedded + +{------------------------------------------------------------------------------- + Patterns and replacements +-------------------------------------------------------------------------------} + +type FileName = String +type Directory = String +type Extension = String +type BaseName = String + +-- | Structured patterns over paths +-- +-- The type argument indicates what kind of function we expect when the +-- pattern matches. For example, we have the pattern @"*/*.txt"@: +-- +-- > PathPatternDirAny (PathPatternFileExt ".txt") +-- > :: PathPattern (Directory :- BaseName :- ()) +-- +-- TODOs (see README.md): +-- +-- * Update this to work with 'Path' rather than 'FilePath'/'String' +-- * Add different kinds of wildcards +-- * Add path roots +-- +-- Currently this is a proof of concept more than anything else; the right +-- structure is here, but it needs updating. However, until we add author +-- signing (or out-of-tarball targets) we don't actually use this yet. +-- +-- NOTE: Haddock lacks GADT support so constructors have only regular comments. +data Pattern a where + -- Match against a specific filename + PatFileConst :: FileName -> Pattern () + + -- Match against a filename with the given extension + PatFileExt :: Extension -> Pattern (BaseName :- ()) + + -- Match against any filename + PatFileAny :: Pattern (FileName :- ()) + + -- Match against a specific directory + PatDirConst :: Directory -> Pattern a -> Pattern a + + -- Match against any directory + PatDirAny :: Pattern a -> Pattern (Directory :- a) + +-- | Replacement patterns +-- +-- These constructors match the ones in 'Pattern': wildcards must be used +-- in the same order as they appear in the pattern, but they don't all have to +-- be used (that's why the base constructors are polymorphic in the stack tail). +data Replacement a where + RepFileConst :: FileName -> Replacement a + RepFileExt :: Extension -> Replacement (BaseName :- a) + RepFileAny :: Replacement (FileName :- a) + RepDirConst :: Directory -> Replacement a -> Replacement a + RepDirAny :: Replacement a -> Replacement (Directory :- a) + +deriving instance Eq (Pattern typ) +deriving instance Show (Pattern typ) + +deriving instance Eq (Replacement typ) +deriving instance Show (Replacement typ) + +-- | The identity replacement replaces a matched pattern with itself +identityReplacement :: Pattern typ -> Replacement typ +identityReplacement = go + where + go :: Pattern typ -> Replacement typ + go (PatFileConst fn) = RepFileConst fn + go (PatFileExt e) = RepFileExt e + go PatFileAny = RepFileAny + go (PatDirConst d p) = RepDirConst d (go p) + go (PatDirAny p) = RepDirAny (go p) + +-- | A delegation +-- +-- A delegation is a pair of a pattern and a replacement. +-- +-- See 'match' for an example. +data Delegation = forall a. Delegation (Pattern a) (Replacement a) + +deriving instance Show Delegation + +{------------------------------------------------------------------------------- + Matching +-------------------------------------------------------------------------------} + +matchPattern :: String -> Pattern a -> Maybe a +matchPattern = go . splitDirectories + where + go :: [String] -> Pattern a -> Maybe a + go [] _ = Nothing + go [f] (PatFileConst f') = do guard (f == f') + return () + go [f] (PatFileExt e') = do let (bn, _:e) = splitExtension f + guard $ e == e' + return (bn :- ()) + go [_] _ = Nothing + go (d:p) (PatDirConst d' p') = do guard (d == d') + go p p' + go (d:p) (PatDirAny p') = (d :-) <$> go p p' + go (_:_) _ = Nothing + +constructReplacement :: Replacement a -> a -> String +constructReplacement = \repl a -> joinPath $ go repl a + where + go :: Replacement a -> a -> [String] + go (RepFileConst c) _ = [c] + go (RepFileExt e) (bn :- _) = [bn <.> e] + go RepFileAny (fn :- _) = [fn] + go (RepDirConst d p) a = d : go p a + go (RepDirAny p) (d :- a) = d : go p a + +matchDelegation :: Delegation -> String -> Maybe String +matchDelegation (Delegation pat repl) str = + constructReplacement repl <$> matchPattern str pat + +{------------------------------------------------------------------------------- + Typechecking patterns and replacements +-------------------------------------------------------------------------------} + +-- | Types for pattern and replacements +-- +-- We intentially are not very precise here, saying @String@ (instead of +-- @FileName@, @BaseName@, or @Directory@, say) so that we can, for example, +-- use a matched filename in a pattern as a directory in a replacement. +data PatternType a where + PatTypeNil :: PatternType () + PatTypeStr :: PatternType a -> PatternType (String :- a) + +instance Unify PatternType where + unify PatTypeNil PatTypeNil = Just Refl + unify (PatTypeStr p) (PatTypeStr p') = case unify p p' of + Just Refl -> Just Refl + Nothing -> Nothing + unify _ _ = Nothing + +type instance TypeOf Pattern = PatternType +type instance TypeOf Replacement = PatternType + +instance Typed Pattern where + typeOf (PatFileConst _) = PatTypeNil + typeOf (PatFileExt _) = PatTypeStr PatTypeNil + typeOf (PatFileAny ) = PatTypeStr PatTypeNil + typeOf (PatDirConst _ p) = typeOf p + typeOf (PatDirAny p) = PatTypeStr (typeOf p) + +instance AsType Replacement where + asType = go + where + go :: Replacement typ -> PatternType typ' -> Maybe (Replacement typ') + go (RepFileConst c) _ = return $ RepFileConst c + go (RepFileExt _) PatTypeNil = Nothing + go (RepFileExt e) (PatTypeStr _) = return $ RepFileExt e + go RepFileAny PatTypeNil = Nothing + go RepFileAny (PatTypeStr _) = return $ RepFileAny + go (RepDirConst c p) tp = RepDirConst c <$> go p tp + go (RepDirAny _) PatTypeNil = Nothing + go (RepDirAny p) (PatTypeStr tp) = RepDirAny <$> go p tp + +{------------------------------------------------------------------------------- + Pretty-printing and parsing patterns and replacements +-------------------------------------------------------------------------------} + +prettyPattern :: Pattern typ -> String +prettyPattern (PatFileConst f) = f +prettyPattern (PatFileExt e) = "*" <.> e +prettyPattern PatFileAny = "*" +prettyPattern (PatDirConst d p) = d prettyPattern p +prettyPattern (PatDirAny p) = "*" prettyPattern p + +prettyReplacement :: Replacement typ -> String +prettyReplacement (RepFileConst f) = f +prettyReplacement (RepFileExt e) = "*" <.> e +prettyReplacement RepFileAny = "*" +prettyReplacement (RepDirConst d p) = d prettyReplacement p +prettyReplacement (RepDirAny p) = "*" prettyReplacement p + +-- | Parse a pattern +parsePattern :: String -> Maybe (Some Pattern) +parsePattern = go . splitDirectories + where + go :: [String] -> Maybe (Some Pattern) + go [] = Nothing + go ["*"] = return . Some $ PatFileAny + go [p] = if '*' `notElem` p + then return . Some $ PatFileConst p + else case splitExtension p of + ("*", _:ext) -> return . Some $ PatFileExt ext + _otherwise -> Nothing + go (p:ps) = do Some p' <- go ps + if '*' `notElem` p + then return . Some $ PatDirConst p p' + else case p of + "*" -> return . Some $ PatDirAny p' + _otherwise -> Nothing + +-- | Parse a replacement +-- +-- We cheat and use the parser for patterns and then translate using the +-- identity replacement. +parseReplacement :: String -> Maybe (Some Replacement) +parseReplacement = fmap aux . parsePattern + where + aux :: Some Pattern -> Some Replacement + aux (Some pat) = Some (identityReplacement pat) + +parseDelegation :: String -> String -> Either String Delegation +parseDelegation pat repl = + case (parsePattern pat, parseReplacement repl) of + (Just (Some pat'), Just (Some repl')) -> + case repl' `asType` typeOf pat' of + Just repl'' -> Right $ Delegation pat' repl'' + Nothing -> Left "Replacement does not match pattern type" + _otherwise -> + Left "Cannot parse delegation" + +{------------------------------------------------------------------------------- + Quasi-quotation + + We cannot (easily) use dataToExpQ because of the use of GADTs, so we manually + give Lift instances. +-------------------------------------------------------------------------------} + +-- | Quasi-quoter for delegations to make them easier to write in code +-- +-- This allows to write delegations as +-- +-- > $(qqd "targets/*/*/*.cabal" "targets/*/*/revisions.json") +-- +-- (The alternative syntax which actually uses a quasi-quoter doesn't work very +-- well because the '/*' bits confuse CPP: "unterminated comment") +qqd :: String -> String -> Q Exp +qqd pat repl = + case parseDelegation pat repl of + Left err -> fail $ "Invalid delegation: " ++ err + Right del -> TH.lift del + +instance TH.Lift (Pattern a) where + lift (PatFileConst fn) = [| PatFileConst fn |] + lift (PatFileExt e) = [| PatFileExt e |] + lift PatFileAny = [| PatFileAny |] + lift (PatDirConst d p) = [| PatDirConst d p |] + lift (PatDirAny p) = [| PatDirAny p |] + +instance TH.Lift (Replacement a) where + lift (RepFileConst fn) = [| RepFileConst fn |] + lift (RepFileExt e ) = [| RepFileExt e |] + lift RepFileAny = [| RepFileAny |] + lift (RepDirConst d r) = [| RepDirConst d r |] + lift (RepDirAny r) = [| RepDirAny r |] + +instance TH.Lift Delegation where + lift (Delegation pat repl) = [| Delegation pat repl |] + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m (Pattern typ) where + toJSON = return . JSString . prettyPattern +instance Monad m => ToJSON m (Replacement typ) where + toJSON = return . JSString . prettyReplacement + +instance Monad m => ToJSON m (Some Pattern) where + toJSON (Some p) = toJSON p +instance Monad m => ToJSON m (Some Replacement) where + toJSON (Some r) = toJSON r + +instance ReportSchemaErrors m => FromJSON m (Some Pattern) where + fromJSON enc = do + str <- fromJSON enc + case parsePattern str of + Nothing -> expected "valid pattern" (Just str) + Just p -> return p + +instance ReportSchemaErrors m => FromJSON m (Some Replacement) where + fromJSON enc = do + str <- fromJSON enc + case parseReplacement str of + Nothing -> expected "valid replacement" (Just str) + Just r -> return r + +{------------------------------------------------------------------------------- + Debugging: examples +-------------------------------------------------------------------------------} + +_ex1 :: Maybe String +_ex1 = matchDelegation del "A/x/y/z.foo" + where + del = Delegation + ( PatDirConst "A" + $ PatDirAny + $ PatDirAny + $ PatFileExt "foo" + ) + ( RepDirConst "B" + $ RepDirAny + $ RepDirConst "C" + $ RepDirAny + $ RepFileExt "bar" + ) + +_ex2 :: Maybe String +_ex2 = matchDelegation del "A/x/y/z.foo" + where + Right del = parseDelegation "A/*/*/*.foo" "B/*/C/*/*.bar" + +_ex3 :: Either String Delegation +_ex3 = parseDelegation "foo" "*/bar" diff --git a/src/Hackage/Security/TUF/Root.hs b/src/Hackage/Security/TUF/Root.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Root.hs @@ -0,0 +1,117 @@ +-- | The root filetype +module Hackage.Security.TUF.Root ( + -- * Datatypes + Root(..) + , RootRoles(..) + , RoleSpec(..) + ) where + +import Hackage.Security.JSON +import Hackage.Security.Key +import Hackage.Security.Key.Env (KeyEnv) +import Hackage.Security.TUF.Common +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.Mirrors +import Hackage.Security.TUF.Signed +import Hackage.Security.TUF.Snapshot +import Hackage.Security.TUF.Targets +import Hackage.Security.TUF.Timestamp +import Hackage.Security.Util.Some + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +-- | The root metadata +-- +-- NOTE: We must have the invariant that ALL keys (apart from delegation keys) +-- must be listed in 'rootKeys'. (Delegation keys satisfy a similar invariant, +-- see Targets.) +data Root = Root { + rootVersion :: FileVersion + , rootExpires :: FileExpires + , rootKeys :: KeyEnv + , rootRoles :: RootRoles + } + +data RootRoles = RootRoles { + rootRolesRoot :: RoleSpec Root + , rootRolesSnapshot :: RoleSpec Snapshot + , rootRolesTargets :: RoleSpec Targets + , rootRolesTimestamp :: RoleSpec Timestamp + , rootRolesMirrors :: RoleSpec Mirrors + } + +-- | Role specification +-- +-- The phantom type indicates what kind of type this role is meant to verify. +data RoleSpec a = RoleSpec { + roleSpecKeys :: [Some PublicKey] + , roleSpecThreshold :: KeyThreshold + } + deriving (Show) + +instance HasHeader Root where + fileVersion f x = (\y -> x { rootVersion = y }) <$> f (rootVersion x) + fileExpires f x = (\y -> x { rootExpires = y }) <$> f (rootExpires x) + +{------------------------------------------------------------------------------- + JSON encoding +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m RootRoles where + toJSON RootRoles{..} = mkObject [ + ("root" , toJSON rootRolesRoot) + , ("snapshot" , toJSON rootRolesSnapshot) + , ("targets" , toJSON rootRolesTargets) + , ("timestamp" , toJSON rootRolesTimestamp) + , ("mirrors" , toJSON rootRolesMirrors) + ] + +instance MonadKeys m => FromJSON m RootRoles where + fromJSON enc = do + rootRolesRoot <- fromJSField enc "root" + rootRolesSnapshot <- fromJSField enc "snapshot" + rootRolesTargets <- fromJSField enc "targets" + rootRolesTimestamp <- fromJSField enc "timestamp" + rootRolesMirrors <- fromJSField enc "mirrors" + return RootRoles{..} + +instance Monad m => ToJSON m Root where + toJSON Root{..} = mkObject [ + ("_type" , return $ JSString "Root") + , ("version" , toJSON rootVersion) + , ("expires" , toJSON rootExpires) + , ("keys" , toJSON rootKeys) + , ("roles" , toJSON rootRoles) + ] + +instance Monad m => ToJSON m (RoleSpec a) where + toJSON RoleSpec{..} = mkObject [ + ("keyids" , return . JSArray . map writeKeyAsId $ roleSpecKeys) + , ("threshold" , toJSON roleSpecThreshold) + ] + +-- | We give an instance for Signed Root rather than Root because the key +-- environment from the root data is necessary to resolve the explicit sharing +-- in the signatures. +instance MonadKeys m => FromJSON m (Signed Root) where + fromJSON envelope = do + enc <- fromJSField envelope "signed" + rootKeys <- fromJSField enc "keys" + withKeys rootKeys $ do + verifyType enc "Root" + rootVersion <- fromJSField enc "version" + rootExpires <- fromJSField enc "expires" + rootRoles <- fromJSField enc "roles" + let signed = Root{..} + + signatures <- fromJSField envelope "signatures" + validate "signatures" $ verifySignatures enc signatures + return Signed{..} + +instance MonadKeys m => FromJSON m (RoleSpec a) where + fromJSON enc = do + roleSpecKeys <- mapM readKeyAsId =<< fromJSField enc "keyids" + roleSpecThreshold <- fromJSField enc "threshold" + return RoleSpec{..} diff --git a/src/Hackage/Security/TUF/Signed.hs b/src/Hackage/Security/TUF/Signed.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Signed.hs @@ -0,0 +1,238 @@ +-- | Wrapper around an arbitrary datatype that adds signatures +-- +-- Note that in the spec there is explicit sharing of keys through key IDs; +-- we translate this to implicit sharing in our Haskell datatypes, with the +-- translation done in the JSON serialization/deserialization. +module Hackage.Security.TUF.Signed ( + -- * TUF types + Signed(..) + , Signatures(..) + , Signature(..) + -- * Construction and verification + , unsigned + , withSignatures + , withSignatures' + , signRendered + , verifySignature + -- * JSON aids + , signedFromJSON + , verifySignatures + -- * Avoid interpreting signatures + , UninterpretedSignatures(..) + , PreSignature(..) + -- ** Utility + , fromPreSignature + , fromPreSignatures + , toPreSignature + , toPreSignatures + ) where + +import Control.Monad +import Data.Functor.Identity +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Set as Set + +import Hackage.Security.JSON +import Hackage.Security.Key +import Hackage.Security.TUF.Layout +import Hackage.Security.Util.Some +import Text.JSON.Canonical +import qualified Hackage.Security.Util.Base64 as B64 + +{------------------------------------------------------------------------------- + Signed objects +-------------------------------------------------------------------------------} + +data Signed a = Signed { + signed :: a + , signatures :: Signatures + } + +-- | A list of signatures +-- +-- Invariant: each signature must be made with a different key. +-- We enforce this invariant for incoming untrusted data ('fromPreSignatures') +-- but not for lists of signatures that we create in code. +newtype Signatures = Signatures [Signature] + +data Signature = Signature { + signature :: BS.ByteString + , signatureKey :: Some PublicKey + } + +-- | Create a new document without any signatures +unsigned :: a -> Signed a +unsigned a = Signed { signed = a, signatures = Signatures [] } + +-- | Sign a document +withSignatures :: ToJSON WriteJSON a => RepoLayout -> [Some Key] -> a -> Signed a +withSignatures repoLayout keys doc = Signed { + signed = doc + , signatures = signRendered keys $ renderJSON repoLayout doc + } + +-- | Variation on 'withSignatures' that doesn't need the repo layout +withSignatures' :: ToJSON Identity a => [Some Key] -> a -> Signed a +withSignatures' keys doc = Signed { + signed = doc + , signatures = signRendered keys $ renderJSON_NoLayout doc + } + +-- | Construct signatures for already rendered value +signRendered :: [Some Key] -> BS.L.ByteString -> Signatures +signRendered keys rendered = Signatures $ map go keys + where + go :: Some Key -> Signature + go (Some key) = Signature { + signature = sign (privateKey key) rendered + , signatureKey = Some $ publicKey key + } + +verifySignature :: BS.L.ByteString -> Signature -> Bool +verifySignature inp Signature{signature = sig, signatureKey = Some pub} = + verify pub inp sig + +instance (Monad m, ToJSON m a) => ToJSON m (Signed a) where + toJSON Signed{..} = mkObject [ + ("signed" , toJSON signed) + , ("signatures" , toJSON signatures) + ] + +instance Monad m => ToJSON m Signatures where + toJSON = toJSON . toPreSignatures + +instance MonadKeys m => FromJSON m Signatures where + fromJSON = fromPreSignatures <=< fromJSON + +{------------------------------------------------------------------------------- + JSON aids +-------------------------------------------------------------------------------} + +-- | General FromJSON instance for signed datatypes +-- +-- We don't give a general FromJSON instance for Signed because for some +-- datatypes we need to do something special (datatypes where we need to +-- read key environments); for instance, see the "Signed Root" instance. +signedFromJSON :: (MonadKeys m, FromJSON m a) => JSValue -> m (Signed a) +signedFromJSON envelope = do + enc <- fromJSField envelope "signed" + signed <- fromJSON enc + signatures <- fromJSField envelope "signatures" + validate "signatures" $ verifySignatures enc signatures + return Signed{..} + +-- | Signature verification +-- +-- NOTES: +-- 1. By definition, the signature must be verified against the canonical +-- JSON format. This means we _must_ parse and then pretty print (as +-- we do here) because the document as stored may or may not be in +-- canonical format. +-- 2. However, it is important that we NOT translate from the JSValue +-- to whatever internal datatype we are using and then back to JSValue, +-- because that may not roundtrip: we must allow for additional fields +-- in the JSValue that we ignore (and would therefore lose when we +-- attempt to roundtrip). +-- 3. We verify that all signatures are valid, but we cannot verify (here) +-- that these signatures are signed with the right key, or that we +-- have a sufficient number of signatures. This will be the +-- responsibility of the calling code. +verifySignatures :: JSValue -> Signatures -> Bool +verifySignatures parsed (Signatures sigs) = + all (verifySignature $ renderCanonicalJSON parsed) sigs + +{------------------------------------------------------------------------------- + Uninterpreted signatures +-------------------------------------------------------------------------------} + +-- | File with uninterpreted signatures +-- +-- Sometimes we want to be able to read a file without interpreting the +-- signatures (that is, resolving the key IDs) or doing any kind of checks on +-- them. One advantage of this is that this allows us to read many file types +-- without any key environment at all, which is sometimes useful. +data UninterpretedSignatures a = UninterpretedSignatures { + uninterpretedSigned :: a + , uninterpretedSignatures :: [PreSignature] + } + deriving (Show) + +-- | A signature with a key ID (rather than an actual key) +-- +-- This corresponds precisely to the TUF representation of a signature. +data PreSignature = PreSignature { + presignature :: BS.ByteString + , presigMethod :: Some KeyType + , presigKeyId :: KeyId + } + deriving (Show) + +-- | Convert a pre-signature to a signature +-- +-- Verifies that the key type matches the advertised method. +fromPreSignature :: MonadKeys m => PreSignature -> m Signature +fromPreSignature PreSignature{..} = do + key <- lookupKey presigKeyId + validate "key type" $ typecheckSome key presigMethod + return Signature { + signature = presignature + , signatureKey = key + } + +-- | Convert signature to pre-signature +toPreSignature :: Signature -> PreSignature +toPreSignature Signature{..} = PreSignature { + presignature = signature + , presigMethod = somePublicKeyType signatureKey + , presigKeyId = someKeyId signatureKey + } + +-- | Convert a list of 'PreSignature's to a list of 'Signature's +-- +-- This verifies the invariant that all signatures are made with different keys. +-- We do this on the presignatures rather than the signatures so that we can do +-- the check on key IDs, rather than keys (the latter don't have an Ord +-- instance). +fromPreSignatures :: MonadKeys m => [PreSignature] -> m Signatures +fromPreSignatures sigs = do + validate "all signatures made with different keys" $ + Set.size (Set.fromList (map presigKeyId sigs)) == length sigs + Signatures <$> mapM fromPreSignature sigs + +-- | Convert list of pre-signatures to a list of signatures +toPreSignatures :: Signatures -> [PreSignature] +toPreSignatures (Signatures sigs) = map toPreSignature sigs + +instance ReportSchemaErrors m => FromJSON m PreSignature where + fromJSON enc = do + kId <- fromJSField enc "keyid" + method <- fromJSField enc "method" + sig <- fromJSField enc "sig" + return PreSignature { + presignature = B64.toByteString sig + , presigMethod = method + , presigKeyId = KeyId kId + } + +instance Monad m => ToJSON m PreSignature where + toJSON PreSignature{..} = mkObject [ + ("keyid" , return $ JSString . keyIdString $ presigKeyId) + , ("method" , toJSON $ presigMethod) + , ("sig" , toJSON $ B64.fromByteString presignature) + ] + +instance ( ReportSchemaErrors m + , FromJSON m a + ) => FromJSON m (UninterpretedSignatures a) where + fromJSON envelope = do + enc <- fromJSField envelope "signed" + uninterpretedSigned <- fromJSON enc + uninterpretedSignatures <- fromJSField envelope "signatures" + return UninterpretedSignatures{..} + +instance (Monad m, ToJSON m a) => ToJSON m (UninterpretedSignatures a) where + toJSON UninterpretedSignatures{..} = mkObject [ + ("signed" , toJSON uninterpretedSigned) + , ("signatures" , toJSON uninterpretedSignatures) + ] diff --git a/src/Hackage/Security/TUF/Snapshot.hs b/src/Hackage/Security/TUF/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Snapshot.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE UndecidableInstances #-} +module Hackage.Security.TUF.Snapshot ( + Snapshot(..) + ) where + +import Control.Monad.Except +import Control.Monad.Reader + +import Hackage.Security.JSON +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.FileInfo +import Hackage.Security.TUF.FileMap +import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Signed +import qualified Hackage.Security.TUF.FileMap as FileMap + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +data Snapshot = Snapshot { + snapshotVersion :: FileVersion + , snapshotExpires :: FileExpires + + -- | File info for the root metadata + -- + -- We list this explicitly in the snapshot so that we can check if we need + -- to update the root metadata without first having to download the entire + -- index tarball. + , snapshotInfoRoot :: FileInfo + + -- | File info for the mirror metadata + , snapshotInfoMirrors :: FileInfo + + -- | Compressed index tarball + , snapshotInfoTarGz :: FileInfo + + -- | Uncompressed index tarball + -- + -- Repositories are not required to provide this. + , snapshotInfoTar :: Maybe FileInfo + } + +instance HasHeader Snapshot where + fileVersion f x = (\y -> x { snapshotVersion = y }) <$> f (snapshotVersion x) + fileExpires f x = (\y -> x { snapshotExpires = y }) <$> f (snapshotExpires x) + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance MonadReader RepoLayout m => ToJSON m Snapshot where + toJSON Snapshot{..} = do + repoLayout <- ask + mkObject [ + ("_type" , return $ JSString "Snapshot") + , ("version" , toJSON snapshotVersion) + , ("expires" , toJSON snapshotExpires) + , ("meta" , toJSON (snapshotMeta repoLayout)) + ] + where + snapshotMeta repoLayout = FileMap.fromList $ [ + (pathRoot repoLayout , snapshotInfoRoot) + , (pathMirrors repoLayout , snapshotInfoMirrors) + , (pathIndexTarGz repoLayout , snapshotInfoTarGz) + ] ++ + [ (pathIndexTar repoLayout , infoTar) | Just infoTar <- [snapshotInfoTar] ] + +instance ( MonadReader RepoLayout m + , MonadError DeserializationError m + , ReportSchemaErrors m + ) => FromJSON m Snapshot where + fromJSON enc = do + verifyType enc "Snapshot" + repoLayout <- ask + snapshotVersion <- fromJSField enc "version" + snapshotExpires <- fromJSField enc "expires" + snapshotMeta <- fromJSField enc "meta" + snapshotInfoRoot <- FileMap.lookupM snapshotMeta (pathRoot repoLayout) + snapshotInfoMirrors <- FileMap.lookupM snapshotMeta (pathMirrors repoLayout) + snapshotInfoTarGz <- FileMap.lookupM snapshotMeta (pathIndexTarGz repoLayout) + let snapshotInfoTar = FileMap.lookup (pathIndexTar repoLayout) snapshotMeta + return Snapshot{..} + +instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Snapshot) where + fromJSON = signedFromJSON + +{------------------------------------------------------------------------------- + Paths used in the snapshot + + NOTE: Since the snapshot lives in the top-level directory of the repository, + we can safely reinterpret "relative to the repo root" as "relative to the + snapshot"; hence, this use of 'castRoot' is okay. +-------------------------------------------------------------------------------} + +pathRoot, pathMirrors, pathIndexTarGz, pathIndexTar :: RepoLayout -> TargetPath +pathRoot = TargetPathRepo . repoLayoutRoot +pathMirrors = TargetPathRepo . repoLayoutMirrors +pathIndexTarGz = TargetPathRepo . repoLayoutIndexTarGz +pathIndexTar = TargetPathRepo . repoLayoutIndexTar diff --git a/src/Hackage/Security/TUF/Targets.hs b/src/Hackage/Security/TUF/Targets.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Targets.hs @@ -0,0 +1,130 @@ +module Hackage.Security.TUF.Targets ( + -- * TUF types + Targets(..) + , Delegations(..) + , DelegationSpec(..) + , Delegation(..) + -- ** Util + , targetsLookup + ) where + +import Hackage.Security.JSON +import Hackage.Security.Key +import Hackage.Security.Key.Env (KeyEnv) +import Hackage.Security.TUF.Common +import Hackage.Security.TUF.FileInfo +import Hackage.Security.TUF.FileMap (FileMap, TargetPath) +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.Patterns +import Hackage.Security.TUF.Signed +import Hackage.Security.Util.Some +import qualified Hackage.Security.TUF.FileMap as FileMap + +{------------------------------------------------------------------------------- + TUF types +-------------------------------------------------------------------------------} + +-- | Target metadata +-- +-- Most target files do not need expiry dates because they are not subject to +-- change (and hence attacks like freeze attacks are not a concern). +data Targets = Targets { + targetsVersion :: FileVersion + , targetsExpires :: FileExpires + , targetsTargets :: FileMap + , targetsDelegations :: Maybe Delegations + } + deriving (Show) + +-- | Delegations +-- +-- Much like the Root datatype, this must have an invariant that ALL used keys +-- (apart from the global keys, which are in the root key environment) must +-- be listed in 'delegationsKeys'. +data Delegations = Delegations { + delegationsKeys :: KeyEnv + , delegationsRoles :: [DelegationSpec] + } + deriving (Show) + +-- | Delegation specification +-- +-- NOTE: This is a close analogue of 'RoleSpec'. +data DelegationSpec = DelegationSpec { + delegationSpecKeys :: [Some PublicKey] + , delegationSpecThreshold :: KeyThreshold + , delegation :: Delegation + } + deriving (Show) + +instance HasHeader Targets where + fileVersion f x = (\y -> x { targetsVersion = y }) <$> f (targetsVersion x) + fileExpires f x = (\y -> x { targetsExpires = y }) <$> f (targetsExpires x) + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +targetsLookup :: TargetPath -> Targets -> Maybe FileInfo +targetsLookup fp Targets{..} = FileMap.lookup fp targetsTargets + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m DelegationSpec where + toJSON DelegationSpec{delegation = Delegation fp name, ..} = mkObject [ + ("name" , toJSON name) + , ("keyids" , return . JSArray . map writeKeyAsId $ delegationSpecKeys) + , ("threshold" , toJSON delegationSpecThreshold) + , ("path" , toJSON fp) + ] + +instance MonadKeys m => FromJSON m DelegationSpec where + fromJSON enc = do + delegationName <- fromJSField enc "name" + delegationSpecKeys <- mapM readKeyAsId =<< fromJSField enc "keyids" + delegationSpecThreshold <- fromJSField enc "threshold" + delegationPath <- fromJSField enc "path" + case parseDelegation delegationName delegationPath of + Left err -> expected ("valid name/path combination: " ++ err) Nothing + Right delegation -> return DelegationSpec{..} + +-- NOTE: Unlike the Root object, the keys that are used to sign the delegations +-- are NOT listed inside the delegations, so the same "bootstrapping" problems +-- do not arise here. +instance Monad m => ToJSON m Delegations where + toJSON Delegations{..} = mkObject [ + ("keys" , toJSON delegationsKeys) + , ("roles" , toJSON delegationsRoles) + ] + +instance MonadKeys m => FromJSON m Delegations where + fromJSON enc = do + delegationsKeys <- fromJSField enc "keys" + delegationsRoles <- fromJSField enc "roles" + return Delegations{..} + +instance Monad m => ToJSON m Targets where + toJSON Targets{..} = mkObject $ mconcat [ + [ ("_type" , return $ JSString "Targets") + , ("version" , toJSON targetsVersion) + , ("expires" , toJSON targetsExpires) + , ("targets" , toJSON targetsTargets) + ] + , [ ("delegations" , toJSON d) | Just d <- [ targetsDelegations ] ] + ] + +instance MonadKeys m => FromJSON m Targets where + fromJSON enc = do + verifyType enc "Targets" + targetsVersion <- fromJSField enc "version" + targetsExpires <- fromJSField enc "expires" + targetsTargets <- fromJSField enc "targets" + targetsDelegations <- fromJSOptField enc "delegations" + return Targets{..} + +-- TODO: This is okay right now because targets do not introduce additional +-- keys, but will no longer be okay once we have author keys. +instance MonadKeys m => FromJSON m (Signed Targets) where + fromJSON = signedFromJSON diff --git a/src/Hackage/Security/TUF/Timestamp.hs b/src/Hackage/Security/TUF/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/TUF/Timestamp.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE UndecidableInstances #-} +module Hackage.Security.TUF.Timestamp ( + Timestamp(..) + ) where + +import Control.Monad.Except +import Control.Monad.Reader + +import Hackage.Security.JSON +import Hackage.Security.TUF.FileInfo +import Hackage.Security.TUF.FileMap +import Hackage.Security.TUF.Header +import Hackage.Security.TUF.Layout +import Hackage.Security.TUF.Signed +import qualified Hackage.Security.TUF.FileMap as FileMap + +{------------------------------------------------------------------------------- + Datatypes +-------------------------------------------------------------------------------} + +data Timestamp = Timestamp { + timestampVersion :: FileVersion + , timestampExpires :: FileExpires + , timestampInfoSnapshot :: FileInfo + } + +instance HasHeader Timestamp where + fileVersion f x = (\y -> x { timestampVersion = y }) <$> f (timestampVersion x) + fileExpires f x = (\y -> x { timestampExpires = y }) <$> f (timestampExpires x) + +{------------------------------------------------------------------------------- + JSON +-------------------------------------------------------------------------------} + +instance MonadReader RepoLayout m => ToJSON m Timestamp where + toJSON Timestamp{..} = do + repoLayout <- ask + mkObject [ + ("_type" , return $ JSString "Timestamp") + , ("version" , toJSON timestampVersion) + , ("expires" , toJSON timestampExpires) + , ("meta" , toJSON (timestampMeta repoLayout)) + ] + where + timestampMeta repoLayout = FileMap.fromList [ + (pathSnapshot repoLayout, timestampInfoSnapshot) + ] + +instance ( MonadReader RepoLayout m + , MonadError DeserializationError m + , ReportSchemaErrors m + ) => FromJSON m Timestamp where + fromJSON enc = do + verifyType enc "Timestamp" + repoLayout <- ask + timestampVersion <- fromJSField enc "version" + timestampExpires <- fromJSField enc "expires" + timestampMeta <- fromJSField enc "meta" + timestampInfoSnapshot <- FileMap.lookupM timestampMeta (pathSnapshot repoLayout) + return Timestamp{..} + +instance (MonadKeys m, MonadReader RepoLayout m) => FromJSON m (Signed Timestamp) where + fromJSON = signedFromJSON + +{------------------------------------------------------------------------------- + Paths used in the timestamp + + NOTE: Since the timestamp lives in the top-level directory of the repository, + we can safely reinterpret "relative to the repo root" as "relative to the + timestamp"; hence, this use of 'castRoot' is okay. +-------------------------------------------------------------------------------} + +pathSnapshot :: RepoLayout -> TargetPath +pathSnapshot = TargetPathRepo . repoLayoutSnapshot diff --git a/src/Hackage/Security/Trusted.hs b/src/Hackage/Security/Trusted.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Trusted.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE StaticPointers #-} +#endif +module Hackage.Security.Trusted ( + module Hackage.Security.Trusted.TCB + -- * Derived functions + , (<$$>) + -- ** Role verification + , VerifyRole(..) + -- ** File info verification + , verifyFileInfo + , trustedFileInfoEqual + ) where + +import Data.Function (on) +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 +-------------------------------------------------------------------------------} + +-- | Apply a static function to a trusted argument +(<$$>) :: StaticPtr (a -> b) -> Trusted a -> Trusted b +(<$$>) = trustApply . trustStatic + +{------------------------------------------------------------------------------- + Role verification +-------------------------------------------------------------------------------} + +class VerifyRole a where + verifyRole :: Trusted Root -- ^ Root data + -> TargetPath -- ^ Source (for error messages) + -> Maybe FileVersion -- ^ Previous version (if available) + -> Maybe UTCTime -- ^ Time now (if checking expiry) + -> Signed a -- ^ Mirrors to verify + -> Either VerificationError (SignaturesVerified a) + +instance VerifyRole Root where + verifyRole = verifyRole' . (static (rootRolesRoot . rootRoles) <$$>) + +instance VerifyRole Timestamp where + verifyRole = verifyRole' . (static (rootRolesTimestamp . rootRoles) <$$>) + +instance VerifyRole Snapshot where + verifyRole = verifyRole' . (static (rootRolesSnapshot . rootRoles) <$$>) + +instance VerifyRole Mirrors where + verifyRole = verifyRole' . (static (rootRolesMirrors . rootRoles) <$$>) + +{------------------------------------------------------------------------------- + File info verification +-------------------------------------------------------------------------------} + +-- | Verify 'FileInfo' +-- +-- We compare file lengths before computing hashes, but once we have verified +-- that the file lengths match we compute _all_ hashes, and then compare the +-- resulting sets. This is the right thing to do: sure, in the case where the +-- file info does _not_ match this is a waste of effort. However, we expect +-- that in the majority of cases the file info _will_ match, in which case +-- having to traverse the file multiple times to compute each hash, rather than +-- traversing the file once and computing all hashes at once, is inefficient. +-- +-- (Of course, right now the difference is moot since we only use one hash.) +verifyFileInfo :: forall root. IsFileSystemRoot root + => Path (Rooted root) -> Trusted FileInfo -> IO Bool +verifyFileInfo fp trustedInfo = lazyAndM [ + verifyFileLength + , (knownFileInfoEqual info) <$> computeFileInfo fp + ] + where + verifyFileLength :: IO Bool + verifyFileLength = (== fileInfoLength) <$> getFileLength + + getFileLength :: IO FileLength + getFileLength = FileLength . fromInteger <$> getFileSize fp + + info@FileInfo{..} = trusted trustedInfo + +-- | Variation on 'knownFileInfoEqual' for 'Trusted' 'FileInfo' +trustedFileInfoEqual :: Trusted FileInfo -> Trusted FileInfo -> Bool +trustedFileInfoEqual = knownFileInfoEqual `on` trusted + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +lazyAndM :: Monad m => [m Bool] -> m Bool +lazyAndM [] = return True +lazyAndM (m:ms) = do b <- m + case b of + False -> return False + True -> lazyAndM ms diff --git a/src/Hackage/Security/Trusted/TCB.hs b/src/Hackage/Security/Trusted/TCB.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Trusted/TCB.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +module Hackage.Security.Trusted.TCB ( + -- * Trusted values + Trusted(DeclareTrusted) + , trusted + , trustStatic + , trustVerified + , trustApply + , trustSeq + -- * Verification errors + , VerificationError(..) + , RootUpdated(..) + , VerificationHistory + -- * Role verification + , SignaturesVerified -- opaque + , signaturesVerified + , verifyRole' + , verifyFingerprints +#if __GLASGOW_HASKELL__ >= 710 + -- * Re-exports + , StaticPtr +#else + -- * Fake static pointers + , StaticPtr + , static +#endif + ) where + +import Control.Exception +import Control.Monad.Except +import Data.Typeable +import Data.Time +import Hackage.Security.TUF +import Hackage.Security.Key +import Hackage.Security.Util.Pretty +import qualified Hackage.Security.Util.Lens as Lens + +#if __GLASGOW_HASKELL__ >= 710 +import GHC.StaticPtr +#else +-- Fake static pointers for ghc < 7.10. This means Trusted offers no +-- additional type safety, but that's okay: we can still verify the code +-- with ghc 7.10 and get the additional checks. +newtype StaticPtr a = StaticPtr { deRefStaticPtr :: a } + +static :: a -> StaticPtr a +static = StaticPtr +#endif + +-- | Trusted values +-- +-- Trusted values originate in only two ways: +-- +-- * Anything that is statically known is trusted ('trustStatic') +-- * If we have "dynamic" data we can trust it once we have verified the +-- the signatures (trustSigned). +-- +-- NOTE: Trusted is NOT a functor. If it was we could define +-- +-- > trustAnything :: a -> Trusted a +-- > trustAnything a = fmap (const a) (trustStatic (static ())) +-- +-- Consequently, it is neither a monad nor a comonad. However, we _can_ apply +-- trusted functions to trusted arguments ('trustApply'). +-- +-- The 'DeclareTrusted' constructor is exported, but any use of it should be +-- verified. +newtype Trusted a = DeclareTrusted { trusted :: a } + deriving (Eq, Show) + +trustStatic :: StaticPtr a -> Trusted a +trustStatic = DeclareTrusted . deRefStaticPtr + +trustVerified :: SignaturesVerified a -> Trusted a +trustVerified = DeclareTrusted . signaturesVerified + +-- | Equivalent of '<*>' +-- +-- Trusted isn't quite applicative (no pure, not a functor), but it is +-- somehow Applicative-like: we have the equivalent of '<*>' +trustApply :: Trusted (a -> b) -> Trusted a -> Trusted b +trustApply (DeclareTrusted f) (DeclareTrusted x) = DeclareTrusted (f x) + +-- | Equivalent of 'sequenceA' +-- +-- 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 + +{------------------------------------------------------------------------------- + Role verification +-------------------------------------------------------------------------------} + +newtype SignaturesVerified a = SignaturesVerified { signaturesVerified :: a } + +-- | Errors thrown during role validation +data VerificationError = + -- | Not enough signatures signed with the appropriate keys + VerificationErrorSignatures TargetPath + + -- | The file is expired + | VerificationErrorExpired TargetPath + + -- | The file version is less than the previous version + | VerificationErrorVersion TargetPath + + -- | File information mismatch + | VerificationErrorFileInfo TargetPath + + -- | We tried to lookup file information about a particular target file, + -- 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 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. + -- + -- We record all verification errors that occurred before we gave up. + | VerificationErrorLoop VerificationHistory + deriving (Typeable) + +-- | Root metadata updated (as part of the normal update process) +data RootUpdated = RootUpdated + deriving (Typeable) + +type VerificationHistory = [Either RootUpdated VerificationError] + +#if MIN_VERSION_base(4,8,0) +deriving instance Show VerificationError +deriving instance Show RootUpdated +instance Exception VerificationError where displayException = pretty +instance Exception RootUpdated where displayException = pretty +#else +instance Exception VerificationError +instance Show VerificationError where show = pretty +instance Show RootUpdated where show = pretty +instance Exception RootUpdated +#endif + +instance Pretty VerificationError where + pretty (VerificationErrorSignatures file) = + pretty file ++ " does not have enough signatures signed with the appropriate keys" + pretty (VerificationErrorExpired file) = + pretty file ++ " is expired" + pretty (VerificationErrorVersion file) = + "Version of " ++ pretty file ++ " is less than the previous version" + pretty (VerificationErrorFileInfo file) = + "Invalid hash for " ++ pretty file + pretty (VerificationErrorUnknownTarget file) = + pretty file ++ " not found in corresponding target metadata" + pretty (VerificationErrorFileTooLarge file) = + pretty file ++ " too large" + pretty (VerificationErrorLoop es) = + "Verification loop. Errors in order:\n" + ++ unlines (map ((" " ++) . either pretty pretty) es) + +instance Pretty RootUpdated where + pretty RootUpdated = "Root information updated" + +-- | Role verification +-- +-- NOTE: We throw an error when the version number _decreases_, but allow it +-- to be the same. This is sufficient: the file number is there so that +-- attackers cannot replay old files. It cannot protect against freeze attacks +-- (that's what the expiry date is for), so "replaying" the same file is not +-- a problem. If an attacker changes the contents of the file but not the +-- version number we have an inconsistent situation, but this is not something +-- we need to worry about: in this case the attacker will need to resign the +-- file or otherwise the signature won't match, and if the attacker has +-- compromised the key then he might just as well increase the version number +-- and resign. +-- +-- NOTE 2: We are not actually verifying the signatures _themselves_ here +-- (we did that when we parsed the JSON). We are merely verifying the provenance +-- of the keys. +verifyRole' :: forall a. HasHeader a + => Trusted (RoleSpec a) -- ^ For signature validation + -> TargetPath -- ^ File source (for error messages) + -> Maybe FileVersion -- ^ Previous version (if available) + -> Maybe UTCTime -- ^ Time now (if checking expiry) + -> Signed a -> Either VerificationError (SignaturesVerified a) +verifyRole' (trusted -> RoleSpec{roleSpecThreshold = KeyThreshold threshold, ..}) + targetPath + mPrev + mNow + Signed{signatures = Signatures sigs, ..} = + runExcept go + where + go :: Except VerificationError (SignaturesVerified a) + go = do + -- Verify expiry date + case mNow of + Just now -> + when (isExpired now (Lens.get fileExpires signed)) $ + throwError $ VerificationErrorExpired targetPath + _otherwise -> + return () + + -- Verify timestamp + case mPrev of + Nothing -> return () + Just prev -> + when (Lens.get fileVersion signed < prev) $ + throwError $ VerificationErrorVersion targetPath + + -- Verify signatures + -- NOTE: We only need to verify the keys that were used; if the signature + -- 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) $ + throwError $ VerificationErrorSignatures targetPath + + -- Everything is A-OK! + return $ SignaturesVerified signed + + isRoleSpecKey :: Signature -> Bool + isRoleSpecKey Signature{..} = signatureKey `elem` roleSpecKeys + +-- | Variation on 'verifyRole' that uses key IDs rather than keys +-- +-- This is used during the bootstrap process. +-- +-- See . +verifyFingerprints :: [KeyId] + -> KeyThreshold + -> TargetPath -- ^ For error messages + -> Signed Root + -> Either VerificationError (SignaturesVerified Root) +verifyFingerprints fingerprints + (KeyThreshold threshold) + targetPath + Signed{signatures = Signatures sigs, ..} = + if length (filter isTrustedKey sigs) >= threshold + then Right $ SignaturesVerified signed + else Left $ VerificationErrorSignatures targetPath + where + isTrustedKey :: Signature -> Bool + isTrustedKey Signature{..} = someKeyId signatureKey `elem` fingerprints diff --git a/src/Hackage/Security/Util/Base64.hs b/src/Hackage/Security/Util/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Base64.hs @@ -0,0 +1,31 @@ +module Hackage.Security.Util.Base64 ( + Base64 -- opaque + , fromByteString + , toByteString + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 -- only called on B64-enc strings +import qualified Data.ByteString.Base64 as B64 + +import Hackage.Security.Util.JSON + +-- | Simple wrapper around bytestring with ToJSON and FromJSON instances that +-- use base64 encoding. +newtype Base64 = Base64 ByteString + +fromByteString :: ByteString -> Base64 +fromByteString = Base64 + +toByteString :: Base64 -> ByteString +toByteString (Base64 bs) = bs + +instance Monad m => ToJSON m Base64 where + toJSON (Base64 bs) = toJSON (C8.unpack (B64.encode bs)) + +instance ReportSchemaErrors m => FromJSON m Base64 where + fromJSON val = do + str <- fromJSON val + case B64.decode (C8.pack str) of + Left _err -> expected "base-64 encoded string" Nothing + Right bs -> return $ Base64 bs diff --git a/src/Hackage/Security/Util/Checked.hs b/src/Hackage/Security/Util/Checked.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Checked.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE IncoherentInstances #-} +#endif + +-- | Checked exceptions +module Hackage.Security.Util.Checked ( + Throws + , unthrow + -- ** Base exceptions + , throwChecked + , catchChecked + , handleChecked + , tryChecked + , checkIO + , throwUnchecked + , internalError + ) where + +import Control.Exception (Exception, IOException) +import qualified Control.Exception as Base + +#if __GLASGOW_HASKELL__ >= 708 +import GHC.Prim (coerce) +#else +import Unsafe.Coerce (unsafeCoerce) +#endif + +{------------------------------------------------------------------------------- + Basic infrastructure +-------------------------------------------------------------------------------} + +-- | Checked exceptions +class Throws e where + +#if __GLASGOW_HASKELL__ >= 708 +type role Throws representational +#endif + +unthrow :: proxy e -> (Throws e => a) -> a +unthrow _ = unWrap . coerceWrap . Wrap + +{------------------------------------------------------------------------------- + Base exceptions +-------------------------------------------------------------------------------} + +-- | Throw a checked exception +throwChecked :: (Exception e, Throws e) => e -> IO a +throwChecked = Base.throwIO + +-- | Catch a checked exception +catchChecked :: forall a e. Exception e + => (Throws e => IO a) -> (e -> IO a) -> IO a +catchChecked act = Base.catch (unthrow (Proxy :: Proxy e) act) + +-- | 'catchChecked' with the arguments reversed +handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a +handleChecked act handler = catchChecked handler act + +-- | Like 'try', but for checked exceptions +tryChecked :: Exception e => (Throws e => IO a) -> IO (Either e a) +tryChecked act = catchChecked (Right <$> act) (return . Left) + +-- | Rethrow IO exceptions as checked exceptions +checkIO :: Throws IOException => IO a -> IO a +checkIO = Base.handle $ \(ex :: IOException) -> throwChecked ex + +-- | Throw an unchecked exception +-- +-- This is just an alias for 'throw', but makes it evident that this is a very +-- intentional use of an unchecked exception. +throwUnchecked :: Exception e => e -> IO a +throwUnchecked = Base.throwIO + +-- | Variation on 'throwUnchecked' for internal errors +internalError :: String -> IO a +internalError = throwUnchecked . userError + +{------------------------------------------------------------------------------- + Auxiliary definitions (not exported) +-------------------------------------------------------------------------------} + +-- | Wrap an action that may throw a checked exception +-- +-- This is used internally in 'unthrow' to avoid impredicative +-- instantiation of the type of 'coerce'/'unsafeCoerce'. +newtype Wrap e a = Wrap { unWrap :: Throws e => a } + +coerceWrap :: Wrap e a -> Wrap (Catch e) a +#if __GLASGOW_HASKELL__ >= 708 +coerceWrap = coerce +#else +coerceWrap = unsafeCoerce +#endif + +data Proxy a = Proxy + +newtype Catch a = Catch a +instance Throws (Catch e) where diff --git a/src/Hackage/Security/Util/IO.hs b/src/Hackage/Security/Util/IO.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/IO.hs @@ -0,0 +1,94 @@ +module Hackage.Security.Util.IO ( + -- * Miscelleneous + withTempFile + , getFileSize + , handleDoesNotExist + -- * Atomic file operations + , atomicCopyFile + , atomicWriteFile + , atomicWithFile + ) where + +import Control.Exception +import Control.Monad +import System.IO.Error +import qualified Data.ByteString.Lazy as BS.L + +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + 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 + +handleDoesNotExist :: IO a -> IO (Maybe a) +handleDoesNotExist act = + handle aux (Just <$> act) + where + aux e = + if isDoesNotExistError e + then return Nothing + else throwIO e + +{------------------------------------------------------------------------------- + Atomic file operations +-------------------------------------------------------------------------------} + +-- | Copy a file atomically +-- +-- 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 + +-- | 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 + +-- | 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) diff --git a/src/Hackage/Security/Util/JSON.hs b/src/Hackage/Security/Util/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/JSON.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +-- | +module Hackage.Security.Util.JSON ( + -- * Type classes + ToJSON(..) + , FromJSON(..) + , ToObjectKey(..) + , FromObjectKey(..) + , ReportSchemaErrors(..) + , Expected + , Got + , expected' + -- * Utility + , fromJSObject + , fromJSField + , fromJSOptField + , mkObject + -- * Re-exports + , JSValue(..) + ) where + +import Control.Monad (liftM) +import Data.Map (Map) +import Data.Time +import Text.JSON.Canonical +import Network.URI +import qualified Data.Map as Map + +#if !MIN_VERSION_base(4,8,0) +import System.Locale +#endif + +import Hackage.Security.Util.Path + +{------------------------------------------------------------------------------- + ToJSON and FromJSON classes + + We parameterize over the monad here to avoid mutual module dependencies. +-------------------------------------------------------------------------------} + +class ToJSON m a where + toJSON :: a -> m JSValue + +class FromJSON m a where + fromJSON :: JSValue -> m a + +-- | Used in the 'ToJSON' instance for 'Map' +class ToObjectKey m a where + toObjectKey :: a -> m String + +-- | Used in the 'FromJSON' instance for 'Map' +class FromObjectKey m a where + fromObjectKey :: String -> m a + +-- | Monads in which we can report schema errors +class (Applicative m, Monad m) => ReportSchemaErrors m where + expected :: Expected -> Maybe Got -> m a + +type Expected = String +type Got = String + +expected' :: ReportSchemaErrors m => Expected -> JSValue -> m a +expected' descr val = expected descr (Just (describeValue val)) + where + describeValue :: JSValue -> String + describeValue (JSNull ) = "null" + describeValue (JSBool _) = "bool" + describeValue (JSNum _) = "num" + describeValue (JSString _) = "string" + describeValue (JSArray _) = "array" + describeValue (JSObject _) = "object" + +unknownField :: ReportSchemaErrors m => String -> m a +unknownField field = expected ("field " ++ show field) Nothing + +{------------------------------------------------------------------------------- + ToObjectKey and FromObjectKey instances +-------------------------------------------------------------------------------} + +instance Monad m => ToObjectKey m String where + toObjectKey = return + +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 => FromObjectKey m (Path (Rooted root)) where + fromObjectKey = liftM (rootPath Rooted) . fromObjectKey + +{------------------------------------------------------------------------------- + ToJSON and FromJSON instances +-------------------------------------------------------------------------------} + +instance Monad m => ToJSON m JSValue where + toJSON = return + +instance Monad m => FromJSON m JSValue where + fromJSON = return + +instance Monad m => ToJSON m String where + toJSON = return . JSString + +instance ReportSchemaErrors m => FromJSON m String where + fromJSON (JSString str) = return str + fromJSON val = expected' "string" val + +instance Monad m => ToJSON m Int where + toJSON = return . JSNum + +instance ReportSchemaErrors m => FromJSON m Int where + fromJSON (JSNum i) = return i + fromJSON val = expected' "int" val + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + (Monad m, ToJSON m a) => ToJSON m [a] where + toJSON = liftM JSArray . mapM toJSON + +instance +#if __GLASGOW_HASKELL__ >= 710 + {-# OVERLAPPABLE #-} +#endif + (ReportSchemaErrors m, FromJSON m a) => FromJSON m [a] where + fromJSON (JSArray as) = mapM fromJSON as + fromJSON val = expected' "array" val + +instance Monad m => ToJSON m UTCTime where + toJSON = return . JSString . formatTime defaultTimeLocale "%FT%TZ" + +instance ReportSchemaErrors m => FromJSON m UTCTime where + fromJSON enc = do + str <- fromJSON enc + 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) + where + parseTimeM _trim = parseTime +#endif + +instance ( Monad m + , ToObjectKey m k + , ToJSON m a + ) => ToJSON m (Map k a) where + toJSON = liftM JSObject . mapM aux . Map.toList + where + aux :: (k, a) -> m (String, JSValue) + aux (k, a) = do k' <- toObjectKey k; a' <- toJSON a; return (k', a') + +instance ( ReportSchemaErrors m + , Ord k + , FromObjectKey m k + , FromJSON m a + ) => FromJSON m (Map k a) where + fromJSON enc = do + obj <- fromJSObject enc + Map.fromList <$> mapM aux obj + where + aux :: (String, JSValue) -> m (k, a) + aux (k, a) = (,) <$> fromObjectKey k <*> fromJSON a + +instance Monad m => ToJSON m URI where + toJSON = toJSON . show + +instance ReportSchemaErrors m => FromJSON m URI where + fromJSON enc = do + str <- fromJSON enc + case parseURI str of + Nothing -> expected "valid URI" (Just str) + Just uri -> return uri + +{------------------------------------------------------------------------------- + Utility +-------------------------------------------------------------------------------} + +fromJSObject :: ReportSchemaErrors m => JSValue -> m [(String, JSValue)] +fromJSObject (JSObject obj) = return obj +fromJSObject val = expected' "object" val + +-- | Extract a field from a JSON object +fromJSField :: (ReportSchemaErrors m, FromJSON m a) + => JSValue -> String -> m a +fromJSField val nm = do + obj <- fromJSObject val + case lookup nm obj of + Just fld -> fromJSON fld + Nothing -> unknownField nm + +fromJSOptField :: (ReportSchemaErrors m, FromJSON m a) + => JSValue -> String -> m (Maybe a) +fromJSOptField val nm = do + obj <- fromJSObject val + case lookup nm obj of + Just fld -> Just <$> fromJSON fld + Nothing -> return Nothing + +mkObject :: forall m. Monad m => [(String, m JSValue)] -> m JSValue +mkObject = liftM JSObject . sequenceFields + where + sequenceFields :: [(String, m JSValue)] -> m [(String, JSValue)] + sequenceFields [] = return [] + sequenceFields ((fld,val):flds) = do val' <- val + flds' <- sequenceFields flds + return ((fld,val'):flds') diff --git a/src/Hackage/Security/Util/Lens.hs b/src/Hackage/Security/Util/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Lens.hs @@ -0,0 +1,48 @@ +-- | Some very simple lens definitions (to avoid further dependencies) +-- +-- Intended to be double-imported +-- > import Hackage.Security.Util.Lens (Lens) +-- > import qualified Hackage.Security.Util.Lens as Lens +module Hackage.Security.Util.Lens ( + -- * Generic definitions + Lens + , Lens' + , get + , modify + , set + -- * Specific lenses + , lookupM + ) where + +import Control.Applicative +import Data.Functor.Identity + +{------------------------------------------------------------------------------- + General definitions +-------------------------------------------------------------------------------} + +-- | Polymorphic lens +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +-- | Monomorphic lens +type Lens' s a = Lens s s a a + +get :: Lens' s a -> s -> a +get l = getConst . l Const + +modify :: Lens s t a b -> (a -> b) -> s -> t +modify l f = runIdentity . l (Identity . f) + +set :: Lens s t a b -> b -> s -> t +set l = modify l . const + +{------------------------------------------------------------------------------- + Specific lenses +-------------------------------------------------------------------------------} + +lookupM :: forall a b. (Eq a, Monoid b) => a -> Lens' [(a, b)] b +lookupM a f = go + where + go [] = (\b' -> [(a, b')] ) <$> f mempty + go ((a', b):xs) | a == a' = (\b' -> (a, b'):xs ) <$> f b + | otherwise = (\xs' -> (a', b):xs') <$> go xs diff --git a/src/Hackage/Security/Util/Path.hs b/src/Hackage/Security/Util/Path.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Path.hs @@ -0,0 +1,515 @@ +-- | A more type-safe version of file paths +-- +-- This module is intended to replace imports of System.FilePath, and +-- additionally exports thin wrappers around common IO functions. To facilitate +-- importing this module unqualified we also re-export some definitions from +-- System.IO (importing both would likely lead to name clashes). +-- +-- 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 + , Unrooted + , Rooted(..) + , UnrootedPath + , IsRoot(..) + -- ** Construcion and destruction + , fragment + , fragment' + , () + , rootPath + , unrootPath + , unrootPath' + , castRoot + -- ** Unrooted paths + , joinFragments + , splitFragments + , toUnrootedFilePath + , fromUnrootedFilePath + , isPathPrefixOf + -- ** FilePath-like operations + , takeDirectory + , takeFileName + , (<.>) + , splitExtension + -- * File-system paths + , IsFileSystemRoot + , Relative + , Absolute + , HomeDir + , AbsolutePath + , RelativePath + , FileSystemPath(..) + -- ** Conversions + , toFilePath + , fromFilePath + , makeAbsolute + , toAbsoluteFilePath + , fromAbsoluteFilePath + -- ** Wrappers around System.IO + , openTempFile + , withFileInReadMode + -- ** Wrappers around Data.ByteString.* + , readLazyByteString + , readStrictByteString + -- ** Wrappers around System.Directory + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , getDirectoryContents + , getRecursiveContents + , getTemporaryDirectory + , removeFile + , renameFile + -- ** Wrappers around Codec.Archive.Tar.* + , TarballRoot + , TarballPath + , tarIndexLookup + , tarAppend + -- * Paths in URIs + , WebRoot + , URIPath + , uriPath + , modifyUriPath + -- * Re-exports + , IO.IOMode(..) + , IO.BufferMode(..) + , IO.Handle + , IO.hSetBuffering + , IO.hClose + , IO.hFileSize + ) where + +import Control.Monad +import Data.Function (on) +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.IO as IO +import qualified System.Directory as Dir +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Index as TarIndex +import qualified Network.URI as URI + +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') + +-- | 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 + +{------------------------------------------------------------------------------- + Constructing and destructing paths +-------------------------------------------------------------------------------} + +fragment :: Fragment -> UnrootedPath +fragment = PathSnoc PathNil + +-- | For convenience: combine `fragment` and `mkFragment` +-- +-- This can therefore throw the same runtime errors as `mkFragment`. +fragment' :: String -> UnrootedPath +fragment' = fragment . mkFragment + +() :: Path a -> UnrootedPath -> Path a +ps PathNil = ps +ps PathSnoc qs q = PathSnoc (ps qs) q + +rootPath :: forall root. Rooted root -> UnrootedPath -> Path (Rooted root) +rootPath root = go + 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 + +{------------------------------------------------------------------------------- + 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 + +splitFragments :: UnrootedPath -> [Fragment] +splitFragments = go [] + where + go :: [Fragment] -> UnrootedPath -> [Fragment] + go acc PathNil = acc + go acc (PathSnoc ps p) = go (p:acc) ps + +toUnrootedFilePath :: UnrootedPath -> FilePath +toUnrootedFilePath = FilePath.joinPath . map unFragment . splitFragments + +fromUnrootedFilePath :: FilePath -> UnrootedPath +fromUnrootedFilePath = joinFragments . map mkFragment . splitPath + +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 + +{------------------------------------------------------------------------------- + FilePath-like operations +-------------------------------------------------------------------------------} + +takeDirectory :: Path a -> Path a +takeDirectory (PathRoot root) = PathRoot root +takeDirectory PathNil = PathNil +takeDirectory (PathSnoc ps _) = ps + +takeFileName :: Path a -> Fragment +takeFileName (PathRoot _) = error "takeFileName: empty path" +takeFileName PathNil = error "takeFileName: empty path" +takeFileName (PathSnoc _ p) = p + +(<.>) :: 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 + +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) + +{------------------------------------------------------------------------------- + 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 IsRoot Relative where showRoot _ = "." +instance IsRoot Absolute where showRoot _ = "/" +instance IsRoot HomeDir where showRoot _ = "~" + +instance IsFileSystemRoot Relative where + interpretRoot _ = Dir.getCurrentDirectory + +instance IsFileSystemRoot Absolute where + interpretRoot _ = return "/" + +instance IsFileSystemRoot HomeDir where + interpretRoot _ = Dir.getHomeDirectory + +-- | Abstract over a file system root +-- +-- see 'fromFilePath' +data FileSystemPath where + FileSystemPath :: IsFileSystemRoot root => Path (Rooted root) -> FileSystemPath + +{------------------------------------------------------------------------------- + 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) + +makeAbsolute :: FileSystemPath -> IO AbsolutePath +makeAbsolute (FileSystemPath path) = do + let (root, unrooted) = unrootPath path + rootFilePath <- fromUnrootedFilePath <$> interpretRoot root + return $ rootPath Rooted (rootFilePath unrooted) + +toAbsoluteFilePath :: IsFileSystemRoot root => Path (Rooted root) -> IO FilePath +toAbsoluteFilePath = fmap toFilePath . makeAbsolute . FileSystemPath + +fromAbsoluteFilePath :: FilePath -> AbsolutePath +fromAbsoluteFilePath ('/':path) = rootPath Rooted (fromUnrootedFilePath path) +fromAbsoluteFilePath _ = 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 + filePath <- toAbsoluteFilePath path + IO.withFile filePath IO.ReadMode callback + +-- | Wrapper around 'openBinaryTempFileWithDefaultPermissions' +openTempFile :: forall root. IsFileSystemRoot root + => Path (Rooted root) -> String -> IO (AbsolutePath, IO.Handle) +openTempFile path template = do + filePath <- toAbsoluteFilePath path + (tempFilePath, h) <- IO.openBinaryTempFileWithDefaultPermissions filePath template + return (fromAbsoluteFilePath tempFilePath, h) + +{------------------------------------------------------------------------------- + Wrappers around Data.ByteString.* +-------------------------------------------------------------------------------} + +readLazyByteString :: IsFileSystemRoot root + => Path (Rooted 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 path = do + filePath <- toAbsoluteFilePath path + BS.readFile filePath + +{------------------------------------------------------------------------------- + Wrappers around System.Directory +-------------------------------------------------------------------------------} + +createDirectoryIfMissing :: IsFileSystemRoot root + => Bool -> Path (Rooted root) -> IO () +createDirectoryIfMissing createParents path = do + filePath <- toAbsoluteFilePath path + Dir.createDirectoryIfMissing createParents filePath + +doesFileExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool +doesFileExist path = do + filePath <- toAbsoluteFilePath path + Dir.doesFileExist filePath + +doesDirectoryExist :: IsFileSystemRoot root => Path (Rooted root) -> IO Bool +doesDirectoryExist path = do + filePath <- toAbsoluteFilePath path + Dir.doesDirectoryExist filePath + +removeFile :: IsFileSystemRoot root => Path (Rooted root) -> IO () +removeFile path = do + filePath <- toAbsoluteFilePath path + Dir.removeFile filePath + +getTemporaryDirectory :: IO AbsolutePath +getTemporaryDirectory = fromAbsoluteFilePath <$> Dir.getTemporaryDirectory + +-- | Return the immediate children of a directory +-- +-- Filters out @"."@ and @".."@. +getDirectoryContents :: IsFileSystemRoot root + => Path (Rooted root) -> IO [UnrootedPath] +getDirectoryContents path = do + filePath <- toAbsoluteFilePath path + fragments <$> Dir.getDirectoryContents filePath + where + fragments :: [String] -> [UnrootedPath] + fragments = map fragment' . filter (not . skip) + + skip :: String -> Bool + skip "." = True + skip ".." = True + skip _ = False + +-- | 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 + where + go :: UnrootedPath -> IO [UnrootedPath] + go subdir = do + entries <- getDirectoryContents (root subdir) + liftM concat $ forM entries $ \entry -> do + let path = subdir entry + isDirectory <- doesDirectoryExist (root path) + if isDirectory then go path + else return [path] + +renameFile :: (IsFileSystemRoot root, IsFileSystemRoot root1) + => Path (Rooted root) -- ^ Old + -> Path (Rooted root1) -- ^ New + -> IO () +renameFile old new = do + old' <- toAbsoluteFilePath old + new' <- toAbsoluteFilePath new + Dir.renameFile old' new' + +getCurrentDirectory :: IO AbsolutePath +getCurrentDirectory = do + cwd <- Dir.getCurrentDirectory + makeAbsolute $ fromFilePath cwd + +{------------------------------------------------------------------------------- + Wrappers around Codec.Archive.Tar.* +-------------------------------------------------------------------------------} + +data TarballRoot +type TarballPath = Path (Rooted TarballRoot) + +instance Show (Rooted TarballRoot) where show _ = "" + +tarIndexLookup :: TarIndex.TarIndex -> TarballPath -> Maybe TarIndex.TarIndexEntry +tarIndexLookup index path = TarIndex.lookup index path' + where + path' :: FilePath + 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 + -> IO () +tarAppend tarFile baseDir contents = do + tarFile' <- toAbsoluteFilePath tarFile + baseDir' <- toAbsoluteFilePath baseDir + Tar.append tarFile' baseDir' contents' + where + contents' :: [FilePath] + contents' = map (toUnrootedFilePath . unrootPath') contents + +{------------------------------------------------------------------------------- + Wrappers around Network.URI +-------------------------------------------------------------------------------} + +data WebRoot + +type URIPath = Path (Rooted WebRoot) + +toURIPath :: FilePath -> URIPath +toURIPath = rootPath Rooted . fromUnrootedFilePath + +fromURIPath :: URIPath -> FilePath +fromURIPath = toUnrootedFilePath . unrootPath' + +uriPath :: URI.URI -> URIPath +uriPath = toURIPath . URI.uriPath + +modifyUriPath :: URI.URI -> (URIPath -> URIPath) -> 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 +-------------------------------------------------------------------------------} + +-- | 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' diff --git a/src/Hackage/Security/Util/Pretty.hs b/src/Hackage/Security/Util/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Pretty.hs @@ -0,0 +1,8 @@ +-- | Producing human-reaadable strings +module Hackage.Security.Util.Pretty ( + Pretty(..) + ) where + +-- | Produce a human-readable string +class Pretty a where + pretty :: a -> String diff --git a/src/Hackage/Security/Util/Some.hs b/src/Hackage/Security/Util/Some.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Some.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +-- | Hiding existentials +module Hackage.Security.Util.Some ( + Some(..) + -- ** Equality + , DictEq(..) + , SomeEq(..) + -- ** Serialization + , DictShow(..) + , SomeShow(..) + -- ** Type checking + , typecheckSome +#if !MIN_VERSION_base(4,7,0) + -- ** Compatibility with base < 4.7 + , tyConSome +#endif + ) where + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable) +#else +import qualified Data.Typeable as Typeable +#endif + +import Hackage.Security.Util.TypedEmbedded + +data Some f = forall a. Some (f a) + +#if MIN_VERSION_base(4,7,0) +deriving instance Typeable Some +#else +tyConSome :: Typeable.TyCon +tyConSome = Typeable.mkTyCon3 "hackage-security" "Hackage.Security.Util.Some" "Some" +#endif + +{------------------------------------------------------------------------------- + Equality on Some types + + Note that we cannot really do something similar for ordering; what value + should we return for + + > Some (f x) `compare` Some (f x') + + where @x :: a@, @x' :: a'@ and @a /= a'@? These are incomparable. +-------------------------------------------------------------------------------} + +data DictEq a where + DictEq :: Eq a => DictEq a + +-- | Type @f@ satisfies @SomeEq f@ if @f a@ satisfies @Eq@ independent of @a@ +class SomeEq f where + someEq :: DictEq (f a) + +instance (Typed f, SomeEq f) => Eq (Some f) where + Some (x :: f a) == Some (y :: f a') = + case unify (typeOf x) (typeOf y) of + Nothing -> False + Just Refl -> case someEq :: DictEq (f a) of DictEq -> x == y + +{------------------------------------------------------------------------------- + Showing Some types +-------------------------------------------------------------------------------} + +data DictShow a where + DictShow :: Show a => DictShow a + +-- | Type @f@ satisfies @SomeShow f@ if @f a@ satisfies @Show@ independent of @a@ +class SomeShow f where + someShow :: DictShow (f a) + +instance SomeShow f => Show (Some f) where + show (Some (x :: f a)) = + case someShow :: DictShow (f a) of DictShow -> show x + +{------------------------------------------------------------------------------- + Typechecking Some types +-------------------------------------------------------------------------------} + +typecheckSome :: Typed f => Some f -> Some (TypeOf f) -> Bool +typecheckSome (Some x) (Some typ) = + case unify (typeOf x) typ of + Just Refl -> True + Nothing -> False diff --git a/src/Hackage/Security/Util/Stack.hs b/src/Hackage/Security/Util/Stack.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/Stack.hs @@ -0,0 +1,8 @@ +-- | Heterogenous lists +module Hackage.Security.Util.Stack ( + (:-)(..) + ) where + +data h :- t = h :- t + deriving (Eq, Show) +infixr 5 :- diff --git a/src/Hackage/Security/Util/TypedEmbedded.hs b/src/Hackage/Security/Util/TypedEmbedded.hs new file mode 100644 --- /dev/null +++ b/src/Hackage/Security/Util/TypedEmbedded.hs @@ -0,0 +1,38 @@ +-- | Embedded languages with meta level types +module Hackage.Security.Util.TypedEmbedded ( + (:=:)(Refl) + , TypeOf + , Unify(..) + , Typed(..) + , AsType(..) + ) where + +-- | Type equality proofs +-- +-- This is a direct copy of "type-equality:Data.Type.Equality"; if we don't +-- mind the dependency we can use that package directly. +data a :=: b where + Refl :: a :=: a + +type family TypeOf (f :: * -> *) :: * -> * + +-- | Equality check that gives us a type-level equality proof. +class Unify f where + unify :: f typ -> f typ' -> Maybe (typ :=: typ') + +-- | Embedded languages with type inference +class Unify (TypeOf f) => Typed f where + typeOf :: f typ -> TypeOf f typ + +-- | Cast from one type to another +-- +-- By default (for language with type inference) we just compare the types +-- returned by 'typeOf'; however, in languages in which terms can have more +-- than one type this may not be the correct definition (indeed, for such +-- languages we cannot give an instance of 'Typed'). +class AsType f where + asType :: f typ -> TypeOf f typ' -> Maybe (f typ') + default asType :: Typed f => f typ -> TypeOf f typ' -> Maybe (f typ') + asType x typ = case unify (typeOf x) typ of + Just Refl -> Just x + Nothing -> Nothing diff --git a/src/Prelude.hs b/src/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Prelude.hs @@ -0,0 +1,32 @@ +-- | Smooth over differences between various ghc versions by making older +-- preludes look like 4.8.0 +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} +module Prelude ( + module P +#if !MIN_VERSION_base(4,8,0) + , Applicative(..) + , Monoid(..) + , (<$>) + , (<$) + , traverse + , displayException +#endif + ) where + +#if MIN_VERSION_base(4,8,0) +import "base" Prelude as P +#else +#if MIN_VERSION_base(4,6,0) +import "base" Prelude as P +#else +import "base" Prelude as P hiding (catch) +#endif +import Control.Applicative +import Control.Exception (Exception) +import Data.Monoid +import Data.Traversable (traverse) + +displayException :: Exception e => e -> String +displayException = show +#endif diff --git a/src/Text/JSON/Canonical.hs b/src/Text/JSON/Canonical.hs new file mode 100644 --- /dev/null +++ b/src/Text/JSON/Canonical.hs @@ -0,0 +1,198 @@ +-------------------------------------------------------------------- +-- | +-- Module : Text.JSON.Parsec +-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015 +-- +-- +-- Minimal implementation of Canonical JSON. +-- +-- +-- +-- A "canonical JSON" format is provided in order to provide meaningful and +-- repeatable hashes of JSON-encoded data. Canonical JSON is parsable with any +-- full JSON parser, but security-conscious applications will want to verify +-- that input is in canonical form before authenticating any hash or signature +-- on that input. +-- +-- This implementation is derived from the json parser from the json package, +-- with simplifications to meet the Canonical JSON grammar. +-- + +module Text.JSON.Canonical + ( JSValue(..) + , parseCanonicalJSON + , renderCanonicalJSON + ) where + +import Text.ParserCombinators.Parsec + ( CharParser, (<|>), (), many, between, sepBy + , satisfy, char, string, digit, spaces + , parse ) +import Data.Char (isDigit, digitToInt) +import Data.List (foldl', sortBy) +import Data.Function (on) +import qualified Data.ByteString.Lazy.Char8 as BS + + +data JSValue + = JSNull + | JSBool !Bool + | JSNum !Int + | JSString String + | JSArray [JSValue] + | JSObject [(String, JSValue)] + deriving (Show, Read, Eq, Ord) + +------------------------------------------------------------------------------ + +renderCanonicalJSON :: JSValue -> BS.ByteString +renderCanonicalJSON v = BS.pack (s_value v []) + +s_value :: JSValue -> ShowS +s_value JSNull = showString "null" +s_value (JSBool False) = showString "false" +s_value (JSBool True) = showString "true" +s_value (JSNum n) = shows n +s_value (JSString s) = s_string s +s_value (JSArray vs) = s_array vs +s_value (JSObject fs) = s_object (sortBy (compare `on` fst) fs) + +s_string :: String -> ShowS +s_string s = showChar '"' . showl s + where showl [] = showChar '"' + showl (c:cs) = s_char c . showl cs + + s_char '"' = showChar '\\' . showChar '"' + s_char '\\' = showChar '\\' . showChar '\\' + s_char c = showChar c + +s_array :: [JSValue] -> ShowS +s_array [] = showString "[]" +s_array (v0:vs0) = showChar '[' . s_value v0 . showl vs0 + where showl [] = showChar ']' + showl (v:vs) = showChar ',' . s_value v . showl vs + +s_object :: [(String, JSValue)] -> ShowS +s_object [] = showString "{}" +s_object ((k0,v0):kvs0) = showChar '{' . s_string k0 + . showChar ':' . s_value v0 + . showl kvs0 + where showl [] = showChar '}' + showl ((k,v):kvs) = showChar ',' . s_string k + . showChar ':' . s_value v + . showl kvs + +------------------------------------------------------------------------------ + +parseCanonicalJSON :: BS.ByteString -> Either String JSValue +parseCanonicalJSON = either (Left . show) Right + . parse p_value "" + . BS.unpack + +p_value :: CharParser () JSValue +p_value = spaces *> p_jvalue + +tok :: CharParser () a -> CharParser () a +tok p = p <* spaces + +{- +value: + string + number + object + array + true + false + null +-} +p_jvalue :: CharParser () JSValue +p_jvalue = (JSNull <$ p_null) + <|> (JSBool <$> p_boolean) + <|> (JSArray <$> p_array) + <|> (JSString <$> p_string) + <|> (JSObject <$> p_object) + <|> (JSNum <$> p_number) + "JSON value" + +p_null :: CharParser () () +p_null = tok (string "null") >> return () + +p_boolean :: CharParser () Bool +p_boolean = tok + ( (True <$ string "true") + <|> (False <$ string "false") + ) +{- +array: + [] + [ elements ] +elements: + value + value , elements +-} +p_array :: CharParser () [JSValue] +p_array = between (tok (char '[')) (tok (char ']')) + $ p_jvalue `sepBy` tok (char ',') + +{- +string: + "" + " chars " +chars: + char + char chars +char: + any byte except hex 22 (") or hex 5C (\) + \\ + \" +-} +p_string :: CharParser () String +p_string = between (tok (char '"')) (tok (char '"')) (many p_char) + where p_char = (char '\\' >> p_esc) + <|> (satisfy (\x -> x /= '"' && x /= '\\')) + + p_esc = ('"' <$ char '"') + <|> ('\\' <$ char '\\') + "escape character" +{- +object: + {} + { members } +members: + pair + pair , members +pair: + string : value +-} +p_object :: CharParser () [(String,JSValue)] +p_object = between (tok (char '{')) (tok (char '}')) + $ p_field `sepBy` tok (char ',') + where p_field = (,) <$> (p_string <* tok (char ':')) <*> p_jvalue + +{- +number: + int +int: + digit + digit1-9 digits + - digit1-9 + - digit1-9 digits +digits: + digit + digit digits +-} +p_number :: CharParser () Int +p_number = tok + ( (char '-' *> (negate <$> pnat)) + <|> pnat + <|> zero + ) + where pnat = (\d ds -> strToInt (d:ds)) <$> digit19 <*> manyN 8 digit + digit19 = satisfy (\c -> isDigit c && c /= '0') "digit" + strToInt = foldl' (\x d -> 10*x + digitToInt d) 0 + zero = 0 <$ char '0' + +manyN :: Int -> CharParser () a -> CharParser () [a] +manyN 0 _ = pure [] +manyN n p = ((:) <$> p <*> manyN (n-1) p) + <|> pure []