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

-- | Seeds for key generation.
module Cardano.Crypto.Seed (
  Seed,

  -- * Constructing seeds
  mkSeedFromBytes,
  getSeedBytes,
  readSeedFromSystemEntropy,
  splitSeed,
  expandSeed,

  -- * Using seeds
  getBytesFromSeed,
  getBytesFromSeedT,
  getBytesFromSeedEither,
  getSeedSize,
  runMonadRandomWithSeed,
  SeedBytesExhausted (..),
) where

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

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

import Control.Monad.Trans.Except
import Control.Monad.Trans.State
import Data.Bifunctor (first)
import Data.Functor.Identity
import NoThunks.Class (NoThunks)

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

-- | 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
$cshowsPrec :: Int -> Seed -> ShowS
showsPrec :: Int -> Seed -> ShowS
$cshow :: Seed -> String
show :: Seed -> String
$cshowList :: [Seed] -> ShowS
showList :: [Seed] -> ShowS
Show, Seed -> Seed -> Bool
(Seed -> Seed -> Bool) -> (Seed -> Seed -> Bool) -> Eq Seed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Seed -> Seed -> Bool
== :: Seed -> Seed -> Bool
$c/= :: Seed -> Seed -> Bool
/= :: Seed -> Seed -> Bool
Eq, 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
$c<> :: Seed -> Seed -> Seed
<> :: Seed -> Seed -> Seed
$csconcat :: NonEmpty Seed -> Seed
sconcat :: NonEmpty Seed -> Seed
$cstimes :: forall b. Integral b => b -> Seed -> Seed
stimes :: forall b. Integral b => b -> 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
$cmempty :: Seed
mempty :: Seed
$cmappend :: Seed -> Seed -> Seed
mappend :: Seed -> Seed -> Seed
$cmconcat :: [Seed] -> Seed
mconcat :: [Seed] -> 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
$cnoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
noThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Seed -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Seed -> String
showTypeOf :: Proxy Seed -> String
NoThunks, Seed -> ()
(Seed -> ()) -> NFData Seed
forall a. (a -> ()) -> NFData a
$crnf :: Seed -> ()
rnf :: 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

getSeedSize :: Seed -> Word
getSeedSize :: Seed -> Word
getSeedSize (Seed ByteString
bs) =
  Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> (Int -> Int) -> Int -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs

-- | 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
s =
  case Word -> Seed -> Either SeedBytesExhausted (ByteString, Seed)
getBytesFromSeedEither Word
n Seed
s of
    Right (ByteString, Seed)
x -> (ByteString, Seed) -> Maybe (ByteString, Seed)
forall a. a -> Maybe a
Just (ByteString, Seed)
x
    Left SeedBytesExhausted
_ -> Maybe (ByteString, Seed)
forall a. Maybe a
Nothing

getBytesFromSeedEither :: Word -> Seed -> Either SeedBytesExhausted (ByteString, Seed)
getBytesFromSeedEither :: Word -> Seed -> Either SeedBytesExhausted (ByteString, Seed)
getBytesFromSeedEither Word
n (Seed ByteString
s)
  | Word
n Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
b) =
      (ByteString, Seed) -> Either SeedBytesExhausted (ByteString, Seed)
