hackage-security 0.5.1.0 → 0.5.2.0

raw patch · 20 files changed

+417/−92 lines, 20 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hackage-security.cabal +5/−5
• src/Hackage/Security/Client.hs +4/−3
• src/Hackage/Security/Client/Repository.hs +4/−3
• src/Hackage/Security/Client/Repository/Cache.hs +1/−1
• src/Hackage/Security/Client/Repository/Remote.hs +12/−10
• src/Hackage/Security/Key.hs +1/−1
• src/Hackage/Security/TUF/FileInfo.hs +5/−2
• src/Hackage/Security/TUF/FileMap.hs +3/−4
• src/Hackage/Security/TUF/Layout/Index.hs +11/−12
• src/Hackage/Security/TUF/Paths.hs +2/−2
• src/Hackage/Security/TUF/Patterns.hs +1/−1
• src/Hackage/Security/Util/Checked.hs +3/−0
• src/Hackage/Security/Util/JSON.hs +10/−6
• src/Hackage/Security/Util/Path.hs +63/−30
• tests/TestSuite.hs +65/−1
• tests/TestSuite/HttpMem.hs +70/−0
• tests/TestSuite/InMemCache.hs +39/−9
• tests/TestSuite/InMemRepo.hs +39/−0
• tests/TestSuite/InMemRepository.hs +2/−2
• tests/TestSuite/JSON.hs +77/−0

@@ -1,5 +1,5 @@ name:                hackage-security-version:             0.5.1.0+version:             0.5.2.0 synopsis:            Hackage security library description:         The hackage security library provides both server and                      client utilities for securing the Hackage package server@@ -18,13 +18,11 @@                      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+copyright:           Copyright 2015-2016 Well-Typed LLP category:            Distribution homepage:            https://github.com/well-typed/hackage-security bug-reports:         https://github.com/well-typed/hackage-security/issues@@ -214,9 +212,11 @@ test-suite TestSuite   type:                exitcode-stdio-1.0   main-is:             TestSuite.hs-  other-modules:       TestSuite.InMemCache+  other-modules:       TestSuite.HttpMem+                       TestSuite.InMemCache                        TestSuite.InMemRepo                        TestSuite.InMemRepository+                       TestSuite.JSON                        TestSuite.PrivateKeys                        TestSuite.Util.StrictMVar   build-depends:       base,

@@ -110,8 +110,7 @@     -- 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 :: VerificationHistory -> IO HasUpdates     limitIterations history | length history >= maxNumIterations =         throwChecked $ VerificationErrorLoop (reverse history)     limitIterations history = do@@ -802,7 +801,9 @@         }   where     indexPath :: Tar.Entry -> IndexPath-    indexPath = rootPath . fromUnrootedFilePath . Tar.entryPath+    indexPath = rootPath . fromUnrootedFilePath+              . Tar.fromTarPathToPosixPath+              . Tar.entryTarPath      indexFile :: IndexPath -> Maybe (Some IndexFile)     indexFile = indexFileFromPath repIndexLayout

@@ -403,17 +403,17 @@  -- | Is a particular remote file cached? data IsCached :: * -> * where-    -- | This remote file should be cached, and we ask for it by name+    -- This remote file should be cached, and we ask for it by name     CacheAs :: CachedFile -> IsCached Metadata -    -- | We don't cache this remote file+    -- 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 :: IsCached Binary -    -- | The index is somewhat special: it should be cached, but we never+    -- 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@@ -422,6 +422,7 @@     -- keep an index tarball index for quick access, others may scan the tarball     -- linearly, etc.     CacheIndex :: IsCached Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  deriving instance Eq   (IsCached typ) deriving instance Show (IsCached typ)

@@ -62,7 +62,7 @@     -- update the uncompressed index incrementally (assuming the local files     -- have not been corrupted).     -- NOTE: This assumes we already updated the compressed file.-    unzipIndex :: typ ~ Binary => IO ()+    unzipIndex :: IO ()     unzipIndex = do         createDirectoryIfMissing True (takeDirectory indexUn)         shouldTryIncremenal <- cachedIndexProbablyValid

