Fix parsing of cas path adresses

Author: layus

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