Truncated cryptographic hashes implementation.

.gitignore

@@ -0,0 +1 @@
+dist

README.md

@@ -0,0 +1,13 @@
+hnix-store
+===========
+
+A Haskell interface to the [Nix] store.
+
+[Nix]: https://nixos.org/nix
+
+Packages
+----------
+
+* [hnix-store-core]: Core effects for interacting with the Nix store.
+
+[hnix-store-core]: ./hnix-store-core

hnix-store-core/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for hnix-store-core
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version.

hnix-store-core/LICENSE

@@ -0,0 +1 @@
+../LICENSE

hnix-store-core/README.md

@@ -0,0 +1,4 @@
+hnix-store-core
+=================
+
+Core effects for interacting with the Nix store.

hnix-store-core/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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

@@ -0,0 +1,28 @@
+name:                hnix-store-core
+version:             0.1.0.0
+synopsis:            Core effects for interacting with the Nix store.
+description:
+        This package contains types and functions needed to describe
+        interactions with the Nix store abstracted away from
+        specific effectful context.
+homepage:            https://github.com/haskell-nix/hnix-store
+license:             Apache-2.0
+license-file:        LICENSE
+author:              Shea Levy
+maintainer:          shea@shealevy.com
+copyright:           2018 Shea Levy
+category:            System
+build-type:          Simple
+extra-source-files:  ChangeLog.md, README.md
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Crypto.Hash.Truncated
+  build-depends:       base >=4.10 && <4.11,
+                       cryptonite,
+                       memory,
+                       -- Drop foundation when we can drop cryptonite <0.25
+                       foundation,
+                       basement
+  hs-source-dirs:      src
+  default-language:    Haskell2010

hnix-store-core/src/Crypto/Hash/Truncated.hs

@@ -0,0 +1,63 @@
+{-|
+Description : Trunctions of cryptographic hashes.
+Maintainer  : Shea Levy <shea@shealevy.com>
+-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+module Crypto.Hash.Truncated where
+
+import Control.Monad (void)
+import Data.Coerce (coerce, Coercible)
+import Data.Proxy (Proxy(..))
+import Data.Word (Word8)
+import GHC.TypeLits (Nat, KnownNat, natVal, type (<=))
+import Crypto.Hash (Digest)
+import Crypto.Hash.IO (HashAlgorithm(..),)
+import Data.ByteArray (alloc)
+import Foreign.Ptr (castPtr, Ptr)
+import Foreign.Marshal.Utils (copyBytes)
+#if MIN_VERSION_cryptonite(0,25,0)
+import Basement.Block.Mutable (Block)
+#else
+import Foundation.Array (UArray)
+#endif
+-- | Hash algorithm 'algo' truncated to 'size' bytes.
+newtype Truncated algo (size :: Nat) = Truncated algo
+
+-- | The underlying type of a 'Digest'.
+#if MIN_VERSION_cryptonite(0,25,0)
+type DigestUnwrapped = Block Word8
+#else
+type DigestUnwrapped = UArray Word8
+#endif
+
+-- | Use the 'HashAlgorithm' instance of 'algo' and truncate the final
+-- digest.
+--
+-- The 'Coercible' constraint adds a little bit of type safety to the
+-- pointer munging that goes on under the hood.
+instance (HashAlgorithm algo, KnownNat (HashDigestSize algo)
+         , KnownNat size, size <= HashDigestSize algo
+         , Coercible (Digest algo) DigestUnwrapped
+         ) => HashAlgorithm (Truncated algo size) where
+  type HashBlockSize (Truncated algo size) = HashBlockSize algo
+  type HashDigestSize (Truncated algo size) = size
+  type HashInternalContextSize (Truncated algo size) =
+    HashInternalContextSize algo
+  hashBlockSize = hashBlockSize @algo . coerce
+  hashDigestSize _ = fromIntegral $ natVal @size Proxy
+  hashInternalContextSize = hashInternalContextSize @algo . coerce
+  hashInternalInit = hashInternalInit @algo . coerce
+  hashInternalUpdate = hashInternalUpdate @algo . coerce
+  hashInternalFinalize cptr dptr = void @_ @DigestUnwrapped $
+      alloc (fromIntegral $ natVal @(HashDigestSize algo) Proxy) go
+    where
+      go :: Ptr (Digest algo) -> IO ()
+      go p = do
+        hashInternalFinalize (coerce cptr) p
+        copyBytes dptr (castPtr p) (fromIntegral $ natVal @size Proxy)