{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}

-- | Seeds for key generation.
--
module Cardano.Crypto.Seed
  ( Seed
    -- * Constructing seeds
  , mkSeedFromBytes
  , getSeedBytes
  , readSeedFromSystemEntropy
  , splitSeed
  , expandSeed
    -- * Using seeds
  , getBytesFromSeed
  , getBytesFromSeedT
  , runMonadRandomWithSeed
  , SeedBytesExhausted(..)
  ) where

import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import           Data.ByteArray as BA (convert)

import           Control.DeepSeq (NFData)
import           Control.Exception (Exception(..), throw)

import           Data.Functor.Identity
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.State
import           NoThunks.Class (NoThunks)

import           Crypto.Random (MonadRandom(..))
import           Crypto.Random.Entropy (getEntropy)
import           Cardano.Crypto.Hash.Class (HashAlgorithm(digest))


-- | A seed contains a finite number of bytes, and is used for seeding
-- cryptographic algorithms including key generation.
--
-- This is not itself a PRNG, but can be used to seed a PRNG.
--
newtype Seed = Seed ByteString
  deriving (Int -> Seed -> ShowS
[Seed] -> ShowS
Seed -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Seed] -> ShowS
$cshowList :: [Seed] -> ShowS
show :: Seed -> String
$cshow :: Seed -> String
showsPrec :: Int -> Seed -> ShowS
$cshowsPrec :: Int -> Seed -> ShowS
Show, Seed -> Seed -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Seed -> Seed -> Bool
$c/= :: Seed -> Seed -> Bool
== :: Seed -> Seed -> Bool
$c== :: Seed -> Seed -> Bool
Eq, NonEmpty Seed -> Seed
Seed -> Seed -> Seed
forall b. Integral b => b -> Seed -> Seed
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Seed -> Seed
$cstimes :: forall b. Integral b => b -> Seed -> Seed
sconcat :: NonEmpty Seed -> Seed
$csconcat :: NonEmpty Seed -> Seed
<> :: Seed -> Seed -> Seed
$c<> :: Seed -> Seed -> Seed
Semigroup, Semigroup Seed
Seed
[Seed] -> Seed
Seed -> Seed -> Seed
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Seed] -> Seed
$cmconcat :: [Seed] -> Seed
mappend :: Seed -> Seed -> Seed
$cmappend :: Seed -> Seed -> Seed
mempty :: Seed
$cmempty :: Seed
Monoid, Context -> Seed -> IO (Maybe ThunkInfo)
Proxy Seed -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Seed -> String
$cshowTypeOf :: Proxy Seed -> String
wNoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
noThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
NoThunks, Seed -> ()
forall a. (a -> ()) -> NFData a
rnf :: Seed -> ()
$crnf :: Seed -> ()
NFData)


-- | Construct a 'Seed' deterministically from a number of bytes.
--
mkSeedFromBytes :: ByteString -> Seed
mkSeedFromBytes :: ByteString -> Seed
mkSeedFromBytes = ByteString -> Seed
Seed


-- | Extract the full bytes from a seed. Note that this function does not
-- guarantee that the result is sufficiently long for the desired seed size!
getSeedBytes :: Seed -> ByteString
getSeedBytes :: Seed -> ByteString
getSeedBytes (Seed ByteString
s) = ByteString
s

-- | Get a number of bytes from the seed. This will fail if not enough bytes
-- are available. This can be chained multiple times provided the seed is big
-- enough to cover each use.
--
getBytesFromSeed :: Word -> Seed -> Maybe (ByteString, Seed)
getBytesFromSeed :: Word -> Seed -> Maybe (ByteString, Seed)
getBytesFromSeed Word
n (Seed ByteString
s)
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) forall a. Eq a => a -> a -> Bool
== Word
n = forall a. a -> Maybe a
Just (ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = forall a. Maybe a
Nothing
  where
    (ByteString
b, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) ByteString
s

-- | A flavor of 'getBytesFromSeed' that throws 'SeedBytesExhausted' instead of
-- returning 'Nothing'.
getBytesFromSeedT :: Word -> Seed -> (ByteString, Seed)
getBytesFromSeedT :: Word -> Seed -> (ByteString, Seed)
getBytesFromSeedT Word
n (Seed ByteString
s)
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) forall a. Eq a => a -> a -> Bool
== Word
n = (ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = forall a e. Exception e => e -> a
throw (Int -> SeedBytesExhausted
SeedBytesExhausted forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
b)
  where
    (ByteString
b, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) ByteString
s

-- | Split a seed into two smaller seeds, the first of which is the given
-- number of bytes large, and the second is the remaining. This will fail if
-- not enough bytes are available. This can be chained multiple times provided
-- the seed is big enough to cover each use.
--
splitSeed :: Word -> Seed -> Maybe (Seed, Seed)
splitSeed :: Word -> Seed -> Maybe (Seed, Seed)
splitSeed Word
n (Seed ByteString
s)
  | forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) forall a. Eq a => a -> a -> Bool
