{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Module      : Crypto.Hash.Types
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Crypto hash types definitions
module Crypto.Hash.Types (
    HashAlgorithm (..),
    HashAlgorithmPrefix (..),
    Context (..),
    Digest (..),
) where

import Basement.Block (Block, unsafeFreeze)
import Basement.Block.Mutable (MutableBlock, new, unsafeWrite)
import Basement.NormalForm (deepseq)
import Basement.Types.OffsetSize (CountOf (..), Offset (..))
import Control.Monad.ST
import Crypto.Internal.ByteArray (ByteArrayAccess, Bytes)
import qualified Crypto.Internal.ByteArray as B
import Crypto.Internal.Imports
import Data.Char (digitToInt, isHexDigit)
import Data.Data (Data)
import Foreign.Ptr (Ptr)
import GHC.TypeLits (Nat)

-- | Class representing hashing algorithms.
--
-- The interface presented here is update in place
-- and lowlevel. the Hash module takes care of
-- hidding the mutable interface properly.
class HashAlgorithm a where
    -- | Associated type for the block size of the hash algorithm
    type HashBlockSize a :: Nat

    -- | Associated type for the digest size of the hash algorithm
    type HashDigestSize a :: Nat

    -- | Associated type for the internal context size of the hash algorithm
    type HashInternalContextSize a :: Nat

    -- | Get the block size of a hash algorithm
    hashBlockSize :: a -> Int

    -- | Get the digest size of a hash algorithm
    hashDigestSize :: a -> Int

    -- | Get the size of the context used for a hash algorithm
    hashInternalContextSize :: a -> Int

    -- hashAlgorithmFromProxy  :: Proxy a -> a

    -- | Initialize a context pointer to the initial state of a hash algorithm
    hashInternalInit :: Ptr (Context a) -> IO ()

    -- | Update the context with some raw data
    hashInternalUpdate :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()

    -- | Finalize the context and set the digest raw memory to the right value
    hashInternalFinalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()

-- | Hashing algorithms with a constant-time implementation.
class HashAlgorithm a => HashAlgorithmPrefix a where
    -- | Update the context with the first N bytes of a buffer and finalize this
    -- context.  The code path executed is independent from N and depends only
    -- on the complete buffer length.
    hashInternalFinalizePrefix
        :: Ptr (Context a)
        -> Ptr Word8
        -> Word32
        -> Word32
        -> Ptr (Digest a)
        -> IO ()

{-
hashContextGetAlgorithm :: HashAlgorithm a => Context a -> a
hashContextGetAlgorithm = undefined
-}

-- | Represent a context for a given hash algorithm.
--
-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal
-- layout is architecture dependent, may contain uninitialized data fragments,
-- and change in future versions.  The bytearray should not be used as input to
-- cryptographic algorithms.
newtype Context a = Context Bytes
    deriving (Context a -> Int
(Context a -> Int)
-> (forall p a. Context a -> (Ptr p -> IO a) -> IO a)
-> (forall p. Context a -> Ptr p -> IO ())
-> ByteArrayAccess (Context a)
forall a. Context a -> Int
forall p. Context a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. Context a -> Ptr p -> IO ()
forall p a. Context a -> (Ptr p -> IO a) -> IO a
forall a p a. Context a -> (Ptr p -> IO a) -> IO a
$clength :: forall a. Context a -> Int
length :: Context a -> Int
$cwithByteArray :: forall a p a. Context a -> (Ptr p -> IO a) -> IO a
withByteArray :: forall p a. Context a -> (Ptr p -> IO a) -> IO a
$ccopyByteArrayToPtr :: forall a p. Context a -> Ptr p -> IO ()
copyByteArrayToPtr :: forall p. Context a -> Ptr p -> IO ()
ByteArrayAccess, Context a -> ()
(Context a -> ()) -> NFData (Context a)
forall a. Context a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. Context a -> ()
rnf :: Context a -> ()
NFData)

-- | Represent a digest for a given hash algorithm.
--
-- This type is an instance of 'ByteArrayAccess' from package
-- <https://hackage.haskell.org/package/memory memory>.
-- Module "Data.ByteArray" provides many primitives to work with those values
-- including conversion to other types.
--
-- Creating a digest from a bytearray is also possible with function
-- 'Crypto.Hash.digestFromByteString'.
newtype Digest a = Digest (Block Word8)
    deriving (Digest a -> Digest a -> Bool
(Digest a -> Digest a -> Bool)
-> (Digest a -> Digest a -> Bool) -> Eq (Digest a)
forall a. Digest a -> Digest a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Digest a -> Digest a -> Bool
== :: Digest a -> Digest a -> Bool
$c/= :: forall a. Digest a -> Digest a -> Bool
/= :: 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 (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. Digest a -> Digest a -> Bool
forall a. Digest a -> Digest a -> Ordering
forall a. Digest a -> Digest a -> Digest a
$ccompare :: forall a. Digest a -> Digest a -> Ordering
compare :: Digest a -> Digest a -> Ordering
$c< :: forall a. Digest a -> Digest a -> Bool
< :: Digest a -> Digest a -> Bool
$c<= :: forall a. Digest a -> Digest a -> Bool
<= :: Digest a -> Digest a -> Bool
$c> :: forall a. Digest a -> Digest a -> Bool
> :: Digest a -> Digest a -> Bool
$c>= :: forall a. Digest a -> Digest a -> Bool
>= :: Digest a -> Digest a -> Bool
$cmax :: forall a. Digest a -> Digest a -> Digest a
max :: Digest a -> Digest a -> Digest a
$cmin :: forall a. Digest a -> Digest a -> Digest a
min :: Digest a -> Digest a -> Digest a
Ord, Digest a -> Int
(Digest a -> Int)
-> (forall p a. Digest a -> (Ptr p -> IO a) -> IO a)
-> (forall p. Digest a -> Ptr p -> IO ())
-> ByteArrayAccess (Digest a)
forall a. Digest a -> Int
forall p. Digest a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. Digest a -> Ptr p -> IO ()
forall p a. Digest a -> (Ptr p -> IO a) -> IO a
forall a p a. Digest a -> (Ptr p -> IO a) -> IO a
$clength :: forall a. Digest a -> Int
length :: Digest a -> Int
$cwithByteArray :: forall a p a. Digest a -> (Ptr p -> IO a) -> IO a
withByteArray :: forall p a. Digest a -> (Ptr p -> IO a) -> IO a
$ccopyByteArrayToPtr :: forall a p. Digest a -> Ptr p -> IO ()
copyByteArrayToPtr :: forall p. Digest a -> Ptr p -> IO ()
ByteArrayAccess, Typeable (Digest a)
Typeable (Digest a) =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> Digest a -> c (Digest a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Digest a))
-> (Digest a -> Constr)
-> (Digest a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Digest a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Digest a)))
-> ((forall b. Data b => b -> b) -> Digest a -> Digest a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Digest a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Digest a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Digest a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Digest a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Digest a -> m (Digest a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Digest a -> m (Digest a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Digest a -> m (Digest a))
-> Data (Digest a)
Digest a -> Constr
Digest a -> DataType
(forall b. Data b => b -> b) -> Digest a -> Digest a
forall a. Data a => Typeable (Digest a)
forall a. Data a => Digest a -> Constr
forall a. Data a => Digest a -> DataType
forall a.
Data a =>
(forall b. Data b => b -> b) -> Digest a -> Digest a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Digest a -> u
forall a u.
Data a =>
(forall d. Data d => d -> u) -> Digest a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Digest a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Digest a -> c (Digest a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Digest a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Digest a))
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Digest a -> u
forall u. (forall d. Data d => d -> u) -> Digest a -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Digest a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Digest a -> c (Digest a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Digest a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Digest a))
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Digest a -> c (Digest a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Digest a -> c (Digest a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Digest a)
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Digest a)
$ctoConstr :: forall a. Data a => Digest a -> Constr
toConstr :: Digest a -> Constr
$cdataTypeOf :: forall a. Data a => Digest a -> DataType
dataTypeOf :: Digest a -> DataType
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Digest a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Digest a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Digest a))
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Digest a))
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Digest a -> Digest a
gmapT :: (forall b. Data b => b -> b) -> Digest a -> Digest a
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Digest a -> r
$cgmapQ :: forall a u.
Data a =>
(forall d. Data d => d -> u) -> Digest a -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Digest a -> [u]
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Digest a -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Digest a -> u
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Digest a -> m (Digest a)
Data)

