{-# LANGUAGE BangPatterns, MonomorphismRestriction #-}
module Crypto.Random.DRBG.Hash
        ( State, counter
        , reseedInterval
        , SeedLength (..)
        , instantiate
        , reseed
        , generate
        ) where
-- NIST SP 800-90 

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Crypto.Random.DRBG.Types
import Crypto.Random.DRBG.HashDF
import Crypto.Classes
import Data.Serialize (encode)
import Data.Bits (shiftR, shiftL)
import Data.Tagged
import Data.Word (Word64)

class SeedLength h where
  seedlen :: Tagged h Int

reseedInterval :: Word64
reseedInterval :: Word64
reseedInterval = 2Word64 -> Integer -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^48

-- Section 10.1.1.1, pg 35
data State d = St
        { State d -> Word64
counter               :: {-# UNPACK #-} !Word64       -- Number of RBG requests since last reseed
        -- start admin info
        , State d -> ByteString
value                 :: B.ByteString -- seedlen bits
        , State d -> ByteString
constant              :: B.ByteString -- seedlen bits
        , State d -> ByteString -> d
hsh                   :: L.ByteString -> d
        }

-- section 10.1.1.2 pg 36
instantiate :: (Hash c d, SeedLength d) => Entropy -> Nonce -> PersonalizationString -> State d
instantiate :: ByteString -> ByteString -> ByteString -> State d
instantiate entropyInput :: ByteString
entropyInput nonce :: ByteString
nonce perStr :: ByteString
perStr =
        let seedMaterial :: ByteString
seedMaterial = [ByteString] -> ByteString
B.concat [ByteString
entropyInput, ByteString
nonce, ByteString
perStr]
            slen :: Int
slen = Tagged d Int
forall h. SeedLength h => Tagged h Int
seedlen Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
.::. d
d
            seed :: ByteString
seed = (ByteString -> d) -> ByteString -> Int -> ByteString
forall c d.
Hash c d =>
(ByteString -> d) -> ByteString -> Int -> ByteString
hash_df ByteString -> d
f ByteString
seedMaterial Int
slen
            v :: ByteString
v = ByteString
seed
            c :: ByteString
c = (ByteString -> d) -> ByteString -> Int -> ByteString
forall c d.
Hash c d =>
(ByteString -> d) -> ByteString -> Int -> ByteString
hash_df ByteString -> d
f (Word8 -> ByteString -> ByteString
B.cons 0 ByteString
v) Int
slen
            f :: ByteString -> d
f = ByteString -> d
forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
hash
            d :: d
d = ByteString -> d
f ByteString
forall a. HasCallStack => a
undefined
        in Word64 -> ByteString -> ByteString -> (ByteString -> d) -> State d
forall d.
Word64 -> ByteString -> ByteString -> (ByteString -> d) -> State d
St 1 ByteString
v ByteString
c ByteString -> d
f

-- section 10.1.1.3 pg 37
reseed :: (SeedLength d, Hash c d) => State d -> Entropy -> AdditionalInput -> State d
reseed :: State d -> ByteString -> ByteString -> State d
reseed st :: State d
st ent :: ByteString
ent additionalInput :: ByteString
additionalInput =
        let seedMaterial :: ByteString
seedMaterial = [ByteString] -> ByteString
B.concat [[Word8] -> ByteString
B.pack [1], State d -> ByteString
forall d. State d -> ByteString
value State d
st, ByteString
ent, ByteString
additionalInput]
            seed :: ByteString
seed = (ByteString -> d) -> ByteString -> Int -> ByteString
forall c d.
Hash c d =>
(ByteString -> d) -> ByteString -> Int -> ByteString
hash_df ByteString -> d
f ByteString
seedMaterial (Tagged d Int
forall h. SeedLength h => Tagged h Int
seedlen Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
`for` d
d)
            v :: ByteString
v = ByteString
seed
            c :: ByteString
c = (ByteString -> d) -> ByteString -> Int -> ByteString
forall c d.
Hash c d =>
(ByteString -> d) -> ByteString -> Int -> ByteString
hash_df ByteString -> d
f (Word8 -> ByteString -> ByteString
B.cons 0 ByteString
v) (Tagged d Int
forall h. SeedLength h => Tagged h Int
seedlen Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
`for` d
d)
            f :: ByteString -> d
f = ByteString -> d
forall ctx d. (Hash ctx d, Hash ctx d) => ByteString -> d
hash
            d :: d
d = ByteString -> d
f ByteString
forall a. HasCallStack => a
undefined
        in Word64 -> ByteString -> ByteString -> (ByteString -> d) -> State d
forall d.
Word64 -> ByteString -> ByteString -> (ByteString -> d) -> State d
St 1 ByteString
v ByteString
c ByteString -> d
f

-- section 10.1.1.4 pg 38
-- Nothing indicates a need to reseed
generate :: (Hash c d, SeedLength d) => State d -> BitLen -> AdditionalInput -> Maybe (RandomBits, State d)
generate :: State d -> Int -> ByteString -> Maybe (ByteString, State d)
generate st :: State d
st req :: Int
req additionalInput :: ByteString
additionalInput =
        if (State d -> Word64
forall d. State d -> Word64
counter State d
st Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
reseedInterval)
                then Maybe (ByteString, State d)
forall a. Maybe a
Nothing
                else (ByteString, State d) -> Maybe (ByteString, State d)
forall a. a -> Maybe a
Just (ByteString
retBits, State d
st { value :: ByteString
value = ByteString
v2, counter :: Word64
counter = Word64
cnt})
  where
  w :: ByteString
w = [ByteString] -> ByteString
hash [Word8 -> ByteString
B.singleton 2, State d -> ByteString
forall d. State d -> ByteString
value State d
st, ByteString
additionalInput]
  v1 :: ByteString
v1 = if ByteString -> Int
B.length ByteString
additionalInput Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then State d -> ByteString
forall d. State d -> ByteString
value State d
st else Int -> Integer -> ByteString
i2bs Int
slen (ByteString -> Integer
bs2i (State d -> ByteString
forall d. State d -> ByteString
value State d
st) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ ByteString -> Integer
bs2i ByteString
w)
  retBits :: ByteString
retBits = d -> Int -> ByteString -> ByteString
forall c d.
(Hash c d, SeedLength d) =>
d -> Int -> ByteString -> ByteString
hashGen d
d Int
req ByteString
v1
  h :: ByteString
h = [ByteString] -> ByteString
hash [Word8 -> ByteString -> ByteString
B.cons 3 ByteString
v1]
  -- TODO determine if Integer is needed here and move to Word64 if possible
  v2 :: ByteString
v2 = Int -> Integer -> ByteString
i2bs Int
slen ([Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer) -> [Integer] -> Integer
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (State d -> Word64
forall d. State d -> Word64
counter State d
st) Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: (ByteString -> Integer) -> [ByteString] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Integer
bs2i [ByteString
v1, ByteString
h, State d -> ByteString
forall d. State d -> ByteString
constant State d
st])
  cnt :: Word64
cnt = State d -> Word64
forall d. State d -> Word64
counter State d
st Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ 1
  slen :: Int
slen = Tagged d Int
forall h. SeedLength h => Tagged h Int
seedlen Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
`for` d
d
  hash :: [ByteString] -> ByteString
hash = d -> ByteString
forall a. Serialize a => a -> ByteString
encode (d -> ByteString)
-> ([ByteString] -> d) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> d
hashF (ByteString -> d)
-> ([ByteString] -> ByteString) -> [ByteString] -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [ByteString] -> ByteString
L.fromChunks
  d :: d
d = State d -> ByteString -> d
forall d. State d -> ByteString -> d
hsh State d
st ByteString
forall a. HasCallStack => a
undefined
  hashF :: ByteString -> d
hashF = State d -> ByteString -> d
forall d. State d -> ByteString -> d
hsh State d
st

-- 10.1.1.4, pg 39
hashGen :: (Hash c d, SeedLength d) => d -> BitLen -> B.ByteString -> RandomBits
hashGen :: d -> Int -> ByteString -> ByteString
hashGen d :: d
d r :: Int
r val :: ByteString
val = Int -> ByteString -> ByteString
B.take Int
reqBytes (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int -> [ByteString]
getW ByteString
val Int
m
  where
  reqBytes :: Int
reqBytes = (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8
  m :: Int
m = (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
outlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
outlen
  getW :: B.ByteString -> Int -> [B.ByteString]
  getW :: ByteString -> Int -> [ByteString]
getW _ 0 = []
  getW dat :: ByteString
dat i :: Int
i =
        let wi :: ByteString
wi = d -> ByteString
forall a. Serialize a => a -> ByteString
encode (ByteString -> d
h ByteString
dat)
            dat' :: ByteString
dat' = ByteString -> ByteString
incBS ByteString
dat
            rest :: [ByteString]
rest = ByteString -> Int -> [ByteString]
getW ByteString
dat' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
        in ByteString
wi ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
rest
  slen :: Int
slen = Tagged d Int
forall h. SeedLength h => Tagged h Int
seedlen Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
`for` d
d
  outlen :: Int
outlen = Tagged d Int
forall ctx d. Hash ctx d => Tagged d Int
outputLength Tagged d Int -> d -> Int
forall a b. Tagged a b -> a -> b
`for` d
d
  h :: ByteString -> d
h = d -> ByteString -> d
forall c d. Hash c d => d -> ByteString -> d
hashFunc' d
d