Reflect type level hash algo to value

Author: imalsogreg

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

@@ -13,7 +13,9 @@ Maintainer  : Shea Levy <[email protected]>; Greg Hale <[email protected]>
 module System.Nix.Hash (
     HNix.Digest
 
-  , HNix.HashAlgorithm(..)
+  , HNix.HashAlgorithm
+  , HNix.HashAlgorithm'(..)
+  , HNix.AlgoVal(..)
   , HNix.HasDigest(..)
   , HNix.hash
   , HNix.hashLazy

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

@@ -11,6 +11,7 @@ Maintainer  : Greg Hale <[email protected]>
 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeInType          #-}
 
 module System.Nix.Internal.Hash where
 
@@ -23,6 +24,7 @@ import           Data.Bits             (xor)
 import qualified Data.ByteString       as BS
 import qualified Data.ByteString.Lazy  as BSL
 import qualified Data.Hashable         as DataHashable
+import           Data.Kind             (Type)
 import           Data.List             (foldl')
 import           Data.Proxy            (Proxy(Proxy))
 import qualified Data.Text             as T
@@ -34,12 +36,31 @@ import           GHC.TypeLits
 -- | A tag for different hashing algorithms
 --   Also used as a type-level tag for hash digests
 --   (e.g. @Digest SHA256@ is the type for a sha256 hash)
-data HashAlgorithm
+--
+--  When used at the type level, `n` is `Nat`
+data HashAlgorithm' n
   = MD5
   | SHA1
   | SHA256
-  | Truncated Nat HashAlgorithm
+  | Truncated n (HashAlgorithm' n)
+  deriving (Eq, Show)
+
+type HashAlgorithm = HashAlgorithm' Nat
+
+class AlgoVal (a :: HashAlgorithm) where
+  algoVal :: HashAlgorithm' Integer
+
+instance AlgoVal MD5 where
+  algoVal = MD5
+
+instance AlgoVal SHA1 where
+  algoVal = SHA1
+
+instance AlgoVal SHA256 where
+  algoVal = SHA256
 
+instance forall a n.(AlgoVal a, KnownNat n) => AlgoVal (Truncated n a) where
+  algoVal = Truncated (natVal (Proxy @n)) (algoVal @a)
 
 -- | Types with kind @HashAlgorithm@ may be a @HasDigest@ instance
 --   if they are able to hash bytestrings via the init/update/finalize
@@ -49,7 +70,7 @@ data HashAlgorithm
 --   monomorphic hashing libraries, such as `cryptohash-sha256`.
 class HasDigest (a :: HashAlgorithm) where
 
-  type AlgoCtx a :: *
+  type AlgoCtx a :: Type
 
   initialize        :: AlgoCtx a
   update            :: AlgoCtx a -> BS.ByteString -> AlgoCtx a

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

@@ -18,7 +18,7 @@ module System.Nix.Path
   ) where
 
 import           System.Nix.Hash           (Digest(..),
-                                            HashAlgorithm(Truncated, SHA256))
+                                            HashAlgorithm'(Truncated, SHA256))
 import qualified Data.ByteString           as BS
 import qualified Data.ByteString.Char8     as BSC
 import           Data.Hashable             (Hashable (..), hashPtrWithSalt)

hnix-store-remote/app/Main.hs

@@ -1,13 +1,13 @@
 {-# LANGUAGE OverloadedStrings   #-}
 import qualified Data.ByteString.Lazy as LBS
-import qualified Data.HashSet as HS
-import qualified System.Nix.GC as GC
-import System.Nix.Store.Remote
-import System.Nix.Store.Remote.Util
-import Data.Maybe
-import Control.Monad.Reader
+import qualified Data.HashSet         as HS
+import           Data.Maybe
+import           Control.Monad.Reader
+import           Text.Pretty.Simple
 
-import Text.Pretty.Simple
+import qualified System.Nix.GC                as GC
+import           System.Nix.Store.Remote
+import           System.Nix.Store.Remote.Util
 
 noSuchPath = fromJust $ mkPath "blah"
 

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

@@ -1,4 +1,10 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 module System.Nix.Store.Remote (
     runStore
   , isValidPathUncached
@@ -32,6 +38,7 @@ module System.Nix.Store.Remote (
 import           Data.Maybe
 import qualified Data.ByteString.Lazy      as LBS
 import qualified Data.Map.Strict           as M
+import           Data.Proxy                (Proxy(Proxy))
 
 import           Control.Monad
 
@@ -40,6 +47,7 @@ import qualified System.Nix.Derivation as Drv
 import qualified System.Nix.GC         as GC
 import           System.Nix.Hash       (Digest, HashAlgorithm)
 import           System.Nix.Path
+import           System.Nix.Hash
 import           System.Nix.Util
 
 import           System.Nix.Store.Remote.Types
@@ -159,9 +167,40 @@ type Source = () -- abstract binary source
 addToStoreNar :: ValidPathInfo -> Source -> RepairFlag -> CheckSigsFlag -> MonadStore ()
 addToStoreNar = undefined  -- XXX
 
+
+-- class BaseHashAlgorithm (a :: HashAlgorithm) where
+--   baseHashAlgorithm :: Bool
+
+-- instance BaseHashAlgorithm MD5 where
+--   baseHashAlgorithm = MD5
+
+-- instance BaseHashAlgorithm SHA1 where
+--   baseHashAlgorithm = SHA1
+
+-- instance BaseHashAlgorithm SHA256 where
+--   baseHashAlgorithm = SHA256
+
+-- instance forall n a.BaseHashAlgorithm a => BaseHashAlgorithm (Truncated n a) where
+--   baseHashAlgorithm = baseHashAlgorithm @a
+
 type PathFilter = Path -> Bool
-addToStore :: LBS.ByteString -> Path -> Bool -> HashAlgorithm -> PathFilter -> RepairFlag -> MonadStore Path
-addToStore name pth recursive hashAlgo pfilter repair = undefined -- XXX
+addToStore
+  :: forall a. AlgoVal a
+  => LBS.ByteString
+  -> Path
+  -> Bool
+  -> Proxy a
+  -> PathFilter
+  -> RepairFlag
+  -> MonadStore Path
+addToStore name pth recursive algoProxy pfilter repair = do
+  runOpArgs AddToStore $ do
+    putByteStringLen name
+    putByteStringLen $ if algoVal @a == SHA256 && recursive then 0 else 1
+    putByteStringLen $ if recursive then 0 else 1
+    putByteStringLen name
+  fmap (fromMaybe "TODO: Error") sockGetPath
+
 
 addTextToStore :: LBS.ByteString -> LBS.ByteString -> PathSet -> RepairFlag -> MonadStore (Maybe Path)
 addTextToStore name text references' repair = do