@@ -299,24 +299,25 @@  -- | Download method (downloading or updating) data DownloadMethod :: * -> * -> * where-    -- | Download this file (we never attempt to update this type of file)+    -- Download this file (we never attempt to update this type of file)     NeverUpdated :: {         neverUpdatedFormat :: HasFormat fs f       } -> DownloadMethod fs typ -    -- | Download this file (we cannot update this file right now)+    -- Download this file (we cannot update this file right now)     CannotUpdate :: {         cannotUpdateFormat :: HasFormat fs f       , cannotUpdateReason :: UpdateFailure       } -> DownloadMethod fs Binary -    -- | Attempt an (incremental) update of this file+    -- Attempt an (incremental) update of this file     Update :: {         updateFormat :: HasFormat fs f       , updateInfo   :: Trusted FileInfo       , updateLocal  :: Path Absolute       , updateTail   :: Int54       } -> DownloadMethod fs Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  pickDownloadMethod :: forall fs typ. RemoteConfig                    -> AttemptNr@@ -362,8 +363,7 @@ getFile cfg@RemoteConfig{..} attemptNr remoteFile method =     go method   where-    go :: Throws SomeRemoteError-       => DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)+    go :: DownloadMethod fs typ -> Verify (Some (HasFormat fs), RemoteTemp typ)     go NeverUpdated{..} = do         cfgLogger $ LogDownloading remoteFile         download neverUpdatedFormat@@ -379,8 +379,7 @@     headers = httpRequestHeaders cfg attemptNr      -- Get any file from the server, without using incremental updates-    download :: Throws SomeRemoteError => HasFormat fs f-             -> Verify (Some (HasFormat fs), RemoteTemp typ)+    download :: HasFormat fs f -> Verify (Some (HasFormat fs), RemoteTemp typ)     download format = do         (tempPath, h) <- openTempFile (Cache.cacheRoot cfgCache) (uriTemplate uri)         liftIO $ do@@ -598,15 +597,16 @@         wholeTemp :: Path Absolute       } -> RemoteTemp a -    -- | If we download only the delta, we record both the path to where the+    -- If we download only the delta, we record both the path to where the     -- "old" file is stored and the path to the temp file containing the delta.     -- Then:     ---    -- * When we verify the file, we need both of these paths if we compute+    --   When we verify the file, we need both of these paths if we compute     --   the hash from scratch, or only the path to the delta if we attempt     --   to compute the hash incrementally (TODO: incremental verification     --   not currently implemented).-    -- * When we copy a file over, we are additionally given a destination+    --+    --   When we copy a file over, we are additionally given a destination     --   path. In this case, we expect that destination path to be equal to     --   the path to the old file (and assert this to be the case).     DownloadedDelta :: {@@ -614,6 +614,8 @@       , deltaExisting :: Path Absolute       , deltaSeek     :: Int54       -- ^ How much of the existing file to keep       } -> RemoteTemp Binary+--TODO: ^^ older haddock doesn't support GADT doc comments :-(+--      and add the '*' bullet points back in  instance Pretty (RemoteTemp typ) where     pretty DownloadedWhole{..} = intercalate " " $ [

@@ -153,7 +153,7 @@   toObjectKey = return . keyIdString  instance Monad m => FromObjectKey m KeyId where-  fromObjectKey = return . KeyId+  fromObjectKey = return . Just . KeyId  -- | Compute the key ID of a key class HasKeyId key where

@@ -29,6 +29,7 @@ -------------------------------------------------------------------------------}  data HashFn = HashFnSHA256+            | HashFnMD5   deriving (Show, Eq, Ord)  -- | File information@@ -87,10 +88,12 @@  instance Monad m => ToObjectKey m HashFn where   toObjectKey HashFnSHA256 = return "sha256"+  toObjectKey HashFnMD5    = return "md5"  instance ReportSchemaErrors m => FromObjectKey m HashFn where-  fromObjectKey "sha256" = return HashFnSHA256-  fromObjectKey str      = expected "valid hash function" (Just str)+  fromObjectKey "sha256" = return (Just HashFnSHA256)+  fromObjectKey "md5"    = return (Just HashFnMD5)+  fromObjectKey _        = return Nothing  instance Monad m => ToJSON m FileInfo where   toJSON FileInfo{..} = mkObject [

@@ -127,8 +127,7 @@  instance ReportSchemaErrors m => FromObjectKey m TargetPath where   fromObjectKey ('<':'r':'e':'p':'o':'>':'/':path) =-    return . TargetPathRepo  . rootPath . fromUnrootedFilePath $ path+    return . Just . TargetPathRepo  . rootPath . fromUnrootedFilePath $ path   fromObjectKey ('<':'i':'n':'d':'e':'x':'>':'/':path) =-    return . TargetPathIndex . rootPath . fromUnrootedFilePath $ path-  fromObjectKey str =-    expected "target path" (Just str)+    return . Just . TargetPathIndex . rootPath . fromUnrootedFilePath $ path+  fromObjectKey _str = return Nothing

@@ -9,8 +9,6 @@   , indexLayoutPkgPrefs   ) where -import qualified System.FilePath as FP- import Distribution.Package import Distribution.Text @@ -45,14 +43,15 @@ -- the global preferred-versions file. But supporting legacy Hackage will -- probably require more work anyway.. data IndexFile :: * -> * where-    -- | Package-specific metadata (@targets.json@)+    -- Package-specific metadata (@targets.json@)     IndexPkgMetadata :: PackageIdentifier -> IndexFile (Signed Targets) -    -- | Cabal file for a package+    -- Cabal file for a package     IndexPkgCabal :: PackageIdentifier -> IndexFile () -    -- | Preferred versions a package+    -- Preferred versions a package     IndexPkgPrefs :: PackageName -> IndexFile ()+--TODO: ^^ older haddock doesn't support GADT doc comments :-(  deriving instance Show (IndexFile dec) @@ -68,7 +67,7 @@ hackageIndexLayout :: IndexLayout hackageIndexLayout = IndexLayout {       indexFileToPath   = toPath-    , indexFileFromPath = fromPath . toUnrootedFilePath . unrootPath+    , indexFileFromPath = fromPath     }   where     toPath :: IndexFile dec -> IndexPath@@ -90,16 +89,16 @@     fromFragments :: [String] -> IndexPath     fromFragments = rootPath . joinFragments -    fromPath :: FilePath -> Maybe (Some IndexFile)-    fromPath fp = case FP.splitPath fp of-      [pkg, version, file] -> do-        pkgId <- simpleParse (init pkg ++ "-" ++ init version)-        case FP.takeExtension file of+    fromPath :: IndexPath -> Maybe (Some IndexFile)+    fromPath fp = case splitFragments (unrootPath fp) of+      [pkg, version, _file] -> do+        pkgId <- simpleParse (pkg ++ "-" ++ version)+        case takeExtension fp of           ".cabal"   -> return $ Some $ IndexPkgCabal    pkgId           ".json"    -> return $ Some $ IndexPkgMetadata pkgId           _otherwise -> Nothing       [pkg, "preferred-versions"] ->-        Some . IndexPkgPrefs <$> simpleParse (init pkg)+        Some . IndexPkgPrefs <$> simpleParse pkg       _otherwise -> Nothing  {-------------------------------------------------------------------------------

