{-|
Description : Cryptographic hashing interface for hnix-store, on top
              of the cryptohash family of libraries.
-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE CPP #-}

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 System.Nix.Base32      as Base32  -- Nix has own Base32 encoding
import qualified Data.ByteString.Base64 as Base64
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           Data.Coerce            (coerce)

-- | Constructors to indicate the base encodings
data BaseEncoding
  = Base16
  | Base32
  -- | ^ Nix has a special map of Base32 encoding
  | Base64

-- | The universe of supported hash algorithms.
--
-- Currently only intended for use at the type level.
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 (Digest a -> Digest a -> Bool
(Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Bool) -> Eq (Digest a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
/= :: Digest a -> Digest a -> Bool
$c/= :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
== :: Digest a -> Digest a -> Bool
$c== :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
Eq, Eq (Digest a)
Eq (Digest a)
-> (Digest a -> Digest a -> Ordering)
-> (Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Digest a)
-> (Digest a -> Digest a -> Digest a)
-> Ord (Digest a)
Digest a -> Digest a -> Bool
Digest a -> Digest a -> Ordering
Digest a -> Digest a -> Digest a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (a :: HashAlgorithm). Eq (Digest a)
forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
forall (a :: HashAlgorithm). Digest a -> Digest a -> Ordering
forall (a :: HashAlgorithm). Digest a -> Digest a -> Digest a
min :: Digest a -> Digest a -> Digest a
$cmin :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Digest a
max :: Digest a -> Digest a -> Digest a
$cmax :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Digest a
>= :: Digest a -> Digest a -> Bool
$c>= :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
> :: Digest a -> Digest a -> Bool
$c> :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
<= :: Digest a -> Digest a -> Bool
$c<= :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
< :: Digest a -> Digest a -> Bool
$c< :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Bool
compare :: Digest a -> Digest a -> Ordering
$ccompare :: forall (a :: HashAlgorithm). Digest a -> Digest a -> Ordering
$cp1Ord :: forall (a :: HashAlgorithm). Eq (Digest a)
Ord, Int -> Digest a -> Int
Digest a -> Int
(Int -> Digest a -> Int)
-> (Digest a -> Int) -> Hashable (Digest a)
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (a :: HashAlgorithm). Int -> Digest a -> Int
forall (a :: HashAlgorithm). Digest a -> Int
hash :: Digest a -> Int
$chash :: forall (a :: HashAlgorithm). Digest a -> Int
hashWithSalt :: Int -> Digest a -> Int
$chashWithSalt :: forall (a :: HashAlgorithm). Int -> Digest a -> Int
DataHashable.Hashable)

instance Show (Digest a) where
  show :: Digest a -> String
show = (String
"Digest " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (Digest a -> String) -> Digest a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (Digest a -> Text) -> Digest a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseEncoding -> Digest a -> Text
forall (a :: HashAlgorithm). BaseEncoding -> Digest a -> Text
encodeInBase BaseEncoding
Base32

-- | The primitive interface for incremental hashing for a given
-- 'HashAlgorithm'. Every 'HashAlgorithm' should have an instance.
class ValidAlgo (a :: HashAlgorithm) where
  -- | The incremental state for constructing a hash.
  type AlgoCtx a

  -- | Start building a new hash.
  initialize        :: AlgoCtx a
  -- | Append a 'BS.ByteString' to the overall contents to be hashed.
  update            :: AlgoCtx a -> BS.ByteString -> AlgoCtx a
  -- | Finish hashing and generate the output.
  finalize          :: AlgoCtx a -> Digest a

-- | A 'HashAlgorithm' with a canonical name, for serialization
-- purposes (e.g. SRI hashes)
class ValidAlgo a => NamedAlgo (a :: HashAlgorithm) where
  algoName :: Text
  hashSize :: Int

instance NamedAlgo 'MD5 where
  algoName :: Text
algoName = Text
"md5"
  hashSize :: Int
hashSize = Int
16

instance NamedAlgo 'SHA1 where
  algoName :: Text
algoName = Text
"sha1"
  hashSize :: Int
hashSize = Int
20

instance NamedAlgo 'SHA256 where
  algoName :: Text
algoName = Text
"sha256"
  hashSize :: Int
hashSize = Int
32

instance NamedAlgo 'SHA512 where
  algoName :: Text
algoName = Text
"sha512"
  hashSize :: Int
hashSize = Int
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 :: SomeNamedDigest -> String
show SomeNamedDigest
sd = case SomeNamedDigest
sd of
    SomeDigest (Digest a
digest :: Digest hashType) -> Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"SomeDigest " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NamedAlgo a => Text
forall (a :: HashAlgorithm). NamedAlgo a => Text
algoName @hashType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BaseEncoding -> Digest a -> Text
forall (a :: HashAlgorithm). BaseEncoding -> Digest a -> Text
encodeInBase BaseEncoding
Base32 Digest a
digest

mkNamedDigest :: Text -> Text -> Either String SomeNamedDigest
mkNamedDigest :: Text -> Text -> Either String SomeNamedDigest
mkNamedDigest Text
name Text
sriHash =
  let (Text
sriName, Text
h) = Text -> Text -> (Text, Text)
T.breakOnEnd Text
"-" Text
sriHash in
    if Text
sriName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" Bool -> Bool -> Bool
|| Text
sriName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-")
    then Text -> Either String SomeNamedDigest
mkDigest Text
h
    else String -> Either String SomeNamedDigest
forall a b. a -> Either a b
Left (String -> Either String SomeNamedDigest)
-> String -> Either String SomeNamedDigest
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Sri hash method " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sriName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not match the required hash type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
 where
  mkDigest :: Text -> Either String SomeNamedDigest
mkDigest Text
h = case Text
name of
    Text
"md5"    -> Digest 'MD5 -> SomeNamedDigest
forall (a :: HashAlgorithm).
NamedAlgo a =>
Digest a -> SomeNamedDigest
SomeDigest (Digest 'MD5 -> SomeNamedDigest)
-> Either String (Digest 'MD5) -> Either String SomeNamedDigest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String (Digest 'MD5)
forall (a :: HashAlgorithm).
(NamedAlgo a, ValidAlgo a) =>
Text -> Either String (Digest a)
decodeGo @'MD5    Text
h
    Text
"sha1"   -> Digest 'SHA1 -> SomeNamedDigest
forall (a :: HashAlgorithm).
NamedAlgo a =>
Digest a -> SomeNamedDigest
SomeDigest (Digest 'SHA1 -> SomeNamedDigest)
-> Either String (Digest 'SHA1) -> Either String SomeNamedDigest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String (Digest 'SHA1)
forall (a :: HashAlgorithm).
(NamedAlgo a, ValidAlgo a) =>
Text -> Either String (Digest a)
decodeGo @'SHA1   Text
h
    Text
"sha256" -> Digest 'SHA256 -> SomeNamedDigest
forall (a :: HashAlgorithm).
NamedAlgo a =>
Digest a -> SomeNamedDigest
SomeDigest (Digest 'SHA256 -> SomeNamedDigest)
-> Either String (Digest 'SHA256) -> Either String SomeNamedDigest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String (Digest 'SHA256)
forall (a :: HashAlgorithm).
(NamedAlgo a, ValidAlgo a) =>
Text -> Either String (Digest a)
decodeGo @'SHA256 Text
h
    Text
"sha512" -> Digest 'SHA512 -> SomeNamedDigest
forall (a :: HashAlgorithm).
NamedAlgo a =>
Digest a -> SomeNamedDigest
SomeDigest (Digest 'SHA512 -> SomeNamedDigest)
-> Either String (Digest 'SHA512) -> Either String SomeNamedDigest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either String (Digest 'SHA512)
forall (a :: HashAlgorithm).
(NamedAlgo a, ValidAlgo a) =>
Text -> Either String (Digest a)
decodeGo @'SHA512 Text
h
    Text
_        -> String -> Either String SomeNamedDigest
forall a b. a -> Either a b
Left (String -> Either String SomeNamedDigest)
-> String -> Either String SomeNamedDigest
forall a b. (a -> b) -> a -> b
$ String
"Unknown hash name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name
  decodeGo :: forall a . (NamedAlgo a, ValidAlgo a) => Text -> Either String (Digest a)
  decodeGo :: Text -> Either String (Digest a)
decodeGo Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base16Len = BaseEncoding -> Text -> Either String (Digest a)
forall (a :: HashAlgorithm).
BaseEncoding -> Text -> Either String (Digest a)
decodeBase BaseEncoding
Base16 Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base32Len = BaseEncoding -> Text -> Either String (Digest a)
forall (a :: HashAlgorithm).
BaseEncoding -> Text -> Either String (Digest a)
decodeBase BaseEncoding
Base32 Text
h
    | Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
base64Len = BaseEncoding -> Text -> Either String (Digest a)
forall (a :: HashAlgorithm).
BaseEncoding -> Text -> Either String (Digest a)
decodeBase BaseEncoding
Base64 Text
h
    | Bool
otherwise = String -> Either String (Digest a)
forall a b. a -> Either a b
Left (String -> Either String (Digest a))
-> String -> Either String (Digest a)
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
sriHash String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a valid " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" hash. Its length (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
size String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") does not match any of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show [Int
base16Len, Int
base32Len, Int
base64Len]
   where
    size :: Int
size = Text -> Int
T.length Text
h
    hsize :: Int
hsize = NamedAlgo a => Int
forall (a :: HashAlgorithm). NamedAlgo a => Int
hashSize @a
    base16Len :: Int
base16Len = Int
hsize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    base32Len :: Int
base32Len = ((Int
hsize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1;
    base64Len :: Int
base64Len = ((Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hsize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4;


-- | Hash an entire (strict) 'BS.ByteString' as a single call.
--
--   For example:
--   > let d = hash "Hello, sha-256!" :: Digest SHA256
--   or
--   > :set -XTypeApplications
--   > let d = hash @SHA256 "Hello, sha-256!"
hash :: forall a.ValidAlgo a => BS.ByteString -> Digest a
hash :: ByteString -> Digest a
hash ByteString
bs =
  AlgoCtx a -> Digest a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a -> Digest a
finalize (AlgoCtx a -> Digest a) -> AlgoCtx a -> Digest a
forall a b. (a -> b) -> a -> b
$ AlgoCtx a -> ByteString -> AlgoCtx a
forall (a :: HashAlgorithm).
ValidAlgo a =>
AlgoCtx a -> ByteString -> AlgoCtx a
update @a (ValidAlgo a => AlgoCtx a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a
initialize @a) ByteString
bs

-- | Hash an entire (lazy) 'BSL.ByteString' as a single call.
--
-- Use is the same as for 'hash'.  This runs in constant space, but
-- forces the entire bytestring.
hashLazy :: forall a.ValidAlgo a => BSL.ByteString -> Digest a
hashLazy :: ByteString -> Digest a
hashLazy ByteString
bsl =
  AlgoCtx a -> Digest a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a -> Digest a
finalize (AlgoCtx a -> Digest a) -> AlgoCtx a -> Digest a
forall a b. (a -> b) -> a -> b
$ (AlgoCtx a -> ByteString -> AlgoCtx a)
-> AlgoCtx a -> [ByteString] -> AlgoCtx a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (ValidAlgo a => AlgoCtx a -> ByteString -> AlgoCtx a
forall (a :: HashAlgorithm).
ValidAlgo a =>
AlgoCtx a -> ByteString -> AlgoCtx a
update @a) (ValidAlgo a => AlgoCtx a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a
initialize @a) (ByteString -> [ByteString]
BSL.toChunks ByteString
bsl)


-- | Take BaseEncoding type of the output -> take the Digeest as input -> encode Digest
encodeInBase :: BaseEncoding -> Digest a -> T.Text
encodeInBase :: BaseEncoding -> Digest a -> Text
encodeInBase BaseEncoding
Base16 = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (Digest a -> ByteString) -> Digest a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (Digest a -> ByteString) -> Digest a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> ByteString
coerce
encodeInBase BaseEncoding
Base32 = ByteString -> Text
Base32.encode (ByteString -> Text)
-> (Digest a -> ByteString) -> Digest a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> ByteString
coerce
encodeInBase BaseEncoding
Base64 = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (Digest a -> ByteString) -> Digest a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base64.encode (ByteString -> ByteString)
-> (Digest a -> ByteString) -> Digest a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> ByteString
coerce


-- | Take BaseEncoding type of the input -> take the input itself -> decodeBase into Digest
decodeBase :: BaseEncoding -> T.Text -> Either String (Digest a)
#if MIN_VERSION_base16_bytestring(1,0,0)
decodeBase :: BaseEncoding -> Text -> Either String (Digest a)
decodeBase BaseEncoding
Base16 = (ByteString -> Digest a)
-> Either String ByteString -> Either String (Digest a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Digest a
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (Either String ByteString -> Either String (Digest a))
-> (Text -> Either String ByteString)
-> Text
-> Either String (Digest a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
#else
decodeBase Base16 = lDecode  -- this tacit sugar simply makes GHC pleased with number of args
 where
  lDecode t = case Base16.decode (T.encodeUtf8 t) of
    (x, "") -> Right $ Digest x
    _       -> Left $ "Unable to decode base16 string" <> T.unpack t
#endif
decodeBase BaseEncoding
Base32 = (ByteString -> Digest a)
-> Either String ByteString -> Either String (Digest a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Digest a
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (Either String ByteString -> Either String (Digest a))
-> (Text -> Either String ByteString)
-> Text
-> Either String (Digest a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String ByteString
Base32.decode
decodeBase BaseEncoding
Base64 = (ByteString -> Digest a)
-> Either String ByteString -> Either String (Digest a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Digest a
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (Either String ByteString -> Either String (Digest a))
-> (Text -> Either String ByteString)
-> Text
-> Either String (Digest a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
Base64.decode (ByteString -> Either String ByteString)
-> (Text -> ByteString) -> Text -> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8


-- | Uses "Crypto.Hash.MD5" from cryptohash-md5.
instance ValidAlgo 'MD5 where
  type AlgoCtx 'MD5 = MD5.Ctx
  initialize :: AlgoCtx 'MD5
initialize = Ctx
AlgoCtx 'MD5
MD5.init
  update :: AlgoCtx 'MD5 -> ByteString -> AlgoCtx 'MD5
update = Ctx -> ByteString -> Ctx
AlgoCtx 'MD5 -> ByteString -> AlgoCtx 'MD5
MD5.update
  finalize :: AlgoCtx 'MD5 -> Digest 'MD5
finalize = ByteString -> Digest 'MD5
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (ByteString -> Digest 'MD5)
-> (Ctx -> ByteString) -> Ctx -> Digest 'MD5
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString
MD5.finalize

-- | Uses "Crypto.Hash.SHA1" from cryptohash-sha1.
instance ValidAlgo 'SHA1 where
  type AlgoCtx 'SHA1 = SHA1.Ctx
  initialize :: AlgoCtx 'SHA1
initialize = Ctx
AlgoCtx 'SHA1
SHA1.init
  update :: AlgoCtx 'SHA1 -> ByteString -> AlgoCtx 'SHA1
update = Ctx -> ByteString -> Ctx
AlgoCtx 'SHA1 -> ByteString -> AlgoCtx 'SHA1
SHA1.update
  finalize :: AlgoCtx 'SHA1 -> Digest 'SHA1
finalize = ByteString -> Digest 'SHA1
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (ByteString -> Digest 'SHA1)
-> (Ctx -> ByteString) -> Ctx -> Digest 'SHA1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString
SHA1.finalize

-- | Uses "Crypto.Hash.SHA256" from cryptohash-sha256.
instance ValidAlgo 'SHA256 where
  type AlgoCtx 'SHA256 = SHA256.Ctx
  initialize :: AlgoCtx 'SHA256
initialize = Ctx
AlgoCtx 'SHA256
SHA256.init
  update :: AlgoCtx 'SHA256 -> ByteString -> AlgoCtx 'SHA256
update = Ctx -> ByteString -> Ctx
AlgoCtx 'SHA256 -> ByteString -> AlgoCtx 'SHA256
SHA256.update
  finalize :: AlgoCtx 'SHA256 -> Digest 'SHA256
finalize = ByteString -> Digest 'SHA256
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (ByteString -> Digest 'SHA256)
-> (Ctx -> ByteString) -> Ctx -> Digest 'SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString
SHA256.finalize

-- | Uses "Crypto.Hash.SHA512" from cryptohash-sha512.
instance ValidAlgo 'SHA512 where
  type AlgoCtx 'SHA512 = SHA512.Ctx
  initialize :: AlgoCtx 'SHA512
initialize = Ctx
AlgoCtx 'SHA512
SHA512.init
  update :: AlgoCtx 'SHA512 -> ByteString -> AlgoCtx 'SHA512
update = Ctx -> ByteString -> Ctx
AlgoCtx 'SHA512 -> ByteString -> AlgoCtx 'SHA512
SHA512.update
  finalize :: AlgoCtx 'SHA512 -> Digest 'SHA512
finalize = ByteString -> Digest 'SHA512
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (ByteString -> Digest 'SHA512)
-> (Ctx -> ByteString) -> Ctx -> Digest 'SHA512
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ByteString
SHA512.finalize

-- | Reuses the underlying 'ValidAlgo' instance, but does a
-- 'truncateDigest' at the end.
instance (ValidAlgo a, KnownNat n) => ValidAlgo ('Truncated n a) where
  type AlgoCtx ('Truncated n a) = AlgoCtx a
  initialize :: AlgoCtx ('Truncated n a)
initialize = ValidAlgo a => AlgoCtx a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a
initialize @a
  update :: AlgoCtx ('Truncated n a) -> ByteString -> AlgoCtx ('Truncated n a)
update = ValidAlgo a => AlgoCtx a -> ByteString -> AlgoCtx a
forall (a :: HashAlgorithm).
ValidAlgo a =>
AlgoCtx a -> ByteString -> AlgoCtx a
update @a
  finalize :: AlgoCtx ('Truncated n a) -> Digest ('Truncated n a)
finalize = forall (n :: Nat) (a :: HashAlgorithm).
KnownNat n =>
Digest a -> Digest ('Truncated n a)
forall (a :: HashAlgorithm).
KnownNat n =>
Digest a -> Digest ('Truncated n a)
truncateDigest @n (Digest a -> Digest ('Truncated n a))
-> (AlgoCtx a -> Digest a) -> AlgoCtx a -> Digest ('Truncated n a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidAlgo a => AlgoCtx a -> Digest a
forall (a :: HashAlgorithm). ValidAlgo a => AlgoCtx a -> Digest a
finalize @a

-- | Bytewise truncation of a 'Digest'.
--
-- When truncation length is greater than the length of the bytestring
-- but less than twice the bytestring length, truncation splits the
-- bytestring into a head part (truncation length) and tail part
-- (leftover part), right-pads the leftovers with 0 to the truncation
-- length, and combines the two strings bytewise with 'xor'.
truncateDigest
  :: forall n a.(KnownNat n) => Digest a -> Digest ('Truncated n a)
truncateDigest :: Digest a -> Digest ('Truncated n a)
truncateDigest (Digest ByteString
c) =
    ByteString -> Digest ('Truncated n a)
forall (a :: HashAlgorithm). ByteString -> Digest a
Digest (ByteString -> Digest ('Truncated n a))
-> ByteString -> Digest ('Truncated n a)
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Int -> Word8) -> [Int] -> [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Word8
truncOutputByte [Int
0.. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  where
    n :: Int
n = Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)

    truncOutputByte :: Int -> Word8
    truncOutputByte :: Int -> Word8
truncOutputByte Int
i = (Word8 -> Int -> Word8) -> Word8 -> [Int] -> Word8
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int -> Word8 -> Int -> Word8
aux Int
i) Word8
0 [Int
0 .. ByteString -> Int
BS.length ByteString
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

    inputByte :: Int -> Word8
    inputByte :: Int -> Word8
inputByte Int
j = ByteString -> Int -> Word8
BS.index ByteString
c (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j)

    aux :: Int -> Word8 -> Int -> Word8
    aux :: Int -> Word8 -> Int -> Word8
aux Int
i Word8
x Int
j = if Int
j Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                then Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
xor Word8
x (Int -> Word8
inputByte (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j)
                else Word8
x