Merge pull request #3120 from alexeyzab/3006-speed-up-store-instances

Start implementing #3006

ChangeLog.md

@@ -73,6 +73,8 @@ Other enhancements:
   foo-1.2.3@gitsha1:deadbeef`. Note that this should be considered
   _experimental_, Stack will likely move towards a different hash
   format in the future.
+* `GitSHA1` is now `StaticSHA256` and is implemented using the `StaticSize 64 ByteString` for improved performance.
+  See [#3006](https://github.com/commercialhaskell/stack/issues/3006)
 
 Bug fixes:
 

src/Stack/Fetch.hs

@@ -314,7 +314,7 @@ data ToFetch = ToFetch
     , tfDestDir :: !(Maybe (Path Abs Dir))
     , tfUrl     :: !T.Text
     , tfSize    :: !(Maybe Word64)
-    , tfSHA256  :: !(Maybe ByteString)
+    , tfSHA256  :: !(Maybe StaticSHA256)
     , tfCabal   :: !ByteString
     -- ^ Contents of the .cabal file
     }
@@ -546,7 +546,7 @@ fetchPackages' mdistDir toFetchAll = do
         let toHashCheck bs = HashCheck SHA256 (CheckHexDigestByteString bs)
         let downloadReq = DownloadRequest
                 { drRequest = req
-                , drHashChecks = map toHashCheck $ maybeToList (tfSHA256 toFetch)
+                , drHashChecks = map (toHashCheck . staticSHA256ToBase16) $ maybeToList (tfSHA256 toFetch)
                 , drLengthCheck = fromIntegral <$> tfSize toFetch
                 , drRetryPolicy = drRetryPolicyDefault
                 }

src/Stack/PackageIndex.hs

@@ -365,7 +365,7 @@ getPackageCaches = do
             result <- liftM mconcat $ forM (configPackageIndices config) $ \index -> do
                 fp <- configPackageIndexCache (indexName index)
                 PackageCacheMap pis' gitPIs <-
-                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v3" "QAJ-RTivqCIR5uF09Km2FYW1Lnw="
+                    $(versionedDecodeOrLoad (storeVersionConfig "pkg-v4" "YZ4KNwqz-WdTZMaiU0UvfLWSSBw="
                                              :: VersionConfig PackageCacheMap))
                     fp
                     (populateCache index)

src/Stack/Snapshot.hs

@@ -215,10 +215,13 @@ loadResolver (ResolverSnapshot name) = do
             mcabalFileInfo' <- forM mcabalFileInfo $ \o' -> do
                 cfiSize <- Just <$> o' .: "size"
                 cfiHashes <- o' .: "hashes"
-                cfiHash <- maybe
-                                (fail "Could not find SHA256")
-                                (return . mkCabalHashFromSHA256)
-                            $ HashMap.lookup ("SHA256" :: Text) cfiHashes
+                cfiHash <-
+                  case HashMap.lookup ("SHA256" :: Text) cfiHashes of
+                    Nothing -> fail "Could not find SHA256"
+                    Just shaText ->
+                      case mkCabalHashFromSHA256 shaText of
+                        Nothing -> fail "Invalid SHA256"
+                        Just x -> return x
                 return CabalFileInfo {..}
 
             Object constraints <- o .: "constraints"

src/Stack/Types/BuildPlan.hs

@@ -255,7 +255,7 @@ instance Store LoadedSnapshot
 instance NFData LoadedSnapshot
 
 loadedSnapshotVC :: VersionConfig LoadedSnapshot
-loadedSnapshotVC = storeVersionConfig "ls-v1" "pH4Le2OpvbgouOui4sjXODTEkZA="
+loadedSnapshotVC = storeVersionConfig "ls-v2" "xsmhHqmPKKcyHNzCLkKRGZ_StxE="
 
 -- | Information on a single package for the 'LoadedSnapshot' which
 -- can be installed.

src/Stack/Types/PackageIdentifier.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -24,7 +25,12 @@ module Stack.Types.PackageIdentifier
   , packageIdentifierRevisionString
   , packageIdentifierText
   , toCabalPackageIdentifier
-  , fromCabalPackageIdentifier )
+  , fromCabalPackageIdentifier
+  , StaticSHA256
+  , mkStaticSHA256FromText
+  , staticSHA256ToText
+  , staticSHA256ToBase16
+  )
   where
 
 import           Control.Applicative
@@ -34,13 +40,16 @@ import           Crypto.Hash as Hash (hashlazy, Digest, SHA256)
 import           Data.Aeson.Extended
 import           Data.Attoparsec.Text as A
 import qualified Data.ByteArray.Encoding as Mem (convertToBase, Base(Base16))
+import           Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 import           Data.Data
 import           Data.Hashable
 import           Data.Store (Store)
+import           Data.Store.Internal (Size (..), StaticSize (..), size,
+                                      toStaticSize, toStaticSizeEx, unStaticSize)
 import           Data.Text (Text)
 import qualified Data.Text as T
-import           Data.Text.Encoding (decodeUtf8)
+import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import qualified Distribution.Package as C
 import           GHC.Generics
 import           Prelude hiding (FilePath)
@@ -109,25 +118,59 @@ instance FromJSON PackageIdentifierRevision where
       Right x -> return x
 
 -- | A cryptographic hash of a Cabal file.
---
--- Internal @Text@ value is in base-16 format, and represents a SHA256
--- hash.
-newtype CabalHash = CabalHash { unCabalHash :: Text }
-    deriving (Generic, Show, Eq, NFData, Store, Data, Typeable, Ord, Hashable)
+newtype CabalHash = CabalHash { unCabalHash :: StaticSHA256 }
+    deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Store, Hashable)
+
+-- | A SHA256 hash, stored in a static size for more efficient
+-- serialization with store.
+newtype StaticSHA256 = StaticSHA256 (StaticSize 64 ByteString)
+    deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord)
+
+instance Store StaticSHA256 where
+    size = ConstSize 64
+    -- poke (GitSHA1 x) = do
+    --   let (sourceFp, sourceOffset, sourceLength) = BSI.toForeignPtr (unStaticSize x)
+    --   pokeFromForeignPtr sourceFp sourceOffset sourceLength
+    -- peek = do
+    --     let len = 20
+    --     fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len
+    --     return (GitSHA1 $ StaticSize (BSI.PS fp 0 len))
+    -- {-# INLINE size #-}
+    -- {-# INLINE peek #-}
+    -- {-# INLINE poke #-}
+
+instance Hashable StaticSHA256 where
+  hashWithSalt s (StaticSHA256 x) = hashWithSalt s (unStaticSize x)
+
+-- | Generate a 'StaticSHA256' value from a base16-encoded SHA256 hash.
+mkStaticSHA256FromText :: Text -> Maybe StaticSHA256
+mkStaticSHA256FromText = fmap StaticSHA256 . toStaticSize . encodeUtf8
+
+-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash.
+staticSHA256ToText :: StaticSHA256 -> Text
+staticSHA256ToText = decodeUtf8 . staticSHA256ToBase16
+
+-- | Convert a 'StaticSHA256' into a base16-encoded SHA256 hash.
+staticSHA256ToBase16 :: StaticSHA256 -> ByteString
+staticSHA256ToBase16 (StaticSHA256 x) = unStaticSize x
 
 -- | Generate a 'CabalHash' value from a base16-encoded SHA256 hash.
-mkCabalHashFromSHA256 :: Text -> CabalHash
-mkCabalHashFromSHA256 = CabalHash
+mkCabalHashFromSHA256 :: Text -> Maybe CabalHash
+mkCabalHashFromSHA256 = fmap CabalHash . mkStaticSHA256FromText
+
+-- | Convert a 'CabalHash' into a base16-encoded SHA256 hash.
+cabalHashToText :: CabalHash -> Text
+cabalHashToText = staticSHA256ToText . unCabalHash
 
 -- | Compute a 'CabalHash' value from a cabal file's contents.
 computeCabalHash :: L.ByteString -> CabalHash
-computeCabalHash = CabalHash . decodeUtf8 . Mem.convertToBase Mem.Base16 . hashSHA256
+computeCabalHash = CabalHash . StaticSHA256 . toStaticSizeEx . Mem.convertToBase Mem.Base16 . hashSHA256
 
 hashSHA256 :: L.ByteString -> Hash.Digest Hash.SHA256
 hashSHA256 = Hash.hashlazy
 
 showCabalHash :: CabalHash -> Text
-showCabalHash (CabalHash t) = T.append (T.pack "sha256:") t
+showCabalHash = T.append (T.pack "sha256:") . cabalHashToText
 
 -- | Information on the contents of a cabal file
 data CabalFileInfo = CabalFileInfo
@@ -184,12 +227,14 @@ parsePackageIdentifierRevision x = go x
     cabalFileInfo = do
       _ <- string $ T.pack "@sha256:"
       hash' <- A.takeWhile (/= ',')
+      hash'' <- maybe (fail "Invalid SHA256") return
+              $ mkCabalHashFromSHA256 hash'
       msize <- optional $ do
         _ <- A.char ','
         A.decimal
       return CabalFileInfo
         { cfiSize = msize
-        , cfiHash = CabalHash hash'
+        , cfiHash = hash''
         }
 
 -- | Get a string representation of the package identifier; name-ver.
@@ -206,7 +251,7 @@ packageIdentifierRevisionString (PackageIdentifierRevision ident mcfi) =
         Nothing -> []
         Just cfi ->
             "@sha256:"
-          : T.unpack (unCabalHash $ cfiHash cfi)
+          : T.unpack (cabalHashToText (cfiHash cfi))
           : showSize (cfiSize cfi)
 
     showSize Nothing = []

src/Stack/Types/PackageIndex.hs

@@ -68,25 +68,30 @@ instance Store PackageCacheMap
 instance NFData PackageCacheMap
 
 data PackageDownload = PackageDownload
-    { pdSHA256 :: !ByteString
+    { pdSHA256 :: !StaticSHA256
     , pdUrl    :: !ByteString
     , pdSize   :: !Word64
     }
     deriving (Show, Generic, Eq, Data, Typeable)
+
 instance Store PackageDownload
 instance NFData PackageDownload
 instance FromJSON PackageDownload where
     parseJSON = withObject "PackageDownload" $ \o -> do
         hashes <- o .: "package-hashes"
-        sha256 <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes)
+        sha256' <- maybe mzero return (Map.lookup ("SHA256" :: Text) hashes)
+        sha256 <-
+          case mkStaticSHA256FromText sha256' of
+            Nothing -> fail "Invalid sha256"
+            Just x -> return x
         locs <- o .: "package-locations"
         url <-
             case reverse locs of
                 [] -> mzero
                 x:_ -> return x
         size <- o .: "package-size"
         return PackageDownload
-            { pdSHA256 = encodeUtf8 sha256
+            { pdSHA256 = sha256
             , pdUrl = encodeUtf8 url
             , pdSize = size
             }
@@ -101,9 +106,13 @@ instance FromJSON HSPackageDownload where
         Object o4:_ <- return $ F.toList o3
         len <- o4 .: "length"
         hashes <- o4 .: "hashes"
-        sha256 <- hashes .: "sha256"
+        sha256' <- hashes .: "sha256"
+        sha256 <-
+          case mkStaticSHA256FromText sha256' of
+            Nothing -> fail "Invalid sha256"
+            Just x -> return x
         return $ HSPackageDownload PackageDownload
-            { pdSHA256 = encodeUtf8 sha256
+            { pdSHA256 = sha256
             , pdSize = len
             , pdUrl = ""
             }

src/test/Stack/StoreSpec.hs

@@ -16,10 +16,12 @@ import           Data.Int
 import           Data.Map (Map)
 import           Data.Sequences (fromList)
 import           Data.Set (Set)
+import           Data.Store.Internal (StaticSize (..))
 import           Data.Store.TH
 import           Data.Text (Text)
 import qualified Data.Vector.Unboxed as UV
 import           Data.Word
+import           GHC.TypeLits (KnownNat)
 import           Language.Haskell.TH
 import           Language.Haskell.TH.ReifyMany
 import           Prelude
@@ -50,6 +52,8 @@ instance Monad m => Serial m BS.ByteString where
 instance (Monad m, Serial m a, Ord a) => Serial m (Set a) where
     series = fmap setFromList series
 
+instance (Monad m, KnownNat n) => Serial m (StaticSize n BS.ByteString)
+
 addMinAndMaxBounds :: forall a. (Bounded a, Eq a) => [a] -> [a]
 addMinAndMaxBounds xs =
     (if (minBound :: a) `notElem` xs then [minBound] else []) ++