@@ -37,7 +37,7 @@ instance Pretty (Path RepoRoot) where   pretty (Path fp) = "<repo>/" ++ fp -anchorRepoPathLocally :: FsRoot root => Path root -> RepoPath -> Path root+anchorRepoPathLocally :: Path root -> RepoPath -> Path root anchorRepoPathLocally localRoot repoPath = localRoot </> unrootPath repoPath  anchorRepoPathRemotely :: Path Web -> RepoPath -> Path Web@@ -68,5 +68,5 @@     pretty (Path fp) = "<cache>/" ++ fp  -- | Anchor a cache path to the location of the cache-anchorCachePath :: FsRoot root => Path root -> CachePath -> Path root+anchorCachePath :: Path root -> CachePath -> Path root anchorCachePath cacheRoot cachePath = cacheRoot </> unrootPath cachePath

@@ -27,7 +27,7 @@  import Control.Monad.Except import Language.Haskell.TH (Q, Exp)-import System.FilePath+import System.FilePath.Posix import qualified Language.Haskell.TH.Syntax as TH  import Hackage.Security.JSON

@@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -wredundant-constraints #-}+#endif  #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE RoleAnnotations     #-}

@@ -24,6 +24,7 @@   ) where  import Control.Monad (liftM)+import Data.Maybe (catMaybes) import Data.Map (Map) import Data.Time import Text.JSON.Canonical@@ -54,7 +55,7 @@  -- | Used in the 'FromJSON' instance for 'Map' class FromObjectKey m a where-  fromObjectKey :: String -> m a+  fromObjectKey :: String -> m (Maybe a)  -- | Monads in which we can report schema errors class (Applicative m, Monad m) => ReportSchemaErrors m where@@ -85,13 +86,13 @@   toObjectKey = return  instance Monad m => FromObjectKey m String where-  fromObjectKey = return+  fromObjectKey = return . Just  instance Monad m => ToObjectKey m (Path root) where   toObjectKey (Path fp) = return fp  instance Monad m => FromObjectKey m (Path root) where-  fromObjectKey = liftM Path . fromObjectKey+  fromObjectKey = liftM (fmap Path) . fromObjectKey  {-------------------------------------------------------------------------------   ToJSON and FromJSON instances@@ -162,10 +163,13 @@          ) => FromJSON m (Map k a) where   fromJSON enc = do       obj <- fromJSObject enc-      Map.fromList <$> mapM aux obj+      Map.fromList . catMaybes <$> mapM aux obj     where-      aux :: (String, JSValue) -> m (k, a)-      aux (k, a) = (,) <$> fromObjectKey k <*> fromJSON a+      aux :: (String, JSValue) -> m (Maybe (k, a))+      aux (k, a) = knownKeys <$> fromObjectKey k <*> fromJSON a+      knownKeys :: Maybe k -> a -> Maybe (k, a)+      knownKeys Nothing  _ = Nothing+      knownKeys (Just k) a = Just (k, a)  instance Monad m => ToJSON m URI where   toJSON = toJSON . show