forall a b. b -> Either a b
Right (ByteString
b, ByteString -> Seed
Seed ByteString
s')
  | Bool
otherwise =
      SeedBytesExhausted -> Either SeedBytesExhausted (ByteString, Seed)
forall a b. a -> Either a b
Left (SeedBytesExhausted
 -> Either SeedBytesExhausted (ByteString, Seed))
-> SeedBytesExhausted
-> Either SeedBytesExhausted (ByteString, Seed)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SeedBytesExhausted
SeedBytesExhausted (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
b) (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n)
  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
s =
  (SeedBytesExhausted -> (ByteString, Seed))
-> ((ByteString, Seed) -> (ByteString, Seed))
-> Either SeedBytesExhausted (ByteString, Seed)
-> (ByteString, Seed)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SeedBytesExhausted -> (ByteString, Seed)
forall a e. Exception e => e -> a
throw (ByteString, Seed) -> (ByteString, Seed)
forall a. a -> a
id (Either SeedBytesExhausted (ByteString, Seed)
 -> (ByteString, Seed))
-> Either SeedBytesExhausted (ByteString, Seed)
-> (ByteString, Seed)
forall a b. (a -> b) -> a -> b
$ Word -> Seed -> Either SeedBytesExhausted (ByteString, Seed)
getBytesFromSeedEither Word
n Seed
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
s =
  (ByteString -> Seed) -> (ByteString, Seed) -> (Seed, Seed)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> Seed
Seed ((ByteString, Seed) -> (Seed, Seed))
-> Maybe (ByteString, Seed) -> Maybe (Seed, Seed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Seed -> Maybe (ByteString, Seed)
getBytesFromSeed Word
n Seed
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 (proxy h -> ByteString -> ByteString
forall h (proxy :: * -> *).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
forall (proxy :: * -> *). 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
forall (proxy :: * -> *). 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 :: forall a. Seed -> (forall (m :: * -> *). MonadRandom m => m a) -> a
runMonadRandomWithSeed Seed
s forall (m :: * -> *). MonadRandom m => m a
a =
  case Identity (Either SeedBytesExhausted a)
-> Either SeedBytesExhausted a
forall a. Identity a -> a
runIdentity (ExceptT SeedBytesExhausted Identity a
-> Identity (Either SeedBytesExhausted a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (StateT Seed (ExceptT SeedBytesExhausted Identity) a
-> Seed -> ExceptT SeedBytesExhausted Identity a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (MonadRandomFromSeed a
-> StateT Seed (ExceptT SeedBytesExhausted Identity) a
forall a.
MonadRandomFromSeed a
-> StateT Seed (ExceptT SeedBytesExhausted Identity) a
unMonadRandomFromSeed MonadRandomFromSeed a
forall (m :: * -> *). MonadRandom m => m a
a) Seed
s)) of
    Right a
x -> a
x
    Left SeedBytesExhausted
e -> SeedBytesExhausted -> a
forall a e. Exception e => e -> a
throw SeedBytesExhausted
e

data SeedBytesExhausted
  = SeedBytesExhausted
  { SeedBytesExhausted -> Int
seedBytesSupplied :: Int
  , SeedBytesExhausted -> Int
seedBytesDemanded :: 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
$cshowsPrec :: Int -> SeedBytesExhausted -> ShowS
showsPrec :: Int -> SeedBytesExhausted -> ShowS
$cshow :: SeedBytesExhausted -> String
show :: SeedBytesExhausted -> String
$cshowList :: [SeedBytesExhausted] -> ShowS
showList :: [SeedBytesExhausted] -> ShowS
Show)

instance Exception SeedBytesExhausted

newtype MonadRandomFromSeed a
  = MonadRandomFromSeed
  { forall a.
MonadRandomFromSeed a
-> StateT Seed (ExceptT SeedBytesExhausted Identity) a
unMonadRandomFromSeed :: StateT Seed (ExceptT SeedBytesExhausted Identity) a
  }
  deriving newtype ((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
$cfmap :: forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
fmap :: forall a b.
(a -> b) -> MonadRandomFromSeed a -> MonadRandomFromSeed b
$c<$ :: forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
<$ :: forall a b. a -> MonadRandomFromSeed b -> MonadRandomFromSeed a
Functor, Functor MonadRandomFromSeed
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
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
$cpure :: forall a. a -> MonadRandomFromSeed a
pure :: forall a. a -> MonadRandomFromSeed a
$c<*> :: forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
<*> :: forall a b.
MonadRandomFromSeed (a -> b)
-> MonadRandomFromSeed a -> MonadRandomFromSeed b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
liftA2 :: forall a b c.
(a -> b -> c)
-> MonadRandomFromSeed a
-> MonadRandomFromSeed b
-> MonadRandomFromSeed c
$c*> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
*> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$c<* :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
<* :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed a
Applicative, Applicative MonadRandomFromSeed
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
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
$c>>= :: forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
>>= :: forall a b.
MonadRandomFromSeed a
-> (a -> MonadRandomFromSeed b) -> MonadRandomFromSeed b
$c>> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
>> :: forall a b.
MonadRandomFromSeed a
-> MonadRandomFromSeed b -> MonadRandomFromSeed b
$creturn :: forall a. a -> MonadRandomFromSeed a
return :: forall a. a -> MonadRandomFromSeed a
Monad)

getRandomBytesFromSeed :: Int -> MonadRandomFromSeed ByteString
getRandomBytesFromSeed :: Int -> MonadRandomFromSeed ByteString
getRandomBytesFromSeed Int
n =
  StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString
-> MonadRandomFromSeed ByteString
forall a.
StateT Seed (ExceptT SeedBytesExhausted Identity) a
-> MonadRandomFromSeed a
MonadRandomFromSeed (StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString
 -> MonadRandomFromSeed ByteString)
-> StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString
-> MonadRandomFromSeed ByteString
forall a b. (a -> b) -> a -> b
$
    (Seed -> ExceptT SeedBytesExhausted Identity (ByteString, Seed))
-> StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Seed -> ExceptT SeedBytesExhausted Identity (ByteString, Seed))
 -> StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString)
-> (Seed -> ExceptT SeedBytesExhausted Identity (ByteString, Seed))
-> StateT Seed (ExceptT SeedBytesExhausted Identity) ByteString
forall a b. (a -> b) -> a -> b
$ \Seed
s ->
      Identity (Either SeedBytesExhausted (ByteString, Seed))
-> ExceptT SeedBytesExhausted Identity (ByteString, Seed)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Identity (Either SeedBytesExhausted (ByteString, Seed))
 -> ExceptT SeedBytesExhausted Identity (ByteString, Seed))
-> Identity (Either SeedBytesExhausted (ByteString, Seed))
-> ExceptT SeedBytesExhausted Identity (ByteString, Seed)
forall a b. (a -> b) -> a -> b
$
        Either SeedBytesExhausted (ByteString, Seed)
-> Identity (Either SeedBytesExhausted (ByteString, Seed))
forall a. a -> Identity a
Identity (Either SeedBytesExhausted (ByteString, Seed)
 -> Identity (Either SeedBytesExhausted (ByteString, Seed)))
-> Either SeedBytesExhausted (ByteString, Seed)
-> Identity (Either SeedBytesExhausted (ByteString, Seed))
forall a b. (a -> b) -> a -> b
$
          Word -> Seed -> Either SeedBytesExhausted (ByteString, Seed)
getBytesFromSeedEither (Int -> Word
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 = 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