packages feed

hackage-security (empty) → 0.1.0.0

raw patch · 41 files changed

+6709/−0 lines, 41 filesdep +Cabaldep +SHAdep +basesetup-changed

Dependencies added: Cabal, SHA, base, base64-bytestring, bytestring, containers, directory, ed25519, filepath, ghc-prim, mtl, network-uri, old-locale, parsec, tar, template-haskell, time, transformers, zlib

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hackage-security.cabal view
@@ -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+                     (<http://hackage.haskell.org/>).  It is based on The Update+                     Framework (<http://theupdateframework.com/>), a set of+                     recommendations developed by security researchers at+                     various universities in the US as well as developers on the+                     Tor project (<https://www.torproject.org/>).+                     .+                     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.
+ src/Hackage/Security/Client.hs view
@@ -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 <https://github.com/theupdateframework/tuf/issues/287>.+    maxNumIterations :: Int+    maxNumIterations = 5++    -- The spec stipulates that on a verification error we must download new+    -- root information and start over. However, in order to prevent DoS attacks+    -- we limit how often we go round this loop.+    -- See als <https://github.com/theupdateframework/tuf/issues/287>.+    limitIterations :: (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 <https://github.com/theupdateframework/tuf/issues/283>.+    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 <https://github.com/theupdateframework/tuf/issues/286>+    rootChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool+    rootChanged Nothing    _   = False+    rootChanged (Just old) new = not (trustedFileInfoEqual old new)++    -- For any file other than the root we consider the file to have changed+    -- if we do not yet have a local snapshot to tell us the old info.+    fileChanged :: Maybe (Trusted FileInfo) -> Trusted FileInfo -> Bool+    fileChanged Nothing    _   = True+    fileChanged (Just old) new = not (trustedFileInfoEqual old new)++    -- We don't actually _do_ anything with the mirrors file until the next call+    -- to 'checkUpdates', because we want to use a single server for a single+    -- check-for-updates request. If validation was successful the repository+    -- will have cached the mirrors file and it will be available on the next+    -- request.+    newMirrors :: Trusted Mirrors -> 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 <https://github.com/theupdateframework/tuf/issues/285>.+--+-- 2. Additionally, deleting the local timestamp and snapshot protects against+--    an attack where an attacker has set the file version of the snapshot or+--    timestamp to MAX_INT, thereby making further updates impossible.+--    (Such an attack would require a timestamp/snapshot key compromise.)+--+-- However, we _ONLY_ do this when the root information has actually changed.+-- If we did this unconditionally it would mean that we delete the locally+-- cached timestamp whenever the version on the remote timestamp is invalid,+-- thereby rendering the file version on the timestamp and the snapshot useless.+-- See <https://github.com/theupdateframework/tuf/issues/283#issuecomment-115739521>+updateRoot :: (Throws VerificationError, Throws SomeRemoteError)+           => Repository+           -> 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+    -- <https://github.com/theupdateframework/tuf/issues/282#issuecomment-102468421>.+    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
+ src/Hackage/Security/Client/Formats.hs view
@@ -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"
+ src/Hackage/Security/Client/Repository.hs view
@@ -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
+ src/Hackage/Security/Client/Repository/Cache.hs view
@@ -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 <https://github.com/well-typed/hackage-security/issues/84>.+rebuildTarIndex :: Cache -> IO ()+rebuildTarIndex cache = do+    entries <- Tar.read <$> readLazyByteString (cachedIndexTarPath cache)+    case TarIndex.build entries of+      Left  ex    -> throwUnchecked ex+      Right index ->+        atomicWithFile (cachedIndexIdxPath cache) $ \h -> do+          hSetBuffering h (BlockBuffering Nothing)+          BS.Builder.hPutBuilder h $ TarIndex.serialise index++-- | 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
+ src/Hackage/Security/Client/Repository/HttpLib.hs view
@@ -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
+ src/Hackage/Security/Client/Repository/Local.hs view
@@ -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
+ src/Hackage/Security/Client/Repository/Remote.hs view
@@ -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
+ src/Hackage/Security/JSON.hs view
@@ -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
+ src/Hackage/Security/Key.hs view
@@ -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
+ src/Hackage/Security/Key/Env.hs view
@@ -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
+ src/Hackage/Security/Server.hs view
@@ -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
+ src/Hackage/Security/TUF.hs view
@@ -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+  )
+ src/Hackage/Security/TUF/Common.hs view
@@ -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
+ src/Hackage/Security/TUF/FileInfo.hs view
@@ -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{..}
+ src/Hackage/Security/TUF/FileMap.hs view
@@ -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)
+ src/Hackage/Security/TUF/Header.hs view
@@ -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
+ src/Hackage/Security/TUF/Layout.hs view
@@ -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 _ = "<repo>"++-- | Layout of a repository+data RepoLayout = RepoLayout {+      -- | TUF root metadata+      repoLayoutRoot :: RepoPath++      -- | TUF timestamp+    , repoLayoutTimestamp :: RepoPath++      -- | TUF snapshot+    , repoLayoutSnapshot :: RepoPath++      -- | TUF mirrors list+    , repoLayoutMirrors :: RepoPath++      -- | Compressed index tarball+    , repoLayoutIndexTarGz :: RepoPath++      -- | Uncompressed index tarball+    , repoLayoutIndexTar :: RepoPath++      -- | Path to the package tarball+    , repoLayoutPkgTarGz :: PackageIdentifier -> RepoPath++      -- | Layout of the index+      --+      -- Since the repository hosts the index, the layout of the index is+      -- not independent of the layout of the repository.+    , repoIndexLayout :: IndexLayout+    }++-- | The layout used on Hackage+hackageRepoLayout :: RepoLayout+hackageRepoLayout = RepoLayout {+      repoLayoutRoot       = rp $ fragment' "root.json"+    , repoLayoutTimestamp  = rp $ fragment' "timestamp.json"+    , repoLayoutSnapshot   = rp $ fragment' "snapshot.json"+    , repoLayoutMirrors    = rp $ fragment' "mirrors.json"+    , repoLayoutIndexTarGz = rp $ fragment' "01-index.tar.gz"+    , repoLayoutIndexTar   = rp $ fragment' "01-index.tar"+    , repoLayoutPkgTarGz   = \pkgId -> rp $ fragment' "package" </> pkgFile pkgId+    , repoIndexLayout      = hackageIndexLayout+    }+  where+    pkgFile :: PackageIdentifier -> UnrootedPath+    pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz"++    rp :: UnrootedPath -> RepoPath+    rp = rootPath Rooted++-- | Layout used by cabal for ("legacy") local repos+--+-- Obviously, such repos do not normally contain any of the TUF files, so their+-- location is more or less arbitrary here.+cabalLocalRepoLayout :: RepoLayout+cabalLocalRepoLayout = hackageRepoLayout {+      repoLayoutPkgTarGz = \pkgId -> rp $ pkgLoc pkgId </> pkgFile pkgId+    }+  where+    pkgLoc :: PackageIdentifier -> UnrootedPath+    pkgLoc pkgId = joinFragments [+          mkFragment $ display (packageName    pkgId)+        , mkFragment $ display (packageVersion pkgId)+        ]++    pkgFile :: PackageIdentifier -> UnrootedPath+    pkgFile pkgId = fragment' (display pkgId) <.> "tar.gz"++    rp :: UnrootedPath -> RepoPath+    rp = rootPath Rooted++anchorRepoPathLocally :: IsFileSystemRoot root+                      => Path (Rooted root) -> RepoPath -> Path (Rooted root)+anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath' repoPath++anchorRepoPathRemotely :: URIPath -> RepoPath -> URIPath+anchorRepoPathRemotely remoteRoot repoPath = remoteRoot </> unrootPath' repoPath++{-------------------------------------------------------------------------------+  Index layout+-------------------------------------------------------------------------------}++-- | The root of the index tarball+data IndexRoot++-- | Paths relative to the root of the index tarball+type IndexPath = Path (Rooted RepoRoot)++instance IsRoot IndexRoot where showRoot _ = "<index>"++-- | Layout of the files within the index tarball+data IndexLayout = IndexLayout  {+      -- | TUF metadata for a package+      indexLayoutPkgMetadata :: PackageIdentifier -> IndexPath++      -- | Package .cabal file+    , indexLayoutPkgCabal :: PackageIdentifier -> IndexPath+    }++-- | The layout of the index as maintained on Hackage+hackageIndexLayout :: IndexLayout+hackageIndexLayout = IndexLayout {+      indexLayoutPkgMetadata = \pkgId -> rp $ pkgLoc pkgId </> pkgMetadata+    , indexLayoutPkgCabal    = \pkgId -> rp $ pkgLoc pkgId </> pkgCabal pkgId+    }+  where+    pkgLoc :: PackageIdentifier -> UnrootedPath+    pkgLoc pkgId = joinFragments [+          mkFragment $ display (packageName    pkgId)+        , mkFragment $ display (packageVersion pkgId)+        ]++    pkgCabal :: PackageIdentifier -> UnrootedPath+    pkgCabal pkgId = fragment' (display (packageName pkgId)) <.> "cabal"++    pkgMetadata :: UnrootedPath+    pkgMetadata = fragment' "package" <.> "json"++    rp :: UnrootedPath -> IndexPath+    rp = rootPath Rooted++{-------------------------------------------------------------------------------+  Cache layout+-------------------------------------------------------------------------------}++-- | The cache directory+data CacheRoot+type CachePath = Path (Rooted CacheRoot)++instance IsRoot CacheRoot where showRoot _ = "<cache>"++-- | Location of the various files we cache+--+-- Although the generic TUF algorithms do not care how we organize the cache,+-- we nonetheless specity this here because as long as there are tools which+-- access files in the cache directly we need to define the cache layout.+-- See also comments for 'defaultCacheLayout'.+data CacheLayout = CacheLayout {+    -- | TUF root metadata+    cacheLayoutRoot :: CachePath++    -- | TUF timestamp+  , cacheLayoutTimestamp :: CachePath++    -- | TUF snapshot+  , cacheLayoutSnapshot :: CachePath++    -- | TUF mirrors list+  , cacheLayoutMirrors :: CachePath++    -- | Uncompressed index tarball+  , cacheLayoutIndexTar :: CachePath++    -- | Index to the uncompressed index tarball+  , cacheLayoutIndexIdx :: CachePath++    -- | Compressed index tarball (if cached)+  , cacheLayoutIndexTarGz :: Maybe CachePath+  }++-- | The cache layout cabal-install uses+--+-- We cache the index as @<cache>/00-index.tar@; this is important because+-- `cabal-install` expects to find it there (and does not currently go through+-- the hackage-security library to get files from the index).+cabalCacheLayout :: CacheLayout+cabalCacheLayout = CacheLayout {+      cacheLayoutRoot       = rp $ fragment' "root.json"+    , cacheLayoutTimestamp  = rp $ fragment' "timestamp.json"+    , cacheLayoutSnapshot   = rp $ fragment' "snapshot.json"+    , cacheLayoutMirrors    = rp $ fragment' "mirrors.json"+    , cacheLayoutIndexTar   = rp $ fragment' "00-index.tar"+    , cacheLayoutIndexIdx   = rp $ fragment' "00-index.tar.idx"+    , cacheLayoutIndexTarGz = Nothing+    }+  where+    rp :: UnrootedPath -> CachePath+    rp = rootPath Rooted++-- | Anchor a cache path to the location of the cache+anchorCachePath :: IsFileSystemRoot root+                => Path (Rooted root) -> CachePath -> Path (Rooted root)+anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath' cachePath
+ src/Hackage/Security/TUF/Mirrors.hs view
@@ -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
+ src/Hackage/Security/TUF/Patterns.hs view
@@ -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"
+ src/Hackage/Security/TUF/Root.hs view
@@ -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{..}
+ src/Hackage/Security/TUF/Signed.hs view
@@ -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)+       ]
+ src/Hackage/Security/TUF/Snapshot.hs view
@@ -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
+ src/Hackage/Security/TUF/Targets.hs view
@@ -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
+ src/Hackage/Security/TUF/Timestamp.hs view
@@ -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
+ src/Hackage/Security/Trusted.hs view
@@ -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
+ src/Hackage/Security/Trusted/TCB.hs view
@@ -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 <http://en.wikipedia.org/wiki/Public_key_fingerprint>.+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
+ src/Hackage/Security/Util/Base64.hs view
@@ -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
+ src/Hackage/Security/Util/Checked.hs view
@@ -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
+ src/Hackage/Security/Util/IO.hs view
@@ -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)
+ src/Hackage/Security/Util/JSON.hs view
@@ -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')
+ src/Hackage/Security/Util/Lens.hs view
@@ -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
+ src/Hackage/Security/Util/Path.hs view
@@ -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 _ = "<tarball>"++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'
+ src/Hackage/Security/Util/Pretty.hs view
@@ -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
+ src/Hackage/Security/Util/Some.hs view
@@ -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
+ src/Hackage/Security/Util/Stack.hs view
@@ -0,0 +1,8 @@+-- | Heterogenous lists+module Hackage.Security.Util.Stack (+    (:-)(..)+  ) where++data h :- t = h :- t+  deriving (Eq, Show)+infixr 5 :-
+ src/Hackage/Security/Util/TypedEmbedded.hs view
@@ -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
+ src/Prelude.hs view
@@ -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
+ src/Text/JSON/Canonical.hs view
@@ -0,0 +1,198 @@+--------------------------------------------------------------------+-- |+-- Module    : Text.JSON.Parsec+-- Copyright : (c) Galois, Inc. 2007-2009, Duncan Coutts 2015+--+--+-- Minimal implementation of Canonical JSON.+--+-- <http://wiki.laptop.org/go/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 []