{-# 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.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))

import           Cardano.Prelude (NFData)


-- | 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
(Int -> Seed -> ShowS)
-> (Seed -> String) -> ([Seed] -> ShowS) -> Show Seed
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
(Seed -> Seed -> Bool) -> (Seed -> Seed -> Bool) -> Eq Seed
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, b -> Seed -> Seed
NonEmpty Seed -> Seed
Seed -> Seed -> Seed
(Seed -> Seed -> Seed)
-> (NonEmpty Seed -> Seed)
-> (forall b. Integral b => b -> Seed -> Seed)
-> Semigroup 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 :: 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
Semigroup Seed
-> Seed
-> (Seed -> Seed -> Seed)
-> ([Seed] -> Seed)
-> Monoid 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
$cp1Monoid :: Semigroup Seed
Monoid, Context -> Seed -> IO (Maybe ThunkInfo)
Proxy Seed -> String
(Context -> Seed -> IO (Maybe ThunkInfo))
-> (Context -> Seed -> IO (Maybe ThunkInfo))
-> (Proxy Seed -> String)
-> NoThunks Seed
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 -> ()
(Seed -> ()) -> NFData 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)
  | Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n = (ByteString, Seed) -> Maybe (ByteString, Seed)
forall a. a -> Maybe a
Just (ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = Maybe (ByteString, Seed)
forall a. Maybe a
Nothing
  where
    (ByteString
b, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Word -> Int
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)
  | Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n = (ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = SeedBytesExhausted -> (ByteString, Seed)
forall a e. Exception e => e -> a
throw (Int -> SeedBytesExhausted
SeedBytesExhausted (Int -> SeedBytesExhausted) -> Int -> 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 (Word -> Int
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)
  | Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Word
n = (Seed, Seed) -> Maybe (Seed, Seed)
forall a. a -> Maybe a
Just (ByteString -> Seed
Seed ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise                       = Maybe (Seed, Seed)
forall a. Maybe a
Nothing
  where
    (ByteString
b, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Word -> Int
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 :: proxy h -> Seed -> (Seed, Seed)
expandSeed proxy h
p (Seed ByteString
s) =
    ( ByteString -> Seed
Seed (proxy h -> ByteString -> ByteString
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 (proxy h -> ByteString -> ByteString
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 (ByteString -> Seed) -> IO ByteString -> IO Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
getEntropy (Word -> Int
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 :: Seed -> (forall (m :: * -> *). MonadRandom m => m a) -> a
runMonadRandomWithSeed s :: Seed
s@(Seed ByteString
bs) forall (m :: * -> *). MonadRandom m => m a
a =
    case Identity (Maybe a) -> Maybe a
forall a. Identity a -> a
runIdentity (MaybeT Identity a -> Identity (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (StateT Seed (MaybeT Identity) a -> Seed -> MaybeT Identity a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (MonadRandomFromSeed a -> StateT Seed (MaybeT Identity) a
forall a. MonadRandomFromSeed a -> StateT Seed (MaybeT Identity) a
unMonadRandomFromSeed MonadRandomFromSeed a
forall (m :: * -> *). MonadRandom m => m a
a) Seed
s)) of
      Just a
x  -> a
x
      Maybe a
Nothing -> SeedBytesExhausted -> a
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
(Int -> SeedBytesExhausted -> ShowS)
-> (SeedBytesExhausted -> String)
-> ([SeedBytesExhausted] -> ShowS)
-> Show SeedBytesExhausted
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 {
          MonadRandomFromSeed a -> StateT Seed (MaybeT Identity) a
unMonadRandomFromSeed :: StateT Seed (MaybeT Identity) a
        }
  deriving newtype (a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
(forall a b.
 (a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b)
-> (forall a b.
    a -> MonadRandomFromSeed b -> MonadRandomFromSeed a)
-> Functor MonadRandomFromSeed
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
<$ :: a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
$c<$ :: forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
fmap :: (a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
$cfmap :: forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
Functor, Functor MonadRandomFromSeed
a -> MonadRandomFromSeed a
Functor MonadRandomFromSeed
-> (forall a. a -> MonadRandomFromSeed a)
-> (forall a b.
    MonadRandomFromSeed (a -> b)
    -> MonadRandomFromSeed a -> MonadRandomFromSeed b)
-> (forall a b c.
    (a -> b -> c)
    -> MonadRandomFromSeed a
    -> MonadRandomFromSeed b
    -> MonadRandomFromSeed c)
-> (forall a b.
    MonadRandomFromSeed a
    -> MonadRandomFromSeed b -> MonadRandomFromSeed b)
-> (forall a b.
    MonadRandomFromSeed a
    -> MonadRandomFromSeed b -> MonadRandomFromSeed a)
-> Applicative MonadRandomFromSeed
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
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
<* :: MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
$c<* :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
*> :: MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$c*> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
liftA2 :: (a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
<*> :: MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
$c<*> :: forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
pure :: a -> MonadRandomFromSeed a
$cpure :: forall a. a -> MonadRandomFromSeed a
$cp1Applicative :: Functor MonadRandomFromSeed
Applicative, Applicative MonadRandomFromSeed
a -> MonadRandomFromSeed a
Applicative MonadRandomFromSeed
-> (forall a b.
    MonadRandomFromSeed a
    -> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b)
-> (forall a b.
    MonadRandomFromSeed a
    -> MonadRandomFromSeed b -> MonadRandomFromSeed b)
-> (forall a. a -> MonadRandomFromSeed a)
-> Monad MonadRandomFromSeed
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
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 :: a -> MonadRandomFromSeed a
$creturn :: forall a. a -> MonadRandomFromSeed a
>> :: MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$c>> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
>>= :: MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
$c>>= :: forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
$cp1Monad :: Applicative MonadRandomFromSeed
Monad)

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

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