type role Digest nominal

instance NFData (Digest a) where
    rnf :: Digest a -> ()
rnf (Digest Block Word8
u) = Block Word8
u Block Word8 -> () -> ()
forall a b. NormalForm a => a -> b -> b
`deepseq` ()

instance Show (Digest a) where
    show :: Digest a -> String
show (Digest Block Word8
bs) =
        (Word8 -> Char) -> [Word8] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ([Word8] -> String) -> [Word8] -> String
forall a b. (a -> b) -> a -> b
$
            Bytes -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
B.unpack (Base -> Block Word8 -> Bytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
B.convertToBase Base
B.Base16 Block Word8
bs :: Bytes)

instance HashAlgorithm a => Read (Digest a) where
    readsPrec :: Int -> ReadS (Digest a)
readsPrec Int
_ String
str = (forall s. ST s [(Digest a, String)]) -> [(Digest a, String)]
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s [(Digest a, String)]) -> [(Digest a, String)])
-> (forall s. ST s [(Digest a, String)]) -> [(Digest a, String)]
forall a b. (a -> b) -> a -> b
$ do
        MutableBlock Word8 s
mut <- CountOf Word8 -> ST s (MutableBlock Word8 (PrimState (ST s)))
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
CountOf ty -> prim (MutableBlock ty (PrimState prim))
new (Int -> CountOf Word8
forall ty. Int -> CountOf ty
CountOf Int
len)
        MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