@@ -17,6 +17,7 @@   , takeFileName   , (<.>)   , splitExtension+  , takeExtension     -- * Unrooted paths   , Unrooted   , (</>)@@ -26,6 +27,7 @@   , fromUnrootedFilePath   , fragment   , joinFragments+  , splitFragments   , isPathPrefixOf     -- * File-system paths   , Relative@@ -92,7 +94,8 @@ #endif import qualified Data.ByteString         as BS import qualified Data.ByteString.Lazy    as BS.L-import qualified System.FilePath         as FP+import qualified System.FilePath         as FP.Native+import qualified System.FilePath.Posix   as FP.Posix import qualified System.IO               as IO import qualified System.Directory        as Dir import qualified Codec.Archive.Tar       as Tar@@ -115,9 +118,21 @@ -- make sense to append two absolute paths together; instead, we can only append -- an unrooted path to another path. It also means we avoid bugs where we use -- one kind of path where we expect another.-newtype Path a = Path { unPath :: FilePath }+newtype Path a = Path FilePath -- always a Posix style path internally   deriving (Show, Eq, Ord) +mkPathNative :: FilePath -> Path a+mkPathNative = Path . FP.Posix.joinPath . FP.Native.splitDirectories++unPathNative :: Path a -> FilePath+unPathNative (Path fp) = FP.Native.joinPath . FP.Posix.splitDirectories $ fp++mkPathPosix :: FilePath -> Path a+mkPathPosix = Path++unPathPosix :: Path a -> FilePath+unPathPosix (Path fp) = fp+ -- | Reinterpret the root of a path -- -- This literally just changes the type-level tag; use with caution!@@ -129,19 +144,22 @@ -------------------------------------------------------------------------------}  takeDirectory :: Path a -> Path a-takeDirectory = liftFP FP.takeDirectory+takeDirectory = liftFP FP.Posix.takeDirectory  takeFileName :: Path a -> String-takeFileName = liftFromFP FP.takeFileName+takeFileName = liftFromFP FP.Posix.takeFileName  (<.>) :: Path a -> String -> Path a-fp <.> ext = liftFP (FP.<.> ext) fp+fp <.> ext = liftFP (FP.Posix.<.> ext) fp  splitExtension :: Path a -> (Path a, String) splitExtension (Path fp) = (Path fp', ext)   where-    (fp', ext) = FP.splitExtension fp+    (fp', ext) = FP.Posix.splitExtension fp +takeExtension :: Path a -> String+takeExtension (Path fp) = FP.Posix.takeExtension fp+ {-------------------------------------------------------------------------------   Unrooted paths -------------------------------------------------------------------------------}@@ -155,7 +173,7 @@   pretty (Path fp) = fp  (</>) :: Path a -> Path Unrooted -> Path a-(</>) = liftFP2 (FP.</>)+(</>) = liftFP2 (FP.Posix.</>)  -- | Reinterpret an unrooted path --@@ -169,19 +187,30 @@ unrootPath :: Path root -> Path Unrooted unrootPath (Path fp) = Path fp +-- | Convert a relative\/unrooted Path to a FilePath (using POSIX style+-- directory separators).+--+-- See also 'toAbsoluteFilePath'+-- toUnrootedFilePath :: Path Unrooted -> FilePath-toUnrootedFilePath = unPath+toUnrootedFilePath = unPathPosix +-- | Convert from a relative\/unrooted FilePath (using POSIX style directory+-- separators).+-- fromUnrootedFilePath :: FilePath -> Path Unrooted-fromUnrootedFilePath = Path+fromUnrootedFilePath = mkPathPosix  -- | A path fragment (like a single directory or filename) fragment :: String -> Path Unrooted-fragment = fromUnrootedFilePath+fragment = Path  joinFragments :: [String] -> Path Unrooted-joinFragments = liftToFP FP.joinPath+joinFragments = liftToFP FP.Posix.joinPath +splitFragments :: Path Unrooted -> [String]+splitFragments (Path fp) = FP.Posix.splitDirectories fp+ isPathPrefixOf :: Path Unrooted -> Path Unrooted -> Bool isPathPrefixOf = liftFromFP2 isPrefixOf @@ -204,30 +233,34 @@  -- | A file system root can be interpreted as an (absolute) FilePath class FsRoot root where+  -- | Convert a Path to an absolute FilePath (using native style directory separators).+  --   toAbsoluteFilePath :: Path root -> IO FilePath  instance FsRoot Relative where-    toAbsoluteFilePath (Path fp) = go fp+    toAbsoluteFilePath p = go (unPathNative p)       where         go :: FilePath -> IO FilePath #if MIN_VERSION_directory(1,2,2)         go = Dir.makeAbsolute #else         -- copied implementation from the directory package-        go = (FP.normalise <$>) . absolutize+        go = (FP.Native.normalise <$>) . absolutize         absolutize path -- avoid the call to `getCurrentDirectory` if we can-          | FP.isRelative path = (FP.</> path) . FP.addTrailingPathSeparator <$>-                                 Dir.getCurrentDirectory-          | otherwise          = return path+          | FP.Native.isRelative path+                      = (FP.Native.</> path)+                      . FP.Native.addTrailingPathSeparator <$>+                        Dir.getCurrentDirectory+          | otherwise = return path #endif  instance FsRoot Absolute where-    toAbsoluteFilePath (Path fp) = return fp+    toAbsoluteFilePath = return . unPathNative  instance FsRoot HomeDir where-    toAbsoluteFilePath (Path fp) = do+    toAbsoluteFilePath p = do       home <- Dir.getHomeDirectory-      return $ home FP.</> fp+      return $ home FP.Native.</> unPathNative p  -- | Abstract over a file system root --@@ -239,29 +272,29 @@ -------------------------------------------------------------------------------}  toFilePath :: Path Absolute -> FilePath-toFilePath (Path fp) = fp+toFilePath = unPathNative  fromFilePath :: FilePath -> FsPath fromFilePath fp-    | FP.isAbsolute      fp = FsPath (Path fp  :: Path Absolute)-    | Just fp' <- atHome fp = FsPath (Path fp' :: Path HomeDir)-    | otherwise             = FsPath (Path fp  :: Path Relative)+    | FP.Native.isAbsolute fp = FsPath (mkPathNative fp  :: Path Absolute)+    | Just fp' <- atHome fp   = FsPath (mkPathNative fp' :: Path HomeDir)+    | otherwise               = FsPath (mkPathNative fp  :: Path Relative)   where     -- TODO: I don't know if there a standard way that Windows users refer to     -- their home directory. For now, we'll only interpret '~'. Everybody else     -- can specify an absolute path if this doesn't work.     atHome :: FilePath -> Maybe FilePath     atHome "~" = Just ""-    atHome ('~':sep:fp') | FP.isPathSeparator sep = Just fp'+    atHome ('~':sep:fp') | FP.Native.isPathSeparator sep = Just fp'     atHome _otherwise = Nothing  makeAbsolute :: FsPath -> IO (Path Absolute)-makeAbsolute (FsPath p) = Path <$> toAbsoluteFilePath p+makeAbsolute (FsPath p) = mkPathNative <$> toAbsoluteFilePath p  fromAbsoluteFilePath :: FilePath -> Path Absolute fromAbsoluteFilePath fp-  | FP.isAbsolute fp = Path fp-  | otherwise        = error "fromAbsoluteFilePath: not an absolute path"+  | FP.Native.isAbsolute fp = mkPathNative fp+  | otherwise               = error "fromAbsoluteFilePath: not an absolute path"  {-------------------------------------------------------------------------------   Wrappers around System.IO@@ -363,7 +396,7 @@     fragments <$> Dir.getDirectoryContents filePath   where     fragments :: [String] -> [Path Unrooted]-    fragments = map fromUnrootedFilePath . filter (not . skip)+    fragments = map fragment . filter (not . skip)      skip :: String -> Bool     skip "."  = True@@ -389,7 +422,7 @@                        else return [path]      emptyPath :: Path Unrooted-    emptyPath = Path (FP.joinPath [])+    emptyPath = joinFragments []  renameFile :: (FsRoot root, FsRoot root')            => Path root  -- ^ Old@@ -431,7 +464,7 @@     Tar.append tarFile' baseDir' contents'   where     contents' :: [FilePath]-    contents' = map (toUnrootedFilePath . unrootPath) contents+    contents' = map (unPathNative . unrootPath) contents  {-------------------------------------------------------------------------------   Wrappers around Network.URI

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards, GADTs #-} module Main (main) where  -- stdlib@@ -8,15 +9,21 @@ import Network.URI (URI, parseURI) import Test.Tasty import Test.Tasty.HUnit-import Test.Tasty.QuickCheck+import Test.Tasty.QuickCheck hiding (label) import System.IO.Temp (withSystemTempDirectory)+import qualified Codec.Archive.Tar.Entry    as Tar+import qualified Data.ByteString.Lazy.Char8 as BS +-- Cabal+import Distribution.Package (PackageName(..))+ -- hackage-security import Hackage.Security.Client import Hackage.Security.Client.Repository import Hackage.Security.JSON (DeserializationError(..)) import Hackage.Security.Util.Checked import Hackage.Security.Util.Path+import Hackage.Security.Util.Some import Hackage.Security.Util.Pretty import qualified Hackage.Security.Client.Repository.Remote as Remote import qualified Hackage.Security.Client.Repository.Cache  as Cache@@ -45,6 +52,7 @@         , testCase "testInMemUpdatesAfterCron"     testInMemUpdatesAfterCron         , testCase "testInMemKeyRollover"          testInMemKeyRollover         , testCase "testInMemOutdatedTimestamp"    testInMemOutdatedTimestamp+        , testCase "testInMemIndex"                testInMemIndex         ]     , testGroup "HttpMem" [           testCase "testHttpMemInitialHasForUpdates" testHttpMemInitialHasUpdates@@ -52,6 +60,7 @@         , testCase "testHttpMemUpdatesAfterCron"     testHttpMemUpdatesAfterCron         , testCase "testHttpMemKeyRollover"          testHttpMemKeyRollover         , testCase "testHttpMemOutdatedTimestamp"    testHttpMemOutdatedTimestamp+        , testCase "testHttpMemIndex"                testHttpMemIndex         ]     , testGroup "Canonical JSON" [           testProperty "prop_roundtrip_canonical" JSON.prop_roundtrip_canonical@@ -131,6 +140,10 @@       withAssertLog "C" logMsgs [] $ do         assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater +testInMemIndex :: Assertion+testInMemIndex = inMemTest $ \inMemRepo _logMsgs repo ->+    testRepoIndex inMemRepo repo+ {-------------------------------------------------------------------------------   Same tests, but going through the "real" Remote repository and Cache, though   still using an in-memory repository (with a HttpLib bridge)@@ -201,6 +214,57 @@     catchVerificationLoop msgs $ do       withAssertLog "C" logMsgs [] $ do         assertEqual "C.1" HasUpdates =<< checkForUpdates repo fourDaysLater++testHttpMemIndex :: Assertion+testHttpMemIndex = httpMemTest $ \inMemRepo _logMsgs repo ->+    testRepoIndex inMemRepo repo++{-------------------------------------------------------------------------------+  Identical tests between the two variants+-------------------------------------------------------------------------------}++testRepoIndex :: (Throws SomeRemoteError, Throws VerificationError)+              => InMemRepo -> Repository down -> IO ()+testRepoIndex inMemRepo repo = do+    assertEqual "A" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    dir1 <- getDirectory repo+    directoryFirst dir1  @?= DirectoryEntry 0+    directoryNext  dir1  @?= DirectoryEntry 0+    length (directoryEntries dir1) @?= 0++    now <- getCurrentTime+    inMemRepoSetIndex inMemRepo now [testEntry1]++    assertEqual "B" HasUpdates =<< checkForUpdates repo =<< checkExpiry+    dir2 <- getDirectory repo+    directoryFirst dir2  @?= DirectoryEntry 0+    directoryNext  dir2  @?= DirectoryEntry 2+    length (directoryEntries dir2) @?= 1+    directoryLookup dir2 testEntryIndexFile @?= Just (DirectoryEntry 0)+    withIndex repo $ \IndexCallbacks{..} -> do+      (sentry, next) <- indexLookupEntry (DirectoryEntry 0)+      next @?= Nothing+      case sentry of Some entry -> checkIndexEntry entry+  where+    checkIndexEntry :: IndexEntry dec -> Assertion+    checkIndexEntry entry = do+       toUnrootedFilePath (unrootPath (indexEntryPath entry))+         @?= "foo/preferred-versions"+       indexEntryContent entry @?= testEntrycontent+       case indexEntryPathParsed entry of+         Just (IndexPkgPrefs pkgname) -> do+           pkgname @?= PackageName "foo"+           case indexEntryContentParsed entry of+             Right () -> return ()+             _        -> fail "unexpected index entry content"+         _ -> fail "unexpected index path"++    testEntry1 = Tar.fileEntry path testEntrycontent+      where+        Right path = Tar.toTarPath False "foo/preferred-versions"+    testEntrycontent   = BS.pack "foo >= 1"+    testEntryIndexFile = IndexPkgPrefs (PackageName "foo")+  {-------------------------------------------------------------------------------   Log messages we expect when using the Remote repository

