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

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