{-# 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 Control.DeepSeq (deepseq)
import Control.Monad.Primitive (PrimMonad (..))
import Control.Monad.ST
import Crypto.Internal.ByteArray (ByteArrayAccess (..), Bytes)
import qualified Crypto.Internal.ByteArray as B
import Crypto.Internal.Imports
import Data.Base16.Types (extractBase16)
import Data.ByteString (ByteString)
import Data.ByteString.Base16 (encodeBase16)
import Data.Char (digitToInt, isHexDigit)
import Data.Data (Data)
import Data.Primitive.ByteArray (
    ByteArray,
    MutableByteArray,
    newPinnedByteArray,
    sizeofByteArray,
    unsafeFreezeByteArray,
    withByteArrayContents,
    writeByteArray,
 )
import qualified Data.Text as Text
import Foreign.Ptr (Ptr, castPtr)
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/ram ram>.
-- 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 ByteArray
    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, 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 ByteArray
u) = ByteArray
u ByteArray -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

instance ByteArrayAccess (Digest a) where
    length :: Digest a -> Int
length (Digest ByteArray
ba) = ByteArray -> Int
sizeofByteArray ByteArray
ba
    withByteArray :: forall p a. Digest a -> (Ptr p -> IO a) -> IO a
withByteArray (Digest ByteArray
ba) Ptr p -> IO a
f = ByteArray -> (Ptr Word8 -> IO a) -> IO a
forall (m :: * -> *) a.
PrimBase m =>
ByteArray -> (Ptr Word8 -> m a) -> m a
withByteArrayContents ByteArray
ba (Ptr p -> IO a
f (Ptr p -> IO a) -> (Ptr Word8 -> Ptr p) -> Ptr Word8 -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr p
forall a b. Ptr a -> Ptr b
castPtr)

instance Show (Digest a) where
    show :: Digest a -> String
show Digest a
d =
        Text -> String
Text.unpack (Base16 Text -> Text
forall a. Base16 a -> a
extractBase16 (Base16 Text -> Text) -> Base16 Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Base16 Text
encodeBase16 (Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
B.convert Digest a
d :: ByteString))

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
        mut <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
len
        loop len mut len str
      where
        len :: Int
len = a -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (a
forall a. HasCallStack => a
undefined :: a)

loop
    :: Int
    -> MutableByteArray (PrimState (ST s))
    -> Int
    -> String
    -> ST s [(Digest a, String)]
loop :: forall s a.
Int
-> MutableByteArray (PrimState (ST s))
-> Int
-> String
-> ST s [(Digest a, String)]
loop Int
_ MutableByteArray (PrimState (ST s))
mut Int
0 String
cs = (\ByteArray
b -> [(ByteArray -> Digest a
forall a. ByteArray -> Digest a
Digest ByteArray
b, String
cs)]) (ByteArray -> [(Digest a, String)])
-> ST s ByteArray -> ST s [(Digest a, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray (PrimState (ST s)) -> ST s ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray (PrimState (ST s))
mut
loop Int
_ MutableByteArray (PrimState (ST 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 Int
_ MutableByteArray (PrimState (ST 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 Int
len MutableByteArray (PrimState (ST 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 :: 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
        MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray (PrimState (ST s))
mut (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Word8
w8
        Int
-> MutableByteArray (PrimState (ST s))
-> Int
-> String
-> ST s [(Digest a, String)]
forall s a.
Int
-> MutableByteArray (PrimState (ST s))
-> Int
-> String
-> ST s [(Digest a, String)]
loop Int
len MutableByteArray (PrimState (ST s))
mut (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) String
ds