{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE ForeignFunctionInterface   #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# CFILES raaz/hash/sha1/portable.c    #-}

-- | Internal types and function for blake2 hashes.
module Raaz.Hash.Blake2.Internal
       ( -- * The blake2 types
         BLAKE2, BLAKE2b, BLAKE2s
       , Blake2bMem, Blake2sMem
       , blake2Pad, blake2bImplementation
       , blake2sImplementation
       ) where

import           Control.Applicative
import           Control.Monad.IO.Class
import           Data.Bits           ( xor, complement )
import           Data.Monoid
import           Data.String
import           Data.Word
import           Foreign.Ptr         ( Ptr          )
import           Foreign.Storable    ( Storable(..) )
import           Prelude      hiding ( zipWith      )

import           Raaz.Core
import           Raaz.Core.Transfer
import           Raaz.Hash.Internal

----------------------------- The blake2 type ---------------------------------

-- | The BLAKE2 type.
newtype BLAKE2 w = BLAKE2 (Tuple 8 w)
               deriving (BLAKE2 w -> BLAKE2 w -> Bool
(BLAKE2 w -> BLAKE2 w -> Bool)
-> (BLAKE2 w -> BLAKE2 w -> Bool) -> Eq (BLAKE2 w)
forall w. (Unbox w, Equality w) => BLAKE2 w -> BLAKE2 w -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BLAKE2 w -> BLAKE2 w -> Bool
$c/= :: forall w. (Unbox w, Equality w) => BLAKE2 w -> BLAKE2 w -> Bool
== :: BLAKE2 w -> BLAKE2 w -> Bool
$c== :: forall w. (Unbox w, Equality w) => BLAKE2 w -> BLAKE2 w -> Bool
Eq, BLAKE2 w -> BLAKE2 w -> Result
(BLAKE2 w -> BLAKE2 w -> Result) -> Equality (BLAKE2 w)
forall w. (Unbox w, Equality w) => BLAKE2 w -> BLAKE2 w -> Result
forall a. (a -> a -> Result) -> Equality a
eq :: BLAKE2 w -> BLAKE2 w -> Result
$ceq :: forall w. (Unbox w, Equality w) => BLAKE2 w -> BLAKE2 w -> Result
Equality, Ptr b -> Int -> IO (BLAKE2 w)
Ptr b -> Int -> BLAKE2 w -> IO ()
Ptr (BLAKE2 w) -> IO (BLAKE2 w)
Ptr (BLAKE2 w) -> Int -> IO (BLAKE2 w)
Ptr (BLAKE2 w) -> Int -> BLAKE2 w -> IO ()
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
BLAKE2 w -> Int
(BLAKE2 w -> Int)
-> (BLAKE2 w -> Int)
-> (Ptr (BLAKE2 w) -> Int -> IO (BLAKE2 w))
-> (Ptr (BLAKE2 w) -> Int -> BLAKE2 w -> IO ())
-> (forall b. Ptr b -> Int -> IO (BLAKE2 w))
-> (forall b. Ptr b -> Int -> BLAKE2 w -> IO ())
-> (Ptr (BLAKE2 w) -> IO (BLAKE2 w))
-> (Ptr (BLAKE2 w) -> BLAKE2 w -> IO ())
-> Storable (BLAKE2 w)
forall b. Ptr b -> Int -> IO (BLAKE2 w)
forall b. Ptr b -> Int -> BLAKE2 w -> IO ()
forall w. (Unbox w, Storable w) => Ptr (BLAKE2 w) -> IO (BLAKE2 w)
forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> Int -> IO (BLAKE2 w)
forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> Int -> BLAKE2 w -> IO ()
forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
forall w. (Unbox w, Storable w) => BLAKE2 w -> Int
forall w b. (Unbox w, Storable w) => Ptr b -> Int -> IO (BLAKE2 w)
forall w b.
(Unbox w, Storable w) =>
Ptr b -> Int -> BLAKE2 w -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
poke :: Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
$cpoke :: forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
peek :: Ptr (BLAKE2 w) -> IO (BLAKE2 w)
$cpeek :: forall w. (Unbox w, Storable w) => Ptr (BLAKE2 w) -> IO (BLAKE2 w)
pokeByteOff :: Ptr b -> Int -> BLAKE2 w -> IO ()
$cpokeByteOff :: forall w b.
(Unbox w, Storable w) =>
Ptr b -> Int -> BLAKE2 w -> IO ()
peekByteOff :: Ptr b -> Int -> IO (BLAKE2 w)
$cpeekByteOff :: forall w b. (Unbox w, Storable w) => Ptr b -> Int -> IO (BLAKE2 w)
pokeElemOff :: Ptr (BLAKE2 w) -> Int -> BLAKE2 w -> IO ()
$cpokeElemOff :: forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> Int -> BLAKE2 w -> IO ()
peekElemOff :: Ptr (BLAKE2 w) -> Int -> IO (BLAKE2 w)
$cpeekElemOff :: forall w.
(Unbox w, Storable w) =>
Ptr (BLAKE2 w) -> Int -> IO (BLAKE2 w)
alignment :: BLAKE2 w -> Int
$calignment :: forall w. (Unbox w, Storable w) => BLAKE2 w -> Int
sizeOf :: BLAKE2 w -> Int
$csizeOf :: forall w. (Unbox w, Storable w) => BLAKE2 w -> Int
Storable, Storable (BLAKE2 w)
Ptr (BLAKE2 w) -> IO (BLAKE2 w)
Ptr (BLAKE2 w) -> Int -> IO ()
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
Storable (BLAKE2 w)
-> (Ptr (BLAKE2 w) -> BLAKE2 w -> IO ())
-> (Ptr (BLAKE2 w) -> IO (BLAKE2 w))
-> (Ptr (BLAKE2 w) -> Int -> IO ())
-> EndianStore (BLAKE2 w)
forall w.
Storable w
-> (Ptr w -> w -> IO ())
-> (Ptr w -> IO w)
-> (Ptr w -> Int -> IO ())
-> EndianStore w
forall w. (Unbox w, EndianStore w) => Storable (BLAKE2 w)
forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> IO (BLAKE2 w)
forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> Int -> IO ()
forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
adjustEndian :: Ptr (BLAKE2 w) -> Int -> IO ()
$cadjustEndian :: forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> Int -> IO ()
load :: Ptr (BLAKE2 w) -> IO (BLAKE2 w)
$cload :: forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> IO (BLAKE2 w)
store :: Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
$cstore :: forall w.
(Unbox w, EndianStore w) =>
Ptr (BLAKE2 w) -> BLAKE2 w -> IO ()
$cp1EndianStore :: forall w. (Unbox w, EndianStore w) => Storable (BLAKE2 w)
EndianStore)

-- | Word type for Blake2b
type Word2b = LE Word64

-- | Word type for Blake2s
type Word2s = LE Word32

-- | The BLAKE2b hash type.
type BLAKE2b = BLAKE2 Word2b

-- | The BLAKE2s hash type.
type BLAKE2s = BLAKE2 Word2s

instance Encodable BLAKE2b
instance Encodable BLAKE2s


instance IsString BLAKE2b where
  fromString :: String -> BLAKE2b
fromString = String -> BLAKE2b
forall a. Encodable a => String -> a
fromBase16

instance IsString BLAKE2s where
  fromString :: String -> BLAKE2s
fromString = String -> BLAKE2s
forall a. Encodable a => String -> a
fromBase16

instance Show BLAKE2b where
  show :: BLAKE2b -> String
show =  BLAKE2b -> String
forall a. Encodable a => a -> String
showBase16

instance Show BLAKE2s where
  show :: BLAKE2s -> String
show =  BLAKE2s -> String
forall a. Encodable a => a -> String
showBase16

instance Primitive BLAKE2b where
  blockSize :: BLAKE2b -> BYTES Int
blockSize BLAKE2b
_ = Int -> BYTES Int
forall a. a -> BYTES a
BYTES Int
128
  type Implementation BLAKE2b = SomeHashI BLAKE2b

instance Hash BLAKE2b where
  additionalPadBlocks :: BLAKE2b -> BLOCKS BLAKE2b
additionalPadBlocks BLAKE2b
_ = Int -> BLOCKS BLAKE2b
forall a. Enum a => Int -> a
toEnum Int
1

instance Primitive BLAKE2s where
  blockSize :: BLAKE2s -> BYTES Int
blockSize BLAKE2s
_ = Int -> BYTES Int
forall a. a -> BYTES a
BYTES Int
64
  type Implementation BLAKE2s = SomeHashI BLAKE2s

instance Hash BLAKE2s where
  additionalPadBlocks :: BLAKE2s -> BLOCKS BLAKE2s
additionalPadBlocks BLAKE2s
_ = Int -> BLOCKS BLAKE2s
forall a. Enum a => Int -> a
toEnum Int
1

-- | The initial value to start the blake2b hashing. This is equal to
-- the iv `xor` the parameter block.
hash2b0 :: BLAKE2b
hash2b0 :: BLAKE2b
hash2b0 = Tuple 8 Word2b -> BLAKE2b
forall w. Tuple 8 w -> BLAKE2 w
BLAKE2 (Tuple 8 Word2b -> BLAKE2b) -> Tuple 8 Word2b -> BLAKE2b
forall a b. (a -> b) -> a -> b
$ [Word2b] -> Tuple 8 Word2b
forall a (dim :: Nat).
(Unbox a, Dimension dim) =>
[a] -> Tuple dim a
unsafeFromList [ Word2b
0x6a09e667f3bcc908 Word2b -> Word2b -> Word2b
forall a. Bits a => a -> a -> a
`xor` Word2b
0x01010040
                                  , Word2b
0xbb67ae8584caa73b
                                  , Word2b
0x3c6ef372fe94f82b
                                  , Word2b
0xa54ff53a5f1d36f1
                                  , Word2b
0x510e527fade682d1
                                  , Word2b
0x9b05688c2b3e6c1f
                                  , Word2b
0x1f83d9abfb41bd6b
                                  , Word2b
0x5be0cd19137e2179
                                  ]

-- | The initial value to start the blake2b hashing. This is equal to
-- the iv `xor` the parameter block.
hash2s0 :: BLAKE2s
hash2s0 :: BLAKE2s
hash2s0 = Tuple 8 Word2s -> BLAKE2s
forall w. Tuple 8 w -> BLAKE2 w
BLAKE2 (Tuple 8 Word2s -> BLAKE2s) -> Tuple 8 Word2s -> BLAKE2s
forall a b. (a -> b) -> a -> b
$ [Word2s] -> Tuple 8 Word2s
forall a (dim :: Nat).
(Unbox a, Dimension dim) =>
[a] -> Tuple dim a
unsafeFromList [ Word2s
0x6a09e667 Word2s -> Word2s -> Word2s
forall a. Bits a => a -> a -> a
`xor` Word2s
0x01010020
                                  , Word2s
0xbb67ae85
                                  , Word2s
0x3c6ef372
                                  , Word2s
0xa54ff53a
                                  , Word2s
0x510e527f
                                  , Word2s
0x9b05688c
                                  , Word2s
0x1f83d9ab
                                  , Word2s
0x5be0cd19
                                  ]

---------------------------------- Memory element for BLAKE2b -----------------------

-- | Memory element for BLAKE2b implementations.
data Blake2bMem = Blake2bMem { Blake2bMem -> MemoryCell BLAKE2b
blake2bCell :: MemoryCell BLAKE2b
                             , Blake2bMem -> MemoryCell (BYTES Word64)
uLengthCell :: MemoryCell (BYTES Word64)
                             , Blake2bMem -> MemoryCell (BYTES Word64)
lLengthCell :: MemoryCell (BYTES Word64)
                             }


instance Memory Blake2bMem where
  memoryAlloc :: Alloc Blake2bMem
memoryAlloc     = MemoryCell BLAKE2b
-> MemoryCell (BYTES Word64)
-> MemoryCell (BYTES Word64)
-> Blake2bMem
Blake2bMem (MemoryCell BLAKE2b
 -> MemoryCell (BYTES Word64)
 -> MemoryCell (BYTES Word64)
 -> Blake2bMem)
-> TwistRF AllocField (BYTES Int) (MemoryCell BLAKE2b)
-> TwistRF
     AllocField
     (BYTES Int)
     (MemoryCell (BYTES Word64)
      -> MemoryCell (BYTES Word64) -> Blake2bMem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) (MemoryCell BLAKE2b)
forall m. Memory m => Alloc m
memoryAlloc TwistRF
  AllocField
  (BYTES Int)
  (MemoryCell (BYTES Word64)
   -> MemoryCell (BYTES Word64) -> Blake2bMem)
-> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
-> TwistRF
     AllocField (BYTES Int) (MemoryCell (BYTES Word64) -> Blake2bMem)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
forall m. Memory m => Alloc m
memoryAlloc TwistRF
  AllocField (BYTES Int) (MemoryCell (BYTES Word64) -> Blake2bMem)
-> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
-> Alloc Blake2bMem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
forall m. Memory m => Alloc m
memoryAlloc
  unsafeToPointer :: Blake2bMem -> Pointer
unsafeToPointer = MemoryCell BLAKE2b -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer (MemoryCell BLAKE2b -> Pointer)
-> (Blake2bMem -> MemoryCell BLAKE2b) -> Blake2bMem -> Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blake2bMem -> MemoryCell BLAKE2b
blake2bCell

instance Initialisable Blake2bMem () where
  initialise :: () -> MT Blake2bMem ()
initialise ()
_ = do (Blake2bMem -> MemoryCell BLAKE2b)
-> MT (MemoryCell BLAKE2b) () -> MT Blake2bMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell BLAKE2b
blake2bCell  (MT (MemoryCell BLAKE2b) () -> MT Blake2bMem ())
-> MT (MemoryCell BLAKE2b) () -> MT Blake2bMem ()
forall a b. (a -> b) -> a -> b
$ BLAKE2b -> MT (MemoryCell BLAKE2b) ()
forall m v. Initialisable m v => v -> MT m ()
initialise BLAKE2b
hash2b0
                    (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
uLengthCell  (MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ())
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ()
forall a b. (a -> b) -> a -> b
$ BYTES Word64 -> MT (MemoryCell (BYTES Word64)) ()
forall m v. Initialisable m v => v -> MT m ()
initialise (BYTES Word64
0 :: BYTES Word64)
                    (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
lLengthCell  (MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ())
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2bMem ()
forall a b. (a -> b) -> a -> b
$ BYTES Word64 -> MT (MemoryCell (BYTES Word64)) ()
forall m v. Initialisable m v => v -> MT m ()
initialise (BYTES Word64
0 :: BYTES Word64)

instance Extractable Blake2bMem BLAKE2b where
  extract :: MT Blake2bMem BLAKE2b
extract = (Blake2bMem -> MemoryCell BLAKE2b)
-> MT (MemoryCell BLAKE2b) BLAKE2b -> MT Blake2bMem BLAKE2b
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell BLAKE2b
blake2bCell MT (MemoryCell BLAKE2b) BLAKE2b
forall m v. Extractable m v => MT m v
extract

---------------------------------- Memory element for BLAKE2b -----------------------

-- | Memory element for BLAKE2s implementations.
data Blake2sMem = Blake2sMem { Blake2sMem -> MemoryCell BLAKE2s
blake2sCell :: MemoryCell BLAKE2s
                             , Blake2sMem -> MemoryCell (BYTES Word64)
lengthCell  :: MemoryCell (BYTES Word64)
                             }

instance Memory Blake2sMem where
  memoryAlloc :: Alloc Blake2sMem
memoryAlloc     = MemoryCell BLAKE2s -> MemoryCell (BYTES Word64) -> Blake2sMem
Blake2sMem (MemoryCell BLAKE2s -> MemoryCell (BYTES Word64) -> Blake2sMem)
-> TwistRF AllocField (BYTES Int) (MemoryCell BLAKE2s)
-> TwistRF
     AllocField (BYTES Int) (MemoryCell (BYTES Word64) -> Blake2sMem)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) (MemoryCell BLAKE2s)
forall m. Memory m => Alloc m
memoryAlloc TwistRF
  AllocField (BYTES Int) (MemoryCell (BYTES Word64) -> Blake2sMem)
-> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
-> Alloc Blake2sMem
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) (MemoryCell (BYTES Word64))
forall m. Memory m => Alloc m
memoryAlloc
  unsafeToPointer :: Blake2sMem -> Pointer
unsafeToPointer = MemoryCell BLAKE2s -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer (MemoryCell BLAKE2s -> Pointer)
-> (Blake2sMem -> MemoryCell BLAKE2s) -> Blake2sMem -> Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blake2sMem -> MemoryCell BLAKE2s
blake2sCell

instance Initialisable Blake2sMem () where
  initialise :: () -> MT Blake2sMem ()
initialise ()
_ = do (Blake2sMem -> MemoryCell BLAKE2s)
-> MT (MemoryCell BLAKE2s) () -> MT Blake2sMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell BLAKE2s
blake2sCell (MT (MemoryCell BLAKE2s) () -> MT Blake2sMem ())
-> MT (MemoryCell BLAKE2s) () -> MT Blake2sMem ()
forall a b. (a -> b) -> a -> b
$ BLAKE2s -> MT (MemoryCell BLAKE2s) ()
forall m v. Initialisable m v => v -> MT m ()
initialise BLAKE2s
hash2s0
                    (Blake2sMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell (BYTES Word64)
lengthCell  (MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ())
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ()
forall a b. (a -> b) -> a -> b
$ BYTES Word64 -> MT (MemoryCell (BYTES Word64)) ()
forall m v. Initialisable m v => v -> MT m ()
initialise (BYTES Word64
0 :: BYTES Word64)

instance Extractable Blake2sMem BLAKE2s where
  extract :: MT Blake2sMem BLAKE2s
extract = (Blake2sMem -> MemoryCell BLAKE2s)
-> MT (MemoryCell BLAKE2s) BLAKE2s -> MT Blake2sMem BLAKE2s
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell BLAKE2s
blake2sCell MT (MemoryCell BLAKE2s) BLAKE2s
forall m v. Extractable m v => MT m v
extract

----------------------- Padding for Blake code ------------------------------

-- | The generic blake2 padding algorithm.
blake2Pad :: (Primitive prim, MonadIO m)
          => prim      -- ^ the primitive (BLAKE2b or BLAKE2s).
          -> BYTES Int -- ^ length of the message
          -> WriteM m
blake2Pad :: prim -> BYTES Int -> WriteM m
blake2Pad prim
prim = Word8 -> BLOCKS prim -> WriteM m -> WriteM m
forall n (m :: * -> *).
(LengthUnit n, MonadIO m) =>
Word8 -> n -> WriteM m -> WriteM m
padWrite Word8
0 (Int -> prim -> BLOCKS prim
forall p. Int -> p -> BLOCKS p
blocksOf Int
1 prim
prim) (WriteM m -> WriteM m)
-> (BYTES Int -> WriteM m) -> BYTES Int -> WriteM m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BYTES Int -> WriteM m
forall u (m :: * -> *). (LengthUnit u, Monad m) => u -> WriteM m
skipWrite



----------------------- Create a blake2b implementation ---------------------
type Compress2b =  Pointer            -- ^ Buffer
                -> BLOCKS BLAKE2b     -- ^ number of blocks
                -> Ptr (BYTES Word64) -- ^ Upper count
                -> Ptr (BYTES Word64) -- ^ Lower
                -> Ptr BLAKE2b
                -> IO ()

type Last2b =  Pointer
            -> BYTES Int
            -> BYTES Word64 -- Upper
            -> BYTES Word64 -- Lower
            -> Word64       -- f0
            -> Word64       -- f1
            -> Ptr BLAKE2b
            -> IO ()


-- | Create a hash implementation form BLAKE2b given a compression
-- function and the last block function.
blake2bImplementation :: String  -- ^ Name
                      -> String  -- ^ Description
                      -> Compress2b
                      -> Last2b
                      -> HashI BLAKE2b Blake2bMem
blake2bImplementation :: String
-> String -> Compress2b -> Last2b -> HashI BLAKE2b Blake2bMem
blake2bImplementation String
nm String
descr Compress2b
compress2b Last2b
last2b
  = HashI :: forall h m.
String
-> String
-> (Pointer -> BLOCKS h -> MT m ())
-> (Pointer -> BYTES Int -> MT m ())
-> Alignment
-> HashI h m
HashI { hashIName :: String
hashIName              = String
nm
          , hashIDescription :: String
hashIDescription       = String
descr
          , compress :: Pointer -> BLOCKS BLAKE2b -> MT Blake2bMem ()
compress               = Pointer -> BLOCKS BLAKE2b -> MT Blake2bMem ()
comp
          , compressFinal :: Pointer -> BYTES Int -> MT Blake2bMem ()
compressFinal          = Pointer -> BYTES Int -> MT Blake2bMem ()
final
          , compressStartAlignment :: Alignment
compressStartAlignment = Alignment
32  --  Allow gcc to use vector instructions
          }
  where comp :: Pointer -> BLOCKS BLAKE2b -> MT Blake2bMem ()
comp Pointer
buf BLOCKS BLAKE2b
blks = do Ptr (BYTES Word64)
uPtr   <- (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (Ptr (BYTES Word64))
-> MT Blake2bMem (Ptr (BYTES Word64))
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
uLengthCell MT (MemoryCell (BYTES Word64)) (Ptr (BYTES Word64))
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                           Ptr (BYTES Word64)
lPtr   <- (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (Ptr (BYTES Word64))
-> MT Blake2bMem (Ptr (BYTES Word64))
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
lLengthCell MT (MemoryCell (BYTES Word64)) (Ptr (BYTES Word64))
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                           Ptr BLAKE2b
hshPtr <- (Blake2bMem -> MemoryCell BLAKE2b)
-> MT (MemoryCell BLAKE2b) (Ptr BLAKE2b)
-> MT Blake2bMem (Ptr BLAKE2b)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell BLAKE2b
blake2bCell MT (MemoryCell BLAKE2b) (Ptr BLAKE2b)
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                           IO () -> MT Blake2bMem ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MT Blake2bMem ()) -> IO () -> MT Blake2bMem ()
forall a b. (a -> b) -> a -> b
$ Compress2b
compress2b Pointer
buf BLOCKS BLAKE2b
blks Ptr (BYTES Word64)
uPtr Ptr (BYTES Word64)
lPtr Ptr BLAKE2b
hshPtr

        lastBlock :: Pointer -> BYTES Int -> MT Blake2bMem ()
lastBlock Pointer
buf BYTES Int
r = do BYTES Word64
u      <- (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (BYTES Word64)
-> MT Blake2bMem (BYTES Word64)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
uLengthCell MT (MemoryCell (BYTES Word64)) (BYTES Word64)
forall m v. Extractable m v => MT m v
extract
                             BYTES Word64
l      <- (Blake2bMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (BYTES Word64)
-> MT Blake2bMem (BYTES Word64)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell (BYTES Word64)
lLengthCell MT (MemoryCell (BYTES Word64)) (BYTES Word64)
forall m v. Extractable m v => MT m v
extract
                             Ptr BLAKE2b
hshPtr <- (Blake2bMem -> MemoryCell BLAKE2b)
-> MT (MemoryCell BLAKE2b) (Ptr BLAKE2b)
-> MT Blake2bMem (Ptr BLAKE2b)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2bMem -> MemoryCell BLAKE2b
blake2bCell MT (MemoryCell BLAKE2b) (Ptr BLAKE2b)
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                             let f0 :: Word64
f0 = Word64 -> Word64
forall a. Bits a => a -> a
complement Word64
0
                                 f1 :: Word64
f1 = Word64
0
                               in  IO () -> MT Blake2bMem ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MT Blake2bMem ()) -> IO () -> MT Blake2bMem ()
forall a b. (a -> b) -> a -> b
$ Last2b
last2b Pointer
buf BYTES Int
r BYTES Word64
u BYTES Word64
l Word64
f0 Word64
f1 Ptr BLAKE2b
hshPtr

        final :: Pointer -> BYTES Int -> MT Blake2bMem ()
final Pointer
buf BYTES Int
nbytes = WriteM (MT Blake2bMem) -> Pointer -> MT Blake2bMem ()
forall (m :: * -> *). WriteM m -> Pointer -> m ()
unsafeWrite WriteM (MT Blake2bMem)
blake2bPad Pointer
buf MT Blake2bMem () -> MT Blake2bMem () -> MT Blake2bMem ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pointer -> BYTES Int -> MT Blake2bMem ()
finalPadded Pointer
buf BYTES Int
nbytes
          where blake2bPad :: WriteM (MT Blake2bMem)
blake2bPad = BLAKE2b -> BYTES Int -> WriteM (MT Blake2bMem)
forall prim (m :: * -> *).
(Primitive prim, MonadIO m) =>
prim -> BYTES Int -> WriteM m
blake2Pad (BLAKE2b
forall a. HasCallStack => a
undefined :: BLAKE2b) BYTES Int
nbytes

        finalPadded :: Pointer -> BYTES Int -> MT Blake2bMem ()
finalPadded Pointer
buf BYTES Int
nbytes
          | BYTES Int
nbytes BYTES Int -> BYTES Int -> Bool
forall a. Eq a => a -> a -> Bool
== BYTES Int
0 = Pointer -> BYTES Int -> MT Blake2bMem ()
lastBlock Pointer
buf BYTES Int
0  -- only when actual input is empty.
          | Bool
otherwise   = let
              (BLOCKS BLAKE2b
blks,BYTES Int
r)       =  BYTES Int -> (BLOCKS BLAKE2b, BYTES Int)
forall u. LengthUnit u => BYTES Int -> (u, BYTES Int)
bytesQuotRem BYTES Int
nbytes
              blksToCompress :: BLOCKS BLAKE2b
blksToCompress = if BYTES Int
r BYTES Int -> BYTES Int -> Bool
forall a. Eq a => a -> a -> Bool
== BYTES Int
0 then BLOCKS BLAKE2b
blks BLOCKS BLAKE2b -> BLOCKS BLAKE2b -> BLOCKS BLAKE2b
forall a. Semigroup a => a -> a -> a
<> Int -> BLOCKS BLAKE2b
forall a. Enum a => Int -> a
toEnum (-Int
1) else BLOCKS BLAKE2b
blks
              remBytes :: BYTES Int
remBytes       = if BYTES Int
r BYTES Int -> BYTES Int -> Bool
forall a. Ord a => a -> a -> Bool
> BYTES Int
0 then BYTES Int
r else BLOCKS BLAKE2b -> BYTES Int
forall u. LengthUnit u => u -> BYTES Int
inBytes (BLOCKS BLAKE2b -> BYTES Int) -> BLOCKS BLAKE2b -> BYTES Int
forall a b. (a -> b) -> a -> b
$ Int -> BLAKE2b -> BLOCKS BLAKE2b
forall p. Int -> p -> BLOCKS p
blocksOf Int
1 (BLAKE2b
forall a. HasCallStack => a
undefined :: BLAKE2b)
              lastBlockPtr :: Pointer
lastBlockPtr   = Pointer
buf Pointer -> BLOCKS BLAKE2b -> Pointer
forall l a. LengthUnit l => Ptr a -> l -> Ptr a
`movePtr` BLOCKS BLAKE2b
blksToCompress
              in do Pointer -> BLOCKS BLAKE2b -> MT Blake2bMem ()
comp Pointer
buf BLOCKS BLAKE2b
blksToCompress
                    Pointer -> BYTES Int -> MT Blake2bMem ()
lastBlock Pointer
lastBlockPtr BYTES Int
remBytes

------------------------- Implementations of blake2s ---------------------------------------------

type Compress2s =  Pointer            -- ^ Buffer
                -> BLOCKS BLAKE2s     -- ^ number of blocks
                -> BYTES Word64       -- ^ length of the message so far
                -> Ptr BLAKE2s        -- ^ Hash pointer
                -> IO ()

type Last2s =  Pointer
            -> BYTES Int
            -> BYTES Word64
            -> Word32       -- f0
            -> Word32       -- f1
            -> Ptr BLAKE2s
            -> IO ()

-- | Create a hash implementation form BLAKE2s given a compression
-- function and the last block function.
blake2sImplementation :: String  -- ^ Name
                      -> String  -- ^ Description
                      -> Compress2s
                      -> Last2s
                      -> HashI BLAKE2s Blake2sMem
blake2sImplementation :: String
-> String -> Compress2s -> Last2s -> HashI BLAKE2s Blake2sMem
blake2sImplementation String
nm String
descr Compress2s
compress2s Last2s
last2s
  = HashI :: forall h m.
String
-> String
-> (Pointer -> BLOCKS h -> MT m ())
-> (Pointer -> BYTES Int -> MT m ())
-> Alignment
-> HashI h m
HashI { hashIName :: String
hashIName              = String
nm
          , hashIDescription :: String
hashIDescription       = String
descr
          , compress :: Pointer -> BLOCKS BLAKE2s -> MT Blake2sMem ()
compress               = Pointer -> BLOCKS BLAKE2s -> MT Blake2sMem ()
comp
          , compressFinal :: Pointer -> BYTES Int -> MT Blake2sMem ()
compressFinal          = Pointer -> BYTES Int -> MT Blake2sMem ()
final
          , compressStartAlignment :: Alignment
compressStartAlignment = Alignment
32  --  Allow gcc to use vector instructions
          }
  where comp :: Pointer -> BLOCKS BLAKE2s -> MT Blake2sMem ()
comp Pointer
buf BLOCKS BLAKE2s
blks = do BYTES Word64
len    <- (Blake2sMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (BYTES Word64)
-> MT Blake2sMem (BYTES Word64)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell (BYTES Word64)
lengthCell  MT (MemoryCell (BYTES Word64)) (BYTES Word64)
forall m v. Extractable m v => MT m v
extract    -- extract current length

                           Ptr BLAKE2s
hshPtr <- (Blake2sMem -> MemoryCell BLAKE2s)
-> MT (MemoryCell BLAKE2s) (Ptr BLAKE2s)
-> MT Blake2sMem (Ptr BLAKE2s)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell BLAKE2s
blake2sCell MT (MemoryCell BLAKE2s) (Ptr BLAKE2s)
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                           IO () -> MT Blake2sMem ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MT Blake2sMem ()) -> IO () -> MT Blake2sMem ()
forall a b. (a -> b) -> a -> b
$ Compress2s
compress2s Pointer
buf BLOCKS BLAKE2s
blks BYTES Word64
len Ptr BLAKE2s
hshPtr

                           let increment :: BYTES Word64
                               increment :: BYTES Word64
increment = BYTES Int -> BYTES Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BYTES Int -> BYTES Word64) -> BYTES Int -> BYTES Word64
forall a b. (a -> b) -> a -> b
$ BLOCKS BLAKE2s -> BYTES Int
forall u. LengthUnit u => u -> BYTES Int
inBytes BLOCKS BLAKE2s
blks -- update the length by blks
                               in (Blake2sMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell (BYTES Word64)
lengthCell (MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ())
-> MT (MemoryCell (BYTES Word64)) () -> MT Blake2sMem ()
forall a b. (a -> b) -> a -> b
$ (BYTES Word64 -> BYTES Word64) -> MT (MemoryCell (BYTES Word64)) ()
forall mem a b (mT :: * -> * -> *).
(Initialisable mem a, Extractable mem b, MemoryThread mT) =>
(b -> a) -> mT mem ()
modify (BYTES Word64 -> BYTES Word64 -> BYTES Word64
forall a. Num a => a -> a -> a
+BYTES Word64
increment)


        lastBlock :: Pointer -> BYTES Int -> MT Blake2sMem ()
lastBlock Pointer
buf BYTES Int
r = do BYTES Word64
len    <- (Blake2sMem -> MemoryCell (BYTES Word64))
-> MT (MemoryCell (BYTES Word64)) (BYTES Word64)
-> MT Blake2sMem (BYTES Word64)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell (BYTES Word64)
lengthCell MT (MemoryCell (BYTES Word64)) (BYTES Word64)
forall m v. Extractable m v => MT m v
extract
                             Ptr BLAKE2s
hshPtr <- (Blake2sMem -> MemoryCell BLAKE2s)
-> MT (MemoryCell BLAKE2s) (Ptr BLAKE2s)
-> MT Blake2sMem (Ptr BLAKE2s)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory Blake2sMem -> MemoryCell BLAKE2s
blake2sCell MT (MemoryCell BLAKE2s) (Ptr BLAKE2s)
forall (mT :: * -> * -> *) a.
(MemoryThread mT, Storable a) =>
mT (MemoryCell a) (Ptr a)
getCellPointer
                             let f0 :: Word32
f0 = Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
0
                                 f1 :: Word32
f1 = Word32
0
                               in IO () -> MT Blake2sMem ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MT Blake2sMem ()) -> IO () -> MT Blake2sMem ()
forall a b. (a -> b) -> a -> b
$ Last2s
last2s Pointer
buf BYTES Int
r BYTES Word64
len Word32
f0 Word32
f1 Ptr BLAKE2s
hshPtr

        final :: Pointer -> BYTES Int -> MT Blake2sMem ()
final Pointer
buf BYTES Int
nbytes = WriteM (MT Blake2sMem) -> Pointer -> MT Blake2sMem ()
forall (m :: * -> *). WriteM m -> Pointer -> m ()
unsafeWrite WriteM (MT Blake2sMem)
blake2sPad Pointer
buf MT Blake2sMem () -> MT Blake2sMem () -> MT Blake2sMem ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pointer -> BYTES Int -> MT Blake2sMem ()
finalPadded Pointer
buf BYTES Int
nbytes
          where blake2sPad :: WriteM (MT Blake2sMem)
blake2sPad = BLAKE2s -> BYTES Int -> WriteM (MT Blake2sMem)
forall prim (m :: * -> *).
(Primitive prim, MonadIO m) =>
prim -> BYTES Int -> WriteM m
blake2Pad (BLAKE2s
forall a. HasCallStack => a
undefined :: BLAKE2s) BYTES Int
nbytes

        finalPadded :: Pointer -> BYTES Int -> MT Blake2sMem ()
finalPadded Pointer
buf BYTES Int
nbytes
          | BYTES Int
nbytes BYTES Int -> BYTES Int -> Bool
forall a. Eq a => a -> a -> Bool
== BYTES Int
0 = Pointer -> BYTES Int -> MT Blake2sMem ()
lastBlock Pointer
buf BYTES Int
0  -- only when actual input is empty.
          | Bool
otherwise   = let
              (BLOCKS BLAKE2s
blks,BYTES Int
r)       =  BYTES Int -> (BLOCKS BLAKE2s, BYTES Int)
forall u. LengthUnit u => BYTES Int -> (u, BYTES Int)
bytesQuotRem BYTES Int
nbytes
              blksToCompress :: BLOCKS BLAKE2s
blksToCompress = if BYTES Int
r BYTES Int -> BYTES Int -> Bool
forall a. Eq a => a -> a -> Bool
== BYTES Int
0 then BLOCKS BLAKE2s
blks BLOCKS BLAKE2s -> BLOCKS BLAKE2s -> BLOCKS BLAKE2s
forall a. Semigroup a => a -> a -> a
<> Int -> BLOCKS BLAKE2s
forall a. Enum a => Int -> a
toEnum (-Int
1) else BLOCKS BLAKE2s
blks
              remBytes :: BYTES Int
remBytes       = if BYTES Int
r BYTES Int -> BYTES Int -> Bool
forall a. Ord a => a -> a -> Bool
> BYTES Int
0 then BYTES Int
r else BLOCKS BLAKE2s -> BYTES Int
forall u. LengthUnit u => u -> BYTES Int
inBytes (BLOCKS BLAKE2s -> BYTES Int) -> BLOCKS BLAKE2s -> BYTES Int
forall a b. (a -> b) -> a -> b
$ Int -> BLAKE2s -> BLOCKS BLAKE2s
forall p. Int -> p -> BLOCKS p
blocksOf Int
1 (BLAKE2s
forall a. HasCallStack => a
undefined :: BLAKE2s)
              lastBlockPtr :: Pointer
lastBlockPtr   = Pointer
buf Pointer -> BLOCKS BLAKE2s -> Pointer
forall l a. LengthUnit l => Ptr a -> l -> Ptr a
`movePtr` BLOCKS BLAKE2s
blksToCompress
              in do Pointer -> BLOCKS BLAKE2s -> MT Blake2sMem ()
comp Pointer
buf BLOCKS BLAKE2s
blksToCompress
                    Pointer -> BYTES Int -> MT Blake2sMem ()
lastBlock Pointer
lastBlockPtr BYTES Int
remBytes