cabal-install-parsers 0.3.0.1 → 0.4

raw patch · 5 files changed

+286/−106 lines, 5 filesdep ~ansi-terminaldep ~base16-bytestringdep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ansi-terminal, base16-bytestring, bytestring, tar

API changes (from Hackage documentation)

Files

• Changelog.md +9/−0
• cabal-install-parsers.cabal +19/−15
• src/Cabal/Config.hs +1/−1
• src/Cabal/Index.hs +217/−84
• test/Index.hs +40/−6

@@ -1,3 +1,12 @@+## 0.4++- Rewrite `Cabal.Index` module+  - Added `riTarOffset` field to `ReleaseInfo`+  - Make `SHA256` be backed by four `Word64`.+    Hackage cache file size drops from 11673149 to 4423787 bytes.++- Update dependencies+ ## 0.3  - Require `Cabal-3.2`.

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               cabal-install-parsers-version:            0.3.0.1+version:            0.4 synopsis:           Utilities to work with cabal-install files description:   @cabal-install-parsers@ provides parsers for @cabal-install@ files:@@ -20,7 +20,9 @@ maintainer:         hvr@gnu.org, oleg.grenrus@iki.fi category:           Development build-type:         Simple-tested-with:        GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1+tested-with:+  GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1+ extra-source-files:   Changelog.md   fixtures/*.project@@ -60,18 +62,18 @@     , parsec        ^>=3.1.13.0     , pretty        ^>=1.1.3.3     , text          ^>=1.2.3.0-    , time          ^>=1.8.0.2  || ^>=1.9.3+    , time          ^>=1.8.0.2 || ^>=1.9.3     , transformers  ^>=0.5.2.0    -- extra dependencies   build-depends:-    , aeson                 ^>=1.4.6.0-    , base16-bytestring     ^>=0.1.1.6-    , binary-instances      ^>=1-    , cryptohash-sha256     ^>=0.11.101.0-    , lukko                 ^>=0.1.1-    , network-uri           ^>=2.6.1.0-    , tar                   ^>=0.5.1.1+    , aeson              ^>=1.4.6.0 || ^>=1.5.0.0+    , base16-bytestring  ^>=1.0.0.0+    , binary-instances   ^>=1+    , cryptohash-sha256  ^>=0.11.101.0+    , lukko              ^>=0.1.1+    , network-uri        ^>=2.6.1.0+    , tar                ^>=0.5.1.1    if !impl(ghc >=8.2)     build-depends: bifunctors ^>=5.5.4@@ -85,13 +87,16 @@   -- inherited constraints   build-depends:     , base+    , bytestring+    , base16-bytestring     , Cabal     , cabal-install-parsers     , containers+    , tar    -- dependencies needing explicit constraints   build-depends:-    , tasty        ^>=1.2.3+    , tasty        ^>=1.2.3 || ^>=1.3.1     , tasty-hunit  ^>=0.10.0.2  test-suite cabal-parsers-golden@@ -113,8 +118,8 @@    -- dependencies needing explicit constraints   build-depends:-    , ansi-terminal  ^>=0.10-    , tasty          ^>=1.2.3+    , ansi-terminal  >=0.10    && <0.12+    , tasty          ^>=1.2.3 || ^>=1.3.1     , tasty-golden   ^>=2.3.1.1     , tree-diff      ^>=0.1 @@ -135,5 +140,4 @@     , filepath    -- dependencies needing explicit constraints-  build-depends:-    , criterion ^>=1.5.6.1+  build-depends:    criterion ^>=1.5.6.1

@@ -53,7 +53,7 @@ -- Read config ------------------------------------------------------------------------------- --- | High level convinience function to find and read @~/.cabal/config@ file+-- | High level convinience function to find and read @~\/.cabal\/config@ file -- -- May throw 'IOException' when file doesn't exist, and 'ParseError' -- on parse error.

@@ -18,9 +18,8 @@     piPreferredVersions,     ReleaseInfo (..),     -- ** Hashes-    SHA256,+    SHA256 (..),     sha256,-    validSHA256,     mkSHA256,     unsafeMkSHA256,     getSHA256,@@ -40,23 +39,27 @@  import Prelude hiding (pi) -import Control.Exception-       (Exception, IOException, bracket, evaluate, handle, throwIO)-import Control.Monad     (unless, void)+import Control.Exception (Exception, IOException, bracket, evaluate, handle, throwIO)+import Data.Bits         (shiftL, (.|.), shiftR, (.&.)) import Data.ByteString   (ByteString) import Data.Int          (Int64) import Data.Map.Strict   (Map) import Data.Text         (Text)+import Data.Word         (Word32, Word64) import GHC.Generics      (Generic)  import qualified Codec.Archive.Tar                   as Tar import qualified Codec.Archive.Tar.Entry             as Tar+import qualified Codec.Archive.Tar.Index             as Tar import qualified Crypto.Hash.SHA256                  as SHA256 import qualified Data.Aeson                          as A import qualified Data.Binary                         as Binary+import qualified Data.Binary.Get                     as Binary.Get+import qualified Data.Binary.Put                     as Binary.Put import qualified Data.ByteString                     as BS import qualified Data.ByteString.Base16              as Base16 import qualified Data.ByteString.Lazy                as LBS+import qualified Data.ByteString.Unsafe              as BS.Unsafe import qualified Data.Map.Strict                     as Map import qualified Data.Text.Encoding                  as TE import qualified Data.Time.Clock.POSIX               as Time@@ -90,9 +93,11 @@     -> IO a foldIndex fp ini action = do     contents <- LBS.readFile fp-    foldEntries go throwIO ini (Tar.read contents)+    Acc _ result <- foldEntries go throwIO (Acc 0 ini) (Tar.read contents)+    return result   where-    go !acc entry = case Tar.entryContent entry of+    go (Acc offset acc) entry = case Tar.entryContent entry of+        -- file entry         Tar.NormalFile contents _ -> do             bs <- evaluate $ LBS.toStrict contents             idxFile <- either (throwIO . InvalidIndexFile) return (elaborateIndexFile fpath)@@ -102,13 +107,18 @@                     , entryOwnership   = Tar.entryOwnership entry                     , entryTime        = Tar.entryTime entry                     , entryType        = idxFile+                    , entryTarOffset   = offset                     }-            action entry' bs acc-        Tar.Directory -> return acc-        _             -> return acc+            next <- action entry' bs acc+            return (Acc (Tar.nextEntryOffset entry offset) next)++        -- all other entries+        _ -> return (Acc (Tar.nextEntryOffset entry offset) acc)      where        fpath = Tar.entryPath entry +data Acc a = Acc !Tar.TarEntryOffset !a+ foldEntries :: (a -> Tar.Entry -> IO a) -> (e -> IO a) -> a -> Tar.Entries e -> IO a foldEntries next fail' = go where     go !acc (Tar.Next e es) = next acc e >>= \acc' -> go acc' es@@ -120,11 +130,12 @@ -------------------------------------------------------------------------------  data IndexEntry = IndexEntry-    { entryPath        :: FilePath-    , entryType        :: IndexFileType-    , entryPermissions :: Tar.Permissions-    , entryOwnership   :: Tar.Ownership-    , entryTime        :: Tar.EpochTime+    { entryPath        :: !FilePath+    , entryType        :: !IndexFileType+    , entryPermissions :: !Tar.Permissions+    , entryOwnership   :: !Tar.Ownership+    , entryTime        :: !Tar.EpochTime+    , entryTarOffset   :: !Tar.TarEntryOffset     }   deriving Show @@ -161,56 +172,138 @@     xs -> Left $ show xs  ---------------------------------------------------------------------------------- Hashes+-- SHA256 ------------------------------------------------------------------------------- --- | SHA256 result.-newtype SHA256 = SHA256 ByteString+-- | SHA256 digest. 256 bytes.+data SHA256 = SHA256 !Word64 !Word64 !Word64 !Word64   deriving (Eq, Ord)  -- | Hash strict 'ByteString'. sha256 :: ByteString -> SHA256-sha256 = SHA256 . SHA256.hash+sha256 = sha256Digest . check . SHA256.hash+  where+    check bs+        | BS.length bs == 32 = bs+        | otherwise          = error $ "panic! SHA256.hash returned ByteStrign of length " ++ show (BS.length bs) ++ " /= 32" +-- unsafe construct. You should check the length of bytestring beforehand.+sha256Digest :: ByteString -> SHA256+sha256Digest bs = SHA256+    (   (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  0)) 56)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  1)) 48)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  2)) 40)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  3)) 32)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  4)) 24)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  5)) 16)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  6))  8)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  7))  0)+    )+    (   (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  8)) 56)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs  9)) 48)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 10)) 40)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 11)) 32)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 12)) 24)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 13)) 16)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 14))  8)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 15))  0)+    )+    (   (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 16)) 56)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 17)) 48)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 18)) 40)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 19)) 32)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 20)) 24)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 21)) 16)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 22))  8)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 23))  0)+    )+    (   (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 24)) 56)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 25)) 48)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 26)) 40)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 27)) 32)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 28)) 24)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 29)) 16)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 30))  8)+    .|. (shiftL (fromIntegral (BS.Unsafe.unsafeIndex bs 31))  0)+    )+ -- | Make SHA256 from base16-encoded string. mkSHA256 :: Text -> Either String SHA256 mkSHA256 t = case Base16.decode (TE.encodeUtf8 t) of-    (bs, rest) | not (BS.null rest)  -> Left $ "Base16 encoding leftovers" ++ show rest-               | BS.length bs /= 32  -> Left $ "Base16 of wrong length, expected 32, got " ++ show (BS.length bs)-               | otherwise           -> Right (SHA256 bs)+    Left err                      -> Left $ "Base16 decoding failure: " ++ err+    Right bs | BS.length bs /= 32 -> Left $ "Base16 of wrong length, expected 32, got " ++ show (BS.length bs)+             | otherwise          -> Right (sha256Digest bs)  -- | Unsafe variant of 'mkSHA256'. unsafeMkSHA256 :: Text -> SHA256 unsafeMkSHA256 = either error id . mkSHA256 -emptySHA256 :: SHA256-emptySHA256 = SHA256 BS.empty+-- | Get 'ByteString' representation of 'SHA256'.+getSHA256 :: SHA256 -> ByteString+getSHA256 (SHA256 a b c d) = BS.pack+    [ fromIntegral ((shiftR a 56) .&. 0xff)+    , fromIntegral ((shiftR a 48) .&. 0xff)+    , fromIntegral ((shiftR a 40) .&. 0xff)+    , fromIntegral ((shiftR a 32) .&. 0xff)+    , fromIntegral ((shiftR a 24) .&. 0xff)+    , fromIntegral ((shiftR a 16) .&. 0xff)+    , fromIntegral ((shiftR a  8) .&. 0xff)+    , fromIntegral ((shiftR a  0) .&. 0xff) --- | Check invariants of 'SHA256'-validSHA256 :: SHA256 -> Bool-validSHA256 (SHA256 bs) = BS.length bs == 32+    , fromIntegral ((shiftR b 56) .&. 0xff)+    , fromIntegral ((shiftR b 48) .&. 0xff)+    , fromIntegral ((shiftR b 40) .&. 0xff)+    , fromIntegral ((shiftR b 32) .&. 0xff)+    , fromIntegral ((shiftR b 24) .&. 0xff)+    , fromIntegral ((shiftR b 16) .&. 0xff)+    , fromIntegral ((shiftR b  8) .&. 0xff)+    , fromIntegral ((shiftR b  0) .&. 0xff) --- | Get underlying 'ByteString' of 'SHA256'.-getSHA256 :: SHA256 -> ByteString-getSHA256 (SHA256 bs) = bs+    , fromIntegral ((shiftR c 56) .&. 0xff)+    , fromIntegral ((shiftR c 48) .&. 0xff)+    , fromIntegral ((shiftR c 40) .&. 0xff)+    , fromIntegral ((shiftR c 32) .&. 0xff)+    , fromIntegral ((shiftR c 24) .&. 0xff)+    , fromIntegral ((shiftR c 16) .&. 0xff)+    , fromIntegral ((shiftR c  8) .&. 0xff)+    , fromIntegral ((shiftR c  0) .&. 0xff) +    , fromIntegral ((shiftR d 56) .&. 0xff)+    , fromIntegral ((shiftR d 48) .&. 0xff)+    , fromIntegral ((shiftR d 40) .&. 0xff)+    , fromIntegral ((shiftR d 32) .&. 0xff)+    , fromIntegral ((shiftR d 24) .&. 0xff)+    , fromIntegral ((shiftR d 16) .&. 0xff)+    , fromIntegral ((shiftR d  8) .&. 0xff)+    , fromIntegral ((shiftR d  0) .&. 0xff)+    ]+ instance C.Pretty SHA256 where     pretty = PP.text . C.fromUTF8BS . Base16.encode . getSHA256  instance Show SHA256 where-    showsPrec d (SHA256 bs)+    showsPrec d h         = showParen (d > 10)         $ showString "unsafeMkSHA256 "-        . shows (Base16.encode bs)+        . shows (Base16.encode (getSHA256 h))  instance Binary.Binary SHA256 where-    put (SHA256 bs) = Binary.put bs+    put (SHA256 a b c d) = do+        Binary.Put.putWord64be a+        Binary.Put.putWord64be b+        Binary.Put.putWord64be c+        Binary.Put.putWord64be d     get = do-        bs <- Binary.get-        case BS.length bs of-            32 -> return (SHA256 bs)-            l  -> fail $ "Invalid SHA256 length " ++ show l+        a <- Binary.Get.getWord64be+        b <- Binary.Get.getWord64be+        c <- Binary.Get.getWord64be+        d <- Binary.Get.getWord64be+        return (SHA256 a b c d) +-------------------------------------------------------------------------------+-- MD5+-------------------------------------------------------------------------------+ newtype MD5 = MD5 ByteString   deriving (Eq, Ord) @@ -223,9 +316,9 @@ -- | Make MD5 from base16-encoded string. mkMD5 :: Text -> Either String MD5 mkMD5 t = case Base16.decode (TE.encodeUtf8 t) of-    (bs, rest) | not (BS.null rest)  -> Left $ "Base16 encoding leftovers" ++ show rest-               | BS.length bs /= 16  -> Left $ "Base16 of wrong length, expected 16, got " ++ show (BS.length bs)-               | otherwise           -> Right (MD5 bs)+    Left err                      -> Left $ "Base16 decoding failure: " ++ err+    Right bs | BS.length bs /= 16 -> Left $ "Base16 of wrong length, expected 16, got " ++ show (BS.length bs)+             | otherwise          -> Right (MD5 bs)  {- -- | Unsafe variant of 'mkMD5'.@@ -261,9 +354,10 @@  -- | Package's release information. data ReleaseInfo = ReleaseInfo-    { riRevision :: Word    -- ^ revision number-    , riCabal    :: SHA256  -- ^ hash of the last revision of @.cabal@ file-    , riTarball  :: SHA256  -- ^ hash of the @.tar.gz@ file.+    { riRevision  :: !Word32              -- ^ revision number+    , riTarOffset :: !Tar.TarEntryOffset  -- ^ offset into tar file+    , riCabal     :: !SHA256              -- ^ hash of the last revision of @.cabal@ file+    , riTarball   :: !SHA256              -- ^ hash of the @.tar.gz@ file.     }   deriving (Eq, Show, Generic) @@ -282,46 +376,56 @@     -> Maybe Tar.EpochTime  -- ^ index state to stop     -> IO (Map C.PackageName PackageInfo) indexMetadata indexFilepath mindexState = do-    result <- foldIndex indexFilepath Map.empty $ \indexEntry contents m ->-        if maybe False (entryTime indexEntry >) mindexState+    let shouldStop :: Tar.EpochTime -> Bool+        shouldStop = case mindexState of+            Nothing         -> \_ -> False+            Just indexState -> \t -> t >= indexState++    result <- foldIndex indexFilepath Map.empty $ \indexEntry contents !m ->+        if shouldStop (entryTime indexEntry)         then return m         else case entryType indexEntry of-            CabalFile pn ver -> return $ Map.alter f pn m where-                f :: Maybe PackageInfo -> Maybe PackageInfo-                f Nothing = Just PackageInfo-                    { piVersions  = Map.singleton ver (ReleaseInfo 0 (sha256 contents) emptySHA256)-                    , piPreferred = C.anyVersion+            CabalFile pn ver -> return (Map.alter f pn m) where+                digest :: SHA256+                digest = sha256 contents++                offset :: Tar.TarEntryOffset+                offset = entryTarOffset indexEntry++                f :: Maybe TmpPackageInfo -> Maybe TmpPackageInfo+                f Nothing = Just TmpPackageInfo+                    { tmpPiVersions  = Map.singleton ver (TmpReleaseInfo 0 offset (Just digest) Nothing)+                    , tmpPiPreferred = C.anyVersion                     }-                f (Just pi) = Just pi { piVersions = Map.alter g ver (piVersions pi) }+                f (Just pi) = Just pi { tmpPiVersions = Map.alter g ver (tmpPiVersions pi) } -                g :: Maybe ReleaseInfo -> Maybe ReleaseInfo-                g Nothing                           = Just $ ReleaseInfo 0        (sha256 contents) emptySHA256-                g (Just (ReleaseInfo r c t))-                    | r == 0 && not (validSHA256 c) = Just $ ReleaseInfo 0        (sha256 contents) t-                    | otherwise                     = Just $ ReleaseInfo (succ r) (sha256 contents) t+                g :: Maybe TmpReleaseInfo -> Maybe TmpReleaseInfo+                g Nothing                                 = Just $ TmpReleaseInfo 0        offset (Just digest) Nothing+                g (Just (TmpReleaseInfo _r _o Nothing t)) = Just $ TmpReleaseInfo 0        offset (Just digest) t+                g (Just (TmpReleaseInfo  r _o _c      t)) = Just $ TmpReleaseInfo (succ r) offset (Just digest) t              PackageJson pn ver -> case A.eitherDecodeStrict contents of                     Left err -> throwIO $ MetadataParseError (entryPath indexEntry) err                     Right (PJ (Signed (Targets ts))) ->                         case Map.lookup ("<repo>/package/" ++ C.prettyShow pn ++ "-" ++ C.prettyShow ver ++ ".tar.gz") ts of-                            Just t  -> return $ Map.alter (f t) pn m+                            Just t  -> return (Map.alter (f t) pn m)                             Nothing -> throwIO $ MetadataParseError (entryPath indexEntry) $ "Invalid targets in " ++ entryPath indexEntry ++ " -- " ++ show ts                       where-                        f :: Target -> Maybe PackageInfo -> Maybe PackageInfo-                        f t Nothing   = Just PackageInfo-                            { piVersions  = Map.singleton ver (ReleaseInfo 0 emptySHA256 (hashSHA256 (targetHashes t)))-                            , piPreferred = C.anyVersion+                        f :: Target -> Maybe TmpPackageInfo -> Maybe TmpPackageInfo+                        f t Nothing   = Just TmpPackageInfo+                            { tmpPiVersions  = Map.singleton ver (TmpReleaseInfo 0 0 Nothing (Just (hashSHA256 (targetHashes t))))+                            , tmpPiPreferred = C.anyVersion                             }-                        f t (Just pi) = Just pi { piVersions = Map.alter (g t) ver (piVersions pi) }+                        f t (Just pi) = Just pi { tmpPiVersions = Map.alter (g t) ver (tmpPiVersions pi) } -                        g :: Target -> Maybe ReleaseInfo -> Maybe ReleaseInfo-                        g t Nothing                    = Just $ ReleaseInfo 0 emptySHA256 (hashSHA256 (targetHashes t))-                        g t (Just (ReleaseInfo r c _)) = Just $ ReleaseInfo r c (hashSHA256 (targetHashes t))+                        g :: Target -> Maybe TmpReleaseInfo -> Maybe TmpReleaseInfo+                        g t Nothing                         = Just $ TmpReleaseInfo 0 0 Nothing (Just (hashSHA256 (targetHashes t)))+                        g t (Just (TmpReleaseInfo r o c _)) = Just $ TmpReleaseInfo r o c       (Just (hashSHA256 (targetHashes t)))              PreferredVersions pn                     | BS.null contents -> return m                     | otherwise        -> case explicitEitherParsecBS preferredP contents of-                        Right vr -> return $ Map.alter (f vr) pn m+                        Right vr -> return (Map.alter (f vr) pn m)                         Left err -> throwIO $ MetadataParseError (entryPath indexEntry) err                   where                     preferredP = do@@ -329,25 +433,35 @@                         C.spaces                         C.parsec -                    f :: C.VersionRange -> Maybe PackageInfo -> Maybe PackageInfo-                    f vr Nothing = Just PackageInfo-                        { piVersions  = Map.empty-                        , piPreferred = vr+                    f :: C.VersionRange -> Maybe TmpPackageInfo -> Maybe TmpPackageInfo+                    f vr Nothing = Just TmpPackageInfo+                        { tmpPiVersions  = Map.empty+                        , tmpPiPreferred = vr                         }-                    f vr (Just pi) = Just pi { piPreferred = vr }-          +                    f vr (Just pi) = Just pi { tmpPiPreferred = vr }      -- check invariants and return     postCheck result-    return result -postCheck :: Map C.PackageName PackageInfo -> IO ()-postCheck meta = ifor_ meta $ \pn pi -> ifor_ (piVersions pi) $ \ver ri -> do-    unless (validSHA256 (riCabal ri))   $ throwIO $ InvalidHash pn ver "cabal"-    unless (validSHA256 (riTarball ri)) $ throwIO $ InvalidHash pn ver "tarball"+postCheck :: Map C.PackageName TmpPackageInfo -> IO (Map C.PackageName PackageInfo)+postCheck meta = ifor meta $ \pn pi -> do+    versions <- ifor (tmpPiVersions pi) $ \ver ri -> do+        cabal   <- maybe (throwIO $ InvalidHash pn ver "cabal")   return (tmpRiCabal   ri)+        tarball <- maybe (throwIO $ InvalidHash pn ver "tarball") return (tmpRiTarball ri)+        return ReleaseInfo+            { riRevision  = tmpRiRevision ri+            , riTarOffset = tmpRiTarOffset ri+            , riCabal     = cabal+            , riTarball   = tarball+            }++    return PackageInfo+        { piPreferred = tmpPiPreferred pi+        , piVersions  = versions+        }   where-    ifor_ :: Map k v -> (k -> v -> IO a) -> IO ()-    ifor_ xs f = Map.foldlWithKey' (\m k a -> m >> void (f k a)) (return ()) xs+    ifor :: Map k v -> (k -> v -> IO v') -> IO (Map k v')+    ifor = flip Map.traverseWithKey  -- | Thrown when we cannot parse @package.json@ or @preferred-versions@ files. data MetadataParseError = MetadataParseError FilePath String@@ -362,13 +476,32 @@ instance Exception InvalidHash  -------------------------------------------------------------------------------+-- Temporary types for indexMetadata+-------------------------------------------------------------------------------++data TmpPackageInfo = TmpPackageInfo+    { tmpPiVersions  :: Map C.Version TmpReleaseInfo  -- ^ individual package releases+    , tmpPiPreferred :: C.VersionRange                -- ^ preferred versions range+    }++data TmpReleaseInfo = TmpReleaseInfo+    { tmpRiRevision  :: !Word32              -- ^ revision number+    , tmpRiTarOffset :: !Tar.TarEntryOffset  -- ^ offset into tar file+    , tmpRiCabal     :: !(Maybe SHA256)      -- ^ hash of the last revision of @.cabal@ file+    , tmpRiTarball   :: !(Maybe SHA256)      -- ^ hash of the @.tar.gz@ file.+    }++------------------------------------------------------------------------------- -- Hackage -------------------------------------------------------------------------------  -- | Read the config and then Hackage index metadata. -- -- This method caches the result in @XDG_CACHE/cabal-parsers@ directory.-cachedHackageMetadata :: IO (Map C.PackageName PackageInfo)+--+-- Returns the location of index tarball and its contents.+--+cachedHackageMetadata :: IO (FilePath, Map C.PackageName PackageInfo) cachedHackageMetadata = do     -- read config     cfg <- readConfig@@ -389,7 +522,7 @@         mcache <- readCache cacheFile         case mcache of             Just cache | cacheSize cache == size && cacheTime cache == time ->-                return $ cacheData cache+                return (indexPath, cacheData cache)             _ -> do                 meta <- indexMetadata indexPath Nothing                 LBS.writeFile cacheFile $ Binary.encode Cache@@ -398,7 +531,7 @@                     , cacheSize  = size                     , cacheData  = meta                     }-                return meta+                return (indexPath, meta)    where     readCache :: FilePath -> IO (Maybe Cache)@@ -455,8 +588,8 @@         m <- Binary.get         if m == magicNumber then return Magic else fail "Got wrong magic number" -magicNumber :: Int64-magicNumber = 0xfedcba09+magicNumber :: Word64+magicNumber = 0xF000F000F0004000  ------------------------------------------------------------------------------- -- mini bool-singetons

@@ -1,20 +1,40 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Data.String      (IsString (..)) import Prelude          hiding (pi)-import Test.Tasty       (defaultMain, testGroup, testGroup)-import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCaseSteps)+import System.IO        (IOMode (ReadMode), withFile)+import Test.Tasty       (defaultMain, testGroup)+import Test.Tasty.HUnit (assertBool, assertEqual, assertFailure, testCase, testCaseSteps) -import qualified Data.Map.Strict      as Map-import qualified Distribution.Package as C-import qualified Distribution.Version as C+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Archive.Tar.Index as Tar+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Base16  as Base16+import qualified Data.ByteString.Lazy    as LBS+import qualified Data.Map.Strict         as Map+import qualified Distribution.Package    as C+import qualified Distribution.Version    as C  import Cabal.Config import Cabal.Index  main :: IO () main = defaultMain $ testGroup "Cabal.Index"-    [ testCaseSteps "low-level approach" $ \step -> do+    [ testGroup "SHA256"+        [ testCase "Base16.encode . getSHA256 . unsafeMkSHA256 rountrip" $ do+            let s :: IsString s => s+                s = "a6f5eddcff9526c786a1b77bdfade54b42f67c066b379bbc4b55ffb291e6c7d6"++            let expected :: BS.ByteString+                expected = s++            assertEqual "hash"+                expected+                (Base16.encode . getSHA256 . unsafeMkSHA256 $ s)+        ]++    , testCaseSteps "low-level approach" $ \step -> do         step "Read ~/.cabal/config"         cfg <- readConfig @@ -43,6 +63,20 @@                     assertEqual "tarball hash"                         (unsafeMkSHA256 "17c67cdaca651e18f310b21b2b12bac6bcec5188c3ac0e4b64cc60c94d7e4d2e")                         (riTarball ri)++                    -- check contents+                    withFile indexPath ReadMode $ \hdl -> do+                        entry <- Tar.hReadEntry hdl (riTarOffset ri)+                        case Tar.entryContent entry of+                            Tar.NormalFile bs fs -> do+                                assertEqual "entry content size"+                                    7251+                                    fs+                                assertEqual "entry content (prefix)"+                                    "name:            aeson\r\nversion:         1.4.4.0\r\nx-revision: 1\r\nlicense:       "+                                    (LBS.take 80 bs)++                            _ -> assertFailure "invalid entry content"          step "binary (deprecated versions)"         case Map.lookup (C.mkPackageName "binary") meta of