diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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`. diff --git a/cabal-install-parsers.cabal b/cabal-install-parsers.cabal --- a/cabal-install-parsers.cabal +++ b/cabal-install-parsers.cabal @@ -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 diff --git a/src/Cabal/Config.hs b/src/Cabal/Config.hs --- a/src/Cabal/Config.hs +++ b/src/Cabal/Config.hs @@ -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. diff --git a/src/Cabal/Index.hs b/src/Cabal/Index.hs --- a/src/Cabal/Index.hs +++ b/src/Cabal/Index.hs @@ -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 ("/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 diff --git a/test/Index.hs b/test/Index.hs --- a/test/Index.hs +++ b/test/Index.hs @@ -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