== Word
n = forall a. a -> Maybe a
Just (ByteString -> Seed
Seed ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = forall a. Maybe a
Nothing
  where
    (ByteString
b, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) ByteString
s

-- | Expand a seed into a pair of seeds using a cryptographic hash function (in
-- the role of a crypto PRNG). The whole input seed is consumed. The output
-- seeds are the size of the hash output.
--
expandSeed :: HashAlgorithm h => proxy h -> Seed -> (Seed, Seed)
expandSeed :: forall h (proxy :: * -> *).
HashAlgorithm h =>
proxy h -> Seed -> (Seed, Seed)
expandSeed proxy h
p (Seed ByteString
s) =
    ( ByteString -> Seed
Seed (forall h (proxy :: * -> *).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
digest proxy h
p (Word8 -> ByteString -> ByteString
BS.cons Word8
1 ByteString
s))
    , ByteString -> Seed
Seed (forall h (proxy :: * -> *).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
digest proxy h
p (Word8 -> ByteString -> ByteString
BS.cons Word8
2 ByteString
s))
    )


-- | Obtain a 'Seed' by reading @n@ bytes of entropy from the operating system.
--
readSeedFromSystemEntropy :: Word -> IO Seed
readSeedFromSystemEntropy :: Word -> IO Seed
readSeedFromSystemEntropy Word
n = ByteString -> Seed
mkSeedFromBytes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall byteArray. ByteArray byteArray => Int -> IO byteArray
getEntropy (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n)

--
-- Support for MonadRandom
--

-- | Run an action in 'MonadRandom' deterministically using a seed as a
-- finite source of randomness. Note that this is not a PRNG, so like with
-- 'getBytesFromSeed' it will fail if more bytes are requested than are
-- available.
--
-- So this is only really suitable for key generation where there is a known
-- upper bound on the amount of entropy that will be requested.
--
runMonadRandomWithSeed :: Seed -> (forall m. MonadRandom m => m a) -> a
runMonadRandomWithSeed :: forall a. Seed -> (forall (m :: * -> *). MonadRandom m => m a) -> a
runMonadRandomWithSeed s :: Seed
s@(Seed ByteString
bs) forall (m :: * -> *). MonadRandom m => m a
a =
    case forall a. Identity a -> a
runIdentity (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall a. MonadRandomFromSeed a -> StateT Seed (MaybeT Identity) a
unMonadRandomFromSeed forall (m :: * -> *). MonadRandom m => m a
a) Seed
s)) of
      Just a
x  -> a
x
      Maybe a
Nothing -> forall a e. Exception e => e -> a
throw (Int -> SeedBytesExhausted
SeedBytesExhausted (ByteString -> Int
BS.length ByteString
bs))

newtype SeedBytesExhausted = SeedBytesExhausted { SeedBytesExhausted -> Int
seedBytesSupplied :: Int }
  deriving Int -> SeedBytesExhausted -> ShowS
[SeedBytesExhausted] -> ShowS
SeedBytesExhausted -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SeedBytesExhausted] -> ShowS
$cshowList :: [SeedBytesExhausted] -> ShowS
show :: SeedBytesExhausted -> String
$cshow :: SeedBytesExhausted -> String
showsPrec :: Int -> SeedBytesExhausted -> ShowS
$cshowsPrec :: Int -> SeedBytesExhausted -> ShowS
Show

instance Exception SeedBytesExhausted

newtype MonadRandomFromSeed a =
        MonadRandomFromSeed {
          forall a. MonadRandomFromSeed a -> StateT Seed (MaybeT Identity) a
unMonadRandomFromSeed :: StateT Seed (MaybeT Identity) a
        }
  deriving newtype (forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
$c<$ :: forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
fmap :: forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
$cfmap :: forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
Functor, Functor MonadRandomFromSeed
forall a. a -> MonadRandomFromSeed a
forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
$c<* :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
*> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$c*> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
liftA2 :: forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
<*> :: forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
$c<*> :: forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
pure :: forall a. a -> MonadRandomFromSeed a
$cpure :: forall a. a -> MonadRandomFromSeed a
Applicative, Applicative MonadRandomFromSeed
forall a. a -> MonadRandomFromSeed a
forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> MonadRandomFromSeed a
$creturn :: forall a. a -> MonadRandomFromSeed a
>> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$c>> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
>>= :: forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
$c>>= :: forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
Monad)

getRandomBytesFromSeed :: Int -> MonadRandomFromSeed ByteString
getRandomBytesFromSeed :: Int -> MonadRandomFromSeed ByteString
getRandomBytesFromSeed Int
n =
    forall a. StateT Seed (MaybeT Identity) a -> MonadRandomFromSeed a
MonadRandomFromSeed forall a b. (a -> b) -> a -> b
$
      forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \Seed
s ->
        forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$
          forall a. a -> Identity a
Identity forall a b. (a -> b) -> a -> b
$
            Word -> Seed -> Maybe (ByteString, Seed)
getBytesFromSeed (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) Seed
s

instance MonadRandom MonadRandomFromSeed where
  getRandomBytes :: forall byteArray.
ByteArray byteArray =>
Int -> MonadRandomFromSeed byteArray
getRandomBytes Int
n = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> MonadRandomFromSeed ByteString
getRandomBytesFromSeed Int
n