Improve digests generation and parsing

hnix-store-core/src/System/Nix/Hash.hs

@@ -10,6 +10,7 @@ module System.Nix.Hash (
   , HNix.SomeNamedDigest(..)
   , HNix.hash
   , HNix.hashLazy
+  , HNix.mkNamedDigest
 
   , HNix.encodeBase32
   , HNix.decodeBase32

hnix-store-core/src/System/Nix/Internal/Hash.hs

@@ -44,7 +44,10 @@ data HashAlgorithm
 
 -- | The result of running a 'HashAlgorithm'.
 newtype Digest (a :: HashAlgorithm) =
-  Digest BS.ByteString deriving (Show, Eq, Ord, DataHashable.Hashable)
+  Digest BS.ByteString deriving (Eq, Ord, DataHashable.Hashable)
+
+instance Show (Digest a) where
+  show = ("Digest " ++) . show . encodeBase32
 
 -- | The primitive interface for incremental hashing for a given
 -- 'HashAlgorithm'. Every 'HashAlgorithm' should have an instance.
@@ -61,21 +64,55 @@ class ValidAlgo (a :: HashAlgorithm) where
 
 -- | A 'HashAlgorithm' with a canonical name, for serialization
 -- purposes (e.g. SRI hashes)
-class NamedAlgo (a :: HashAlgorithm) where
+class ValidAlgo a => NamedAlgo (a :: HashAlgorithm) where
   algoName :: Text
+  hashSize :: Int
 
 instance NamedAlgo 'MD5 where
   algoName = "md5"
+  hashSize = 16
 
 instance NamedAlgo 'SHA1 where
   algoName = "sha1"
+  hashSize = 20
 
 instance NamedAlgo 'SHA256 where
   algoName = "sha256"
+  hashSize = 32
+
+{-
+instance NamedAlgo 'SHA512 where
+  algoName = "sha512"
+  hashSize = 64
+-}
 
 -- | A digest whose 'NamedAlgo' is not known at compile time.
 data SomeNamedDigest = forall a . NamedAlgo a => SomeDigest (Digest a)
 
+instance Show SomeNamedDigest where
+  show sd = case sd of
+    SomeDigest (digest :: Digest hashType) -> T.unpack $ "SomeDigest " <> algoName @hashType <> ":" <> encodeBase32 digest
+
+mkNamedDigest :: Text -> Text -> Either String SomeNamedDigest
+mkNamedDigest name hash = case name of
+  "md5"    -> SomeDigest <$> decode @'MD5
+  "sha1"   -> SomeDigest <$> decode @'SHA1
+  "sha256" -> SomeDigest <$> decode @'SHA256
+  _        -> Left $ "Unknown hash name: " ++ T.unpack name
+ where
+  size = T.length hash
+  decode :: forall a . (NamedAlgo a, ValidAlgo a) => Either String (Digest a)
+  decode
+    | size == base16Len = decodeBase16 hash
+    | size == base32Len = decodeBase32 hash
+    -- | size == base64Len = decodeBase64 s -- TODO
+    | otherwise = Left $ T.unpack hash ++ " is not a valid " ++ T.unpack name ++ " hash."
+   where
+    hsize = hashSize @a
+    base16Len = hsize * 2
+    base32Len = ((hsize * 8 - 1) `div` 5) + 1;
+    -- base64Len = ((4 * hsize / 3) + 3) & ~3;
+
 -- | Hash an entire (strict) 'BS.ByteString' as a single call.
 --
 --   For example:

hnix-store-core/src/System/Nix/ReadonlyStore.hs

@@ -12,7 +12,12 @@ import           Data.Text.Encoding
 import           System.Nix.Hash
 import           System.Nix.StorePath
 
-makeStorePath :: forall hashAlgo . (NamedAlgo hashAlgo) => FilePath -> ByteString -> Digest hashAlgo -> StorePathName -> StorePath
+makeStorePath :: forall hashAlgo . (NamedAlgo hashAlgo)
+  => FilePath
+  -> ByteString
+  -> Digest hashAlgo
+  -> StorePathName
+  -> StorePath
 makeStorePath fp ty h nm = StorePath storeHash nm fp
   where
     s = BS.intercalate ":"
@@ -29,14 +34,18 @@ makeTextPath fp nm h refs = makeStorePath fp ty h nm
   where
     ty = BS.intercalate ":" ("text" : map storePathToRawFilePath (HS.toList refs))
 
-makeFixedOutputPath :: forall hashAlgo. (ValidAlgo hashAlgo, NamedAlgo hashAlgo) => FilePath -> Bool -> Digest hashAlgo -> StorePathName -> StorePath
+makeFixedOutputPath :: forall hashAlgo . (ValidAlgo hashAlgo, NamedAlgo hashAlgo)
+  => FilePath
+  -> Bool
+  -> Digest hashAlgo
+  -> StorePathName
+  -> StorePath
 makeFixedOutputPath fp recursive h nm =
-  makeStorePath fp ty h' nm
-  where
-    (ty, h') =
-      if recursive && algoName @hashAlgo == algoName @'SHA256
-      then ("source", h)
-      else ("output:out", hash ("fixed:out:" <> encodeUtf8 (encodeBase16 h) <> ":"))
+  if recursive && (algoName @hashAlgo) == "sha256"
+  then makeStorePath fp "source"     h  nm
+  else makeStorePath fp "output:out" h' nm
+ where
+  h' = hash @'SHA256 $ "fixed:out:" <> encodeUtf8 (algoName @hashAlgo) <> (if recursive then ":r:" else ":") <> encodeUtf8 (encodeBase16 h) <> ":"
 
 computeStorePathForText :: FilePath -> StorePathName -> ByteString -> StorePathSet -> StorePath
 computeStorePathForText fp nm s refs = makeTextPath fp nm (hash s) refs

hnix-store-remote/src/System/Nix/Store/Remote.hs

@@ -264,8 +264,7 @@ querySubstitutablePaths ps = do
     putPaths ps
   sockGetPaths
 
-queryPathInfoUncached :: forall a . NamedAlgo a
-                      => StorePath
+queryPathInfoUncached :: StorePath
                       -> MonadStore StorePathMetadata
 queryPathInfoUncached path = do
   runOpArgs QueryPathInfo $ do
@@ -277,9 +276,9 @@ queryPathInfoUncached path = do
   deriverPath <- sockGetPathMay
 
   narHashText <- Data.Text.Encoding.decodeUtf8 <$> sockGetStr
-  let narHash = case System.Nix.Hash.decodeBase32 narHashText of
+  let narHash = case System.Nix.Hash.decodeBase32 @'System.Nix.Hash.SHA256 narHashText of
         Left e -> error e
-        Right x -> SomeDigest @a x
+        Right x -> SomeDigest x
 
   references <- sockGetPaths
   registrationTime <- sockGet getTime
@@ -294,7 +293,7 @@ queryPathInfoUncached path = do
       sigs = Data.Set.empty
 
       contentAddressableAddress =
-        case System.Nix.Store.Remote.Parsers.parseContentAddressableAddress @a caString of
+        case System.Nix.Store.Remote.Parsers.parseContentAddressableAddress caString of
           Left e -> error e
           Right x -> Just x
 

hnix-store-remote/src/System/Nix/Store/Remote/Parsers.hs

@@ -2,63 +2,54 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE TypeApplications    #-}
 
-module System.Nix.Store.Remote.Parsers (
-    parseContentAddressableAddress
-  ) where
+module System.Nix.Store.Remote.Parsers
+  ( parseContentAddressableAddress
+  )
+where
 
-import Control.Applicative ((<|>))
-import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
-import Data.ByteString (ByteString)
-import System.Nix.Hash (Digest, NamedAlgo, SomeNamedDigest(SomeDigest))
-import System.Nix.StorePath (ContentAddressableAddress(..), NarHashMode(..))
-
-import qualified Data.Attoparsec.ByteString.Char8
-import qualified Data.ByteString.Char8
+import           Control.Applicative            ( (<|>) )
+import           Data.Attoparsec.ByteString.Char8
+import           Data.ByteString.Char8
 import qualified Data.Text
-
-import qualified System.Nix.Internal.Base32
-import qualified System.Nix.Hash
+import           Data.Text.Encoding             ( decodeUtf8 )
+import           System.Nix.Hash
+import           System.Nix.StorePath           ( ContentAddressableAddress(..)
+                                                , NarHashMode(..)
+                                                )
 
 -- | Parse `ContentAddressableAddress` from `ByteString`
-parseContentAddressableAddress :: forall hashAlgo . NamedAlgo hashAlgo
-                              => ByteString
-                              -> Either String ContentAddressableAddress
+parseContentAddressableAddress
+  :: ByteString -> Either String ContentAddressableAddress
 parseContentAddressableAddress =
-  Data.Attoparsec.ByteString.Char8.parseOnly
-    (contentAddressableAddressParser @hashAlgo)
+  Data.Attoparsec.ByteString.Char8.parseOnly contentAddressableAddressParser
 
 -- | Parser for content addressable field
-contentAddressableAddressParser :: forall hashAlgo . NamedAlgo hashAlgo
-                                => Parser ContentAddressableAddress
-contentAddressableAddressParser =
-      caText
-  <|> caFixed @hashAlgo
+contentAddressableAddressParser :: Parser ContentAddressableAddress
+contentAddressableAddressParser = caText <|> caFixed
 
 -- | Parser for @text:sha256:<h>@
 caText :: Parser ContentAddressableAddress
 caText = do
-  _ <- "text:sha256:"
-  digest <- parseDigest
-  either fail return
-    $ Text <$> digest
+  _      <- "text:sha256:"
+  digest <- decodeBase32 @'SHA256 <$> parseHash
+  either fail return $ Text <$> digest
 
 -- | Parser for @fixed:<r?>:<ht>:<h>@
-caFixed :: forall hashAlgo . NamedAlgo hashAlgo => Parser ContentAddressableAddress
+caFixed :: Parser ContentAddressableAddress
 caFixed = do
-  _ <- "fixed:"
-  narHashMode <- (pure Recursive <$> "true") <|> (pure RegularFile <$> "false")
-    <?> "Invalid Base32 part"
-  digest <- parseDigest
+  _           <- "fixed:"
+  narHashMode <- (pure Recursive <$> "r:") <|> (pure RegularFile <$> "")
+  digest      <- parseTypedDigest
+  either fail return $ Fixed narHashMode <$> digest
+
+parseTypedDigest :: Parser (Either String SomeNamedDigest)
+parseTypedDigest = mkNamedDigest <$> parseHashType <*> parseHash
 
-  either fail return
-    $ Fixed <$> pure narHashMode <*> (SomeDigest @hashAlgo <$> digest)
+parseHashType :: Parser Data.Text.Text
+parseHashType = decodeUtf8 <$> ("sha256" <|> "sha1" <|> "md5") <* ":"
 
-parseDigest :: forall a . Parser (Either String (Digest a))
-parseDigest =
-    System.Nix.Hash.decodeBase32
-  . Data.Text.pack
-  . Data.ByteString.Char8.unpack
-    <$> Data.Attoparsec.ByteString.Char8.takeWhile1
-          (\c -> c `elem` System.Nix.Internal.Base32.digits32)
+parseHash :: Parser Data.Text.Text
+parseHash = decodeUtf8 <$> takeWhile1 (/= ':')