{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
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 Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import Data.Bits (xor)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Hashable as DataHashable
import Data.List (foldl')
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word (Word8)
import GHC.TypeLits (Nat, KnownNat, natVal)
import qualified System.Nix.Base32 as Base32
data HashAlgorithm
= MD5
| SHA1
| SHA256
| Truncated Nat HashAlgorithm
newtype Digest (a :: HashAlgorithm) =
Digest BS.ByteString deriving (Show, Eq, Ord, DataHashable.Hashable)
class ValidAlgo (a :: HashAlgorithm) where
type AlgoCtx a
initialize :: AlgoCtx a
update :: AlgoCtx a -> BS.ByteString -> AlgoCtx a
finalize :: AlgoCtx a -> Digest a
class NamedAlgo (a :: HashAlgorithm) where
algoName :: Text
instance NamedAlgo 'MD5 where
algoName = "md5"
instance NamedAlgo 'SHA1 where
algoName = "sha1"
instance NamedAlgo 'SHA256 where
algoName = "sha256"
hash :: forall a.ValidAlgo a => BS.ByteString -> Digest a
hash bs =
finalize $ update @a (initialize @a) bs
hashLazy :: forall a.ValidAlgo a => BSL.ByteString -> Digest a
hashLazy bsl =
finalize $ foldl' (update @a) (initialize @a) (BSL.toChunks bsl)
encodeBase32 :: Digest a -> T.Text
encodeBase32 (Digest bs) = Base32.encode bs
encodeBase16 :: Digest a -> T.Text
encodeBase16 (Digest bs) = T.decodeUtf8 (Base16.encode bs)
instance ValidAlgo 'MD5 where
type AlgoCtx 'MD5 = MD5.Ctx
initialize = MD5.init
update = MD5.update
finalize = Digest . MD5.finalize
instance ValidAlgo 'SHA1 where
type AlgoCtx 'SHA1 = SHA1.Ctx
initialize = SHA1.init
update = SHA1.update
finalize = Digest . SHA1.finalize
instance ValidAlgo 'SHA256 where
type AlgoCtx 'SHA256 = SHA256.Ctx
initialize = SHA256.init
update = SHA256.update
finalize = Digest . SHA256.finalize
instance (ValidAlgo a, KnownNat n) => ValidAlgo ('Truncated n a) where
type AlgoCtx ('Truncated n a) = AlgoCtx a
initialize = initialize @a
update = update @a
finalize = truncateDigest @n . finalize @a
truncateDigest
:: forall n a.(KnownNat n) => Digest a -> Digest ('Truncated n a)
truncateDigest (Digest c) =
Digest $ BS.pack $ map truncOutputByte [0.. n-1]
where
n = fromIntegral $ natVal (Proxy @n)
truncOutputByte :: Int -> Word8
truncOutputByte i = foldl' (aux i) 0 [0 .. BS.length c - 1]
inputByte :: Int -> Word8
inputByte j = BS.index c (fromIntegral j)
aux :: Int -> Word8 -> Int -> Word8
aux i x j = if j `mod` fromIntegral n == fromIntegral i
then xor x (inputByte $ fromIntegral j)
else x