@@ -0,0 +1,70 @@+-- | HttpLib bridge to the in-memory repository+module TestSuite.HttpMem (+    httpMem+  ) where++-- stdlib+import Network.URI (URI)+import qualified Data.ByteString.Lazy as BS.L++-- hackage-security+import Hackage.Security.Client+import Hackage.Security.Client.Repository.HttpLib+import Hackage.Security.Util.Checked+import Hackage.Security.Util.Path+import Hackage.Security.Util.Some++-- TestSuite+import TestSuite.InMemRepo++httpMem :: InMemRepo -> HttpLib+httpMem inMemRepo = HttpLib {+      httpGet      = get      inMemRepo+    , httpGetRange = getRange inMemRepo+    }++{-------------------------------------------------------------------------------+  Individual methods+-------------------------------------------------------------------------------}++-- | Download a file+--+-- Since we don't (yet?) make any attempt to simulate a cache, we ignore+-- caching headers.+get :: forall a. Throws SomeRemoteError+    => InMemRepo+    -> [HttpRequestHeader]+    -> URI+    -> ([HttpResponseHeader] -> BodyReader -> IO a)+    -> IO a+get InMemRepo{..} _requestHeaders uri callback = do+    Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)+    br <- bodyReaderFromBS $ inMemFileRender inMemFile+    callback [HttpResponseAcceptRangesBytes] br++-- | Download a byte range+--+-- Range is starting and (exclusive) end offset in bytes.+--+-- We ignore requests for compression; different servers deal with compression+-- for byte range requests differently; in particular, Apache returns the range+-- of the _compressed_ file, which is pretty useless for our purposes. For now+-- we ignore this issue completely here.+getRange :: forall a. Throws SomeRemoteError+         => InMemRepo+         -> [HttpRequestHeader]+         -> URI+         -> (Int, Int)+         -> (HttpStatus -> [HttpResponseHeader] -> BodyReader -> IO a)+         -> IO a+getRange InMemRepo{..} _requestHeaders uri (fr, to) callback = do+    Some inMemFile <- inMemRepoGetPath $ castRoot (uriPath uri)+    br <- bodyReaderFromBS $ substr (inMemFileRender inMemFile)++    let responseHeaders = concat [+            [ HttpResponseAcceptRangesBytes ]+          ]+    callback HttpStatus206PartialContent responseHeaders br+  where+    substr :: BS.L.ByteString -> BS.L.ByteString+    substr = BS.L.take (fromIntegral (to - fr)) . BS.L.drop (fromIntegral fr)

