Sha512 and base64 support

hnix-store-core/hnix-store-core.cabal

@@ -33,13 +33,15 @@ library
   build-depends:       base >=4.10 && <5
                      , attoparsec
                      , base16-bytestring
+                     , base64-bytestring
                      , bytestring
                      , binary
                      , bytestring
                      , containers
                      , cryptohash-md5
                      , cryptohash-sha1
                      , cryptohash-sha256
+                     , cryptohash-sha512
                      , directory
                      , filepath
                      , hashable

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

@@ -16,8 +16,10 @@ module System.Nix.Internal.Hash where
 import qualified Crypto.Hash.MD5        as MD5
 import qualified Crypto.Hash.SHA1       as SHA1
 import qualified Crypto.Hash.SHA256     as SHA256
+import qualified Crypto.Hash.SHA512     as SHA512
 import qualified Data.ByteString        as BS
 import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Base64 as Base64
 import           Data.Bits              (xor)
 import qualified Data.ByteString.Lazy   as BSL
 import qualified Data.Hashable          as DataHashable
@@ -37,14 +39,18 @@ data HashAlgorithm
   = MD5
   | SHA1
   | SHA256
+  | SHA512
   | Truncated Nat HashAlgorithm
     -- ^ The hash algorithm obtained by truncating the result of the
     -- input 'HashAlgorithm' to the given number of bytes. See
     -- 'truncateDigest' for a description of the truncation algorithm.
 
 -- | 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 +67,60 @@ 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 sriHash =
+  let (sriName, hash) = T.breakOnEnd "-" sriHash in
+    if sriName == "" || sriName == (name <> "-")
+    then mkDigest name hash
+    else Left $ T.unpack $ "Sri hash method " <> sriName <> " does not match the required hash type " <> name
+ where
+  mkDigest name hash = case name of
+    "md5"    -> SomeDigest <$> decode @'MD5    hash
+    "sha1"   -> SomeDigest <$> decode @'SHA1   hash
+    "sha256" -> SomeDigest <$> decode @'SHA256 hash
+    "sha512" -> SomeDigest <$> decode @'SHA512 hash
+    _        -> Left $ "Unknown hash name: " ++ T.unpack name
+  decode :: forall a . (NamedAlgo a, ValidAlgo a) => Text -> Either String (Digest a)
+  decode hash
+    | size == base16Len = decodeBase16 hash
+    | size == base32Len = decodeBase32 hash
+    | size == base64Len = decodeBase64 hash
+    | otherwise = Left $ T.unpack sriHash ++ " is not a valid " ++ T.unpack name ++ " hash. Its length (" ++ show size ++ ") does not match any of " ++ show [base16Len, base32Len, base64Len]
+   where
+    size = T.length hash
+    hsize = hashSize @a
+    base16Len = hsize * 2
+    base32Len = ((hsize * 8 - 1) `div` 5) + 1;
+    base64Len = ((4 * hsize `div` 3) + 3) `div` 4 * 4;
+
+
 -- | Hash an entire (strict) 'BS.ByteString' as a single call.
 --
 --   For example:
@@ -113,6 +158,16 @@ decodeBase16 t = case Base16.decode (T.encodeUtf8 t) of
   (x, "") -> Right $ Digest x
   _       -> Left $ "Unable to decode base16 string " ++ T.unpack t
 
+-- | Encode a 'Digest' in hex.
+encodeBase64 :: Digest a -> T.Text
+encodeBase64 (Digest bs) = T.decodeUtf8 (Base64.encode bs)
+
+-- | Decode a 'Digest' in hex
+decodeBase64 :: T.Text -> Either String (Digest a)
+decodeBase64 t = case Base64.decode (T.encodeUtf8 t) of
+  Right x -> Right $ Digest x
+  Left  e -> Left $ "Unable to decode base64 string " ++ T.unpack t ++ ": " ++ e
+
 -- | Uses "Crypto.Hash.MD5" from cryptohash-md5.
 instance ValidAlgo 'MD5 where
   type AlgoCtx 'MD5 = MD5.Ctx
@@ -134,6 +189,13 @@ instance ValidAlgo 'SHA256 where
   update = SHA256.update
   finalize = Digest . SHA256.finalize
 
+-- | Uses "Crypto.Hash.SHA512" from cryptohash-sha512.
+instance ValidAlgo 'SHA512 where
+  type AlgoCtx 'SHA512 = SHA512.Ctx
+  initialize = SHA512.init
+  update = SHA512.update
+  finalize = Digest . SHA512.finalize
+
 -- | Reuses the underlying 'ValidAlgo' instance, but does a
 -- 'truncateDigest' at the end.
 instance (ValidAlgo a, KnownNat n) => ValidAlgo ('Truncated n a) where

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" <|> "sha512" <|> "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 (/= ':')