forall s.
MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
loop MutableBlock Word8 s
mut Int
len String
str
      where
        len :: Int
len = a -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (a
forall a. HasCallStack => a
undefined :: a)

        loop :: MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
        loop :: forall s.
MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
loop MutableBlock Word8 s
mut Int
0 String
cs = (\Block Word8
b -> [(Block Word8 -> Digest a
forall a. Block Word8 -> Digest a
Digest Block Word8
b, String
cs)]) (Block Word8 -> [(Digest a, String)])
-> ST s (Block Word8) -> ST s [(Digest a, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableBlock Word8 (PrimState (ST s)) -> ST s (Block Word8)
forall (prim :: * -> *) ty.
PrimMonad prim =>
MutableBlock ty (PrimState prim) -> prim (Block ty)
unsafeFreeze MutableBlock Word8 s
MutableBlock Word8 (PrimState (ST s))
mut
        loop MutableBlock Word8 s
_ Int
_ [] = [(Digest a, String)] -> ST s [(Digest a, String)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        loop MutableBlock Word8 s
_ Int
_ [Char
_] = [(Digest a, String)] -> ST s [(Digest a, String)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        loop MutableBlock Word8 s
mut Int
n (Char
c : (Char
d : String
ds))
            | Bool -> Bool
not (Char -> Bool
isHexDigit Char
c) = [(Digest a, String)] -> ST s [(Digest a, String)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            | Bool -> Bool
not (Char -> Bool
isHexDigit Char
d) = [(Digest a, String)] -> ST s [(Digest a, String)]
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            | Bool
otherwise = do
                let w8 :: Word8
w8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
d
                MutableBlock Word8 (PrimState (ST s))
-> Offset Word8 -> Word8 -> ST s ()
forall (prim :: * -> *) ty.
(PrimMonad prim, PrimType ty) =>
MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()
unsafeWrite MutableBlock Word8 s
MutableBlock Word8 (PrimState (ST s))
mut (Int -> Offset Word8
forall ty. Int -> Offset ty
Offset (Int -> Offset Word8) -> Int -> Offset Word8
forall a b. (a -> b) -> a -> b
$ Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Word8
w8
                MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
forall s.
MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
loop MutableBlock Word8 s
mut (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
ds