@@ -8,8 +8,13 @@ import qualified Codec.Compression.GZip as GZip import qualified Data.ByteString.Lazy   as BS.L +-- tar+import qualified Codec.Archive.Tar       as Tar+import qualified Codec.Archive.Tar.Index as TarIndex+import           Codec.Archive.Tar.Index   (TarIndex)+ -- hackage-security-import Hackage.Security.Client+import Hackage.Security.Client hiding (withIndex) import Hackage.Security.Client.Formats import Hackage.Security.Client.Repository import Hackage.Security.JSON@@ -20,20 +25,25 @@ import TestSuite.InMemRepo  data InMemCache = InMemCache {-      inMemCacheGet     :: CachedFile -> IO (Maybe (Path Absolute))-    , inMemCacheGetRoot :: IO (Path Absolute)-    , inMemCacheClear   :: IO ()-    , inMemCachePut     :: forall f typ. InMemFile typ -> Format f -> IsCached typ -> IO ()+      inMemCacheGet         :: CachedFile -> IO (Maybe (Path Absolute))+    , inMemCacheGetRoot     :: IO (Path Absolute)+    , inMemCacheWithIndex   :: forall a. (Handle -> IO a) -> IO a+    , inMemCacheGetIndexIdx :: IO TarIndex+    , inMemCacheClear       :: IO ()+    , inMemCachePut         :: forall f typ. InMemFile typ -> Format f+                                          -> IsCached  typ -> IO ()     }  newInMemCache :: Path Absolute -> RepoLayout -> IO InMemCache newInMemCache tempDir layout = do     state <- newMVar $ initLocalState layout     return InMemCache {-        inMemCacheGet     = get     state tempDir-      , inMemCacheGetRoot = getRoot state tempDir-      , inMemCacheClear   = clear   state-      , inMemCachePut     = put     state+        inMemCacheGet         = get         state tempDir+      , inMemCacheGetRoot     = getRoot     state tempDir+      , inMemCacheWithIndex   = withIndex   state tempDir+      , inMemCacheGetIndexIdx = getIndexIdx state+      , inMemCacheClear       = clear       state+      , inMemCachePut         = put         state       }  {-------------------------------------------------------------------------------@@ -105,6 +115,26 @@ getRoot :: MVar LocalState -> Path Absolute -> IO (Path Absolute) getRoot state cacheTempDir =     needRoot `fmap` get state cacheTempDir CachedRoot++withIndex :: MVar LocalState -> Path Absolute -> (Handle -> IO a) -> IO a+withIndex state cacheTempDir action = do+    st <- readMVar state+    case cachedIndex st of+      Nothing -> error "InMemCache.withIndex: Could not read index."+      Just bs -> do+        (_, h) <- openTempFile' cacheTempDir "01-index.tar"+        BS.L.hPut h bs+        hSeek  h AbsoluteSeek 0+        x <- action h+        hClose h+        return x++getIndexIdx :: MVar LocalState -> IO TarIndex+getIndexIdx state = do+    st <- readMVar state+    case cachedIndex st of+      Nothing    -> error "InMemCache.getIndexIdx: Could not read index."+      Just index -> either throwIO return . TarIndex.build . Tar.read $ index  -- | Clear all cached data clear :: MVar LocalState -> IO ()

@@ -72,6 +72,9 @@      -- | Rollover the timestamp and snapshot keys   , inMemRepoKeyRollover :: UTCTime -> IO ()++    -- | Set the content of the repo tar index and resign+  , inMemRepoSetIndex :: UTCTime -> [Tar.Entry] -> IO ()   }  newInMemRepo :: RepoLayout@@ -86,6 +89,7 @@       , inMemRepoGetPath     = getPath     state       , inMemRepoCron        = cron        state       , inMemRepoKeyRollover = keyRollover state+      , inMemRepoSetIndex    = setIndex    state       }  {-------------------------------------------------------------------------------@@ -213,6 +217,41 @@     return st {         remoteTimestamp = signedTimestamp       , remoteSnapshot  = signedSnapshot+      }++setIndex :: MVar RemoteState -> UTCTime -> [Tar.Entry] -> IO ()+setIndex state now entries = modifyMVar_ state $ \st@RemoteState{..} -> do+    let snapshot, snapshot' :: Snapshot+        snapshot  = signed remoteSnapshot+        snapshot' = snapshot {+            snapshotVersion   = versionIncrement $ snapshotVersion snapshot+          , snapshotExpires   = expiresInDays now 3+          , snapshotInfoTarGz = fileInfo $ newTarGz+          , snapshotInfoTar   = Just $ fileInfo newTar+          }++        newTar :: BS.L.ByteString+        newTar = Tar.write entries++        newTarGz :: BS.L.ByteString+        newTarGz = GZip.compress newTar++        timestamp, timestamp' :: Timestamp+        timestamp  = signed remoteTimestamp+        timestamp' = Timestamp {+            timestampVersion      = versionIncrement $ timestampVersion timestamp+          , timestampExpires      = expiresInDays now 3+          , timestampInfoSnapshot = fileInfo $ renderJSON remoteLayout signedSnapshot+          }++        signedTimestamp = withSignatures remoteLayout [privateTimestamp remoteKeys] timestamp'+        signedSnapshot  = withSignatures remoteLayout [privateSnapshot  remoteKeys] snapshot'++    return st {+        remoteTimestamp = signedTimestamp+      , remoteSnapshot  = signedSnapshot+      , remoteTar       = newTar+      , remoteTarGz     = newTarGz       }  keyRollover :: MVar RemoteState -> UTCTime -> IO ()

@@ -31,8 +31,8 @@       , repGetCachedRoot = inMemCacheGetRoot  cache       , repClearCache    = inMemCacheClear    cache       , repLockCache     = withMVar cacheLock . const-      , repWithIndex     = error "newInMemRepository: repWithIndex TODO"-      , repGetIndexIdx   = error "newInMemRepository: repGetIndexIdx TODO"+      , repWithIndex     = inMemCacheWithIndex   cache+      , repGetIndexIdx   = inMemCacheGetIndexIdx cache       , repWithMirror    = withMirror       , repLog           = logger       , repLayout        = layout

@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TestSuite.JSON (+    prop_roundtrip_canonical,+    prop_roundtrip_pretty,+    prop_canonical_pretty,+  ) where++-- stdlib+import Data.Int+import Data.List (sortBy, nubBy)+import Data.Function (on)+import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as BS+import Test.QuickCheck++-- hackage-security+import Text.JSON.Canonical+++prop_roundtrip_canonical, prop_roundtrip_pretty, prop_canonical_pretty+  :: JSValue -> Bool++prop_roundtrip_canonical jsval =+    parseCanonicalJSON (renderCanonicalJSON jsval) == Right (canonicalise jsval)++prop_roundtrip_pretty jsval =+    parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)) == Right jsval++prop_canonical_pretty jsval =+    parseCanonicalJSON (renderCanonicalJSON jsval) ==+    fmap canonicalise (parseCanonicalJSON (BS.pack (prettyCanonicalJSON jsval)))++canonicalise :: JSValue -> JSValue+canonicalise v@JSNull        = v+canonicalise v@(JSBool    _) = v+canonicalise v@(JSNum     _) = v+canonicalise v@(JSString  _) = v+canonicalise   (JSArray  vs) = JSArray  [ canonicalise v | v <- vs]+canonicalise   (JSObject vs) = JSObject [ (k, canonicalise v)+                                        | (k,v) <- sortBy (compare `on` fst) vs ]++instance Arbitrary JSValue where+  arbitrary =+    sized $ \sz ->+    frequency+      [ (1, pure JSNull)+      , (1, JSBool   <$> arbitrary)+      , (2, JSNum    <$> arbitrary)+      , (2, JSString <$> arbitrary)+      , (3, JSArray                <$> resize (sz `div` 2) arbitrary)+      , (3, JSObject . noDupFields <$> resize (sz `div` 2) arbitrary)+      ]+    where+      noDupFields = nubBy (\(x,_) (y,_) -> x==y)++  shrink JSNull        = []+  shrink (JSBool    _) = []+  shrink (JSNum     n) = [ JSNum    n' | n' <- shrink n ]+  shrink (JSString  s) = [ JSString s' | s' <- shrink s ]+  shrink (JSArray  vs) = [ JSArray vs' | vs' <- shrink vs ]+  shrink (JSObject vs) = [ JSObject vs' | vs' <- shrinkList shrinkSnd vs ]+    where+      shrinkSnd (a,b) = [ (a,b') | b' <- shrink b ]+++instance Arbitrary Int54 where+  arbitrary = fromIntegral <$>+              frequency [ (1, pure lowerbound)+                        , (1, pure upperbound)+                        , (8, choose (lowerbound, upperbound))+                        ]+    where+      upperbound, lowerbound :: Int64+      upperbound =   999999999999999  -- 15 decimal digits+      lowerbound = (-999999999999999)+  shrink = shrinkIntegral+