{-|
Module      : Z.Crypto.RNG
Description : Random Number Generators
Copyright   : Dong Han, 2021
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

Several different RNG types are implemented. Some access hardware RNGs, which are only available on certain platforms. Others are mostly useful in specific situations.

-}

module Z.Crypto.RNG
  ( -- * RNG
    RNGType(..), RNG
  , newRNG, getRNG, getRandom
  , reseedRNG, reseedRNGFromRNG, addEntropyRNG
  -- * Internal
  , withRNG
  ) where

import           Control.Monad
import           Data.IORef
import           GHC.Conc
import           GHC.Generics
import           System.IO.Unsafe
import           Z.Botan.Exception
import           Z.Botan.FFI
import qualified Z.Data.Array      as A
import           Z.Data.CBytes
import           Z.Data.JSON       (JSON)
import qualified Z.Data.Text       as T
import qualified Z.Data.Vector     as V
import           Z.Foreign

-- | RNG types.
data RNGType = SystemRNG | AutoSeededRNG | ProcessorRNG
    deriving (Int -> RNGType -> ShowS
[RNGType] -> ShowS
RNGType -> String
(Int -> RNGType -> ShowS)
-> (RNGType -> String) -> ([RNGType] -> ShowS) -> Show RNGType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RNGType] -> ShowS
$cshowList :: [RNGType] -> ShowS
show :: RNGType -> String
$cshow :: RNGType -> String
showsPrec :: Int -> RNGType -> ShowS
$cshowsPrec :: Int -> RNGType -> ShowS
Show, RNGType -> RNGType -> Bool
(RNGType -> RNGType -> Bool)
-> (RNGType -> RNGType -> Bool) -> Eq RNGType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RNGType -> RNGType -> Bool
$c/= :: RNGType -> RNGType -> Bool
== :: RNGType -> RNGType -> Bool
$c== :: RNGType -> RNGType -> Bool
Eq, Eq RNGType
Eq RNGType
-> (RNGType -> RNGType -> Ordering)
-> (RNGType -> RNGType -> Bool)
-> (RNGType -> RNGType -> Bool)
-> (RNGType -> RNGType -> Bool)
-> (RNGType -> RNGType -> Bool)
-> (RNGType -> RNGType -> RNGType)
-> (RNGType -> RNGType -> RNGType)
-> Ord RNGType
RNGType -> RNGType -> Bool
RNGType -> RNGType -> Ordering
RNGType -> RNGType -> RNGType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RNGType -> RNGType -> RNGType
$cmin :: RNGType -> RNGType -> RNGType
max :: RNGType -> RNGType -> RNGType
$cmax :: RNGType -> RNGType -> RNGType
>= :: RNGType -> RNGType -> Bool
$c>= :: RNGType -> RNGType -> Bool
> :: RNGType -> RNGType -> Bool
$c> :: RNGType -> RNGType -> Bool
<= :: RNGType -> RNGType -> Bool
$c<= :: RNGType -> RNGType -> Bool
< :: RNGType -> RNGType -> Bool
$c< :: RNGType -> RNGType -> Bool
compare :: RNGType -> RNGType -> Ordering
$ccompare :: RNGType -> RNGType -> Ordering
$cp1Ord :: Eq RNGType
Ord, (forall x. RNGType -> Rep RNGType x)
-> (forall x. Rep RNGType x -> RNGType) -> Generic RNGType
forall x. Rep RNGType x -> RNGType
forall x. RNGType -> Rep RNGType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RNGType x -> RNGType
$cfrom :: forall x. RNGType -> Rep RNGType x
Generic)
    deriving anyclass (Int -> RNGType -> Builder ()
(Int -> RNGType -> Builder ()) -> Print RNGType
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> RNGType -> Builder ()
$ctoUTF8BuilderP :: Int -> RNGType -> Builder ()
T.Print, Value -> Converter RNGType
RNGType -> Value
RNGType -> Builder ()
(Value -> Converter RNGType)
-> (RNGType -> Value) -> (RNGType -> Builder ()) -> JSON RNGType
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: RNGType -> Builder ()
$cencodeJSON :: RNGType -> Builder ()
toValue :: RNGType -> Value
$ctoValue :: RNGType -> Value
fromValue :: Value -> Converter RNGType
$cfromValue :: Value -> Converter RNGType
JSON)

-- | Opaque botan RNG type.
newtype RNG = RNG BotanStruct
    deriving (Int -> RNG -> ShowS
[RNG] -> ShowS
RNG -> String
(Int -> RNG -> ShowS)
-> (RNG -> String) -> ([RNG] -> ShowS) -> Show RNG
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RNG] -> ShowS
$cshowList :: [RNG] -> ShowS
show :: RNG -> String
$cshow :: RNG -> String
showsPrec :: Int -> RNG -> ShowS
$cshowsPrec :: Int -> RNG -> ShowS
Show, (forall x. RNG -> Rep RNG x)
-> (forall x. Rep RNG x -> RNG) -> Generic RNG
forall x. Rep RNG x -> RNG
forall x. RNG -> Rep RNG x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RNG x -> RNG
$cfrom :: forall x. RNG -> Rep RNG x
Generic)
    deriving anyclass Int -> RNG -> Builder ()
(Int -> RNG -> Builder ()) -> Print RNG
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> RNG -> Builder ()
$ctoUTF8BuilderP :: Int -> RNG -> Builder ()
T.Print

-- | Initialize a random number generator object from the given 'RNGType'
newRNG :: RNGType -> IO RNG
newRNG :: RNGType -> IO RNG
newRNG RNGType
typ = BotanStruct -> RNG
RNG (BotanStruct -> RNG) -> IO BotanStruct -> IO RNG
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO ()) -> IO BotanStruct
forall a.
HasCallStack =>
(MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO a) -> IO BotanStruct
newBotanStruct
    (\ MBA# BotanStructT
bts -> CBytes -> (BA# Word8 -> IO CInt) -> IO CInt
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe (RNGType -> CBytes
forall p. IsString p => RNGType -> p
rngTypeCBytes RNGType
typ) (MBA# BotanStructT -> BA# Word8 -> IO CInt
botan_rng_init MBA# BotanStructT
bts))
    FunPtr (BotanStructT -> IO ())
botan_rng_destroy
  where
    rngTypeCBytes :: RNGType -> p
rngTypeCBytes RNGType
SystemRNG     = p
"system"
    rngTypeCBytes RNGType
AutoSeededRNG = p
"user"
    rngTypeCBytes RNGType
ProcessorRNG  = p
"hwrng"

-- | Use RNG as a `botan_rng_t` object.
withRNG :: RNG -> (BotanStructT -> IO a) -> IO a
withRNG :: RNG -> (BotanStructT -> IO a) -> IO a
withRNG (RNG BotanStruct
rng) BotanStructT -> IO a
f = BotanStruct -> (BotanStructT -> IO a) -> IO a
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
rng BotanStructT -> IO a
f

-- | Get an autoseeded RNG from a global RNG pool divide by haskell capability.
--
-- Botan internal use a lock to protect user-space RNG, which may cause contention if shared.
-- This function will fetch an autoseeded RNG from a global RNG pool, which is recommended under
-- concurrent settings.
getRNG :: IO RNG
getRNG :: IO RNG
getRNG = do
    (Int
cap, Bool
_) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
    SmallArray RNG
rngArray <- IORef (SmallArray RNG) -> IO (SmallArray RNG)
forall a. IORef a -> IO a
readIORef IORef (SmallArray RNG)
rngArrayRef
    SmallArray RNG -> Int -> IO RNG
forall (arr :: * -> *) a (m :: * -> *).
(Arr arr a, Monad m) =>
arr a -> Int -> m a
A.indexArrM SmallArray RNG
rngArray (Int
cap Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` SmallArray RNG -> Int
forall (arr :: * -> *) a. Arr arr a => arr a -> Int
A.sizeofArr SmallArray RNG
rngArray)
  where
    rngArrayRef :: IORef (A.SmallArray RNG)
    {-# NOINLINE rngArrayRef #-}
    rngArrayRef :: IORef (SmallArray RNG)
rngArrayRef = IO (IORef (SmallArray RNG)) -> IORef (SmallArray RNG)
forall a. IO a -> a
unsafePerformIO (IO (IORef (SmallArray RNG)) -> IORef (SmallArray RNG))
-> IO (IORef (SmallArray RNG)) -> IORef (SmallArray RNG)
forall a b. (a -> b) -> a -> b
$ do
        Int
numCaps <- IO Int
getNumCapabilities
        SmallMutableArray RealWorld RNG
rngArray <- Int -> IO (MArr SmallArray RealWorld RNG)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
Int -> m (MArr arr s a)
A.newArr Int
numCaps
        [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..Int
numCapsInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
            MArr SmallArray RealWorld RNG -> Int -> RNG -> IO ()
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> Int -> a -> m ()
A.writeArr MArr SmallArray RealWorld RNG
SmallMutableArray RealWorld RNG
rngArray Int
i (RNG -> IO ()) -> IO RNG -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RNGType -> IO RNG
newRNG RNGType
AutoSeededRNG
        SmallArray RNG
irngArray <- MArr SmallArray RealWorld RNG -> IO (SmallArray RNG)
forall (arr :: * -> *) a (m :: * -> *) s.
(Arr arr a, PrimMonad m, PrimState m ~ s) =>
MArr arr s a -> m (arr a)
A.unsafeFreezeArr MArr SmallArray RealWorld RNG
SmallMutableArray RealWorld RNG
rngArray
        SmallArray RNG -> IO (IORef (SmallArray RNG))
forall a. a -> IO (IORef a)
newIORef SmallArray RNG
irngArray

-- | Get random bytes from a random number generator.
getRandom :: RNG -> Int -> IO V.Bytes
getRandom :: RNG -> Int -> IO Bytes
getRandom RNG
r Int
siz =  RNG -> (BotanStructT -> IO Bytes) -> IO Bytes
forall a. RNG -> (BotanStructT -> IO a) -> IO a
withRNG RNG
r ((BotanStructT -> IO Bytes) -> IO Bytes)
-> (BotanStructT -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
rng -> do
    (Bytes
b, ()
_) <- Int -> (MBA# BotanStructT -> IO ()) -> IO (Bytes, ())
forall a b.
Prim a =>
Int -> (MBA# BotanStructT -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe Int
siz ((MBA# BotanStructT -> IO ()) -> IO (Bytes, ()))
-> (MBA# BotanStructT -> IO ()) -> IO (Bytes, ())
forall a b. (a -> b) -> a -> b
$ \ MBA# BotanStructT
buf ->
        IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> MBA# BotanStructT -> CSize -> IO CInt
botan_rng_get BotanStructT
rng MBA# BotanStructT
buf (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz))
    Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
b

-- | Reseeds the random number generator with bits number of bits from the 'SystemRNG'.
reseedRNG :: RNG -> Int -> IO ()
reseedRNG :: RNG -> Int -> IO ()
reseedRNG RNG
r Int
siz = RNG -> (BotanStructT -> IO ()) -> IO ()
forall a. RNG -> (BotanStructT -> IO a) -> IO a
withRNG RNG
r ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
rng -> do
    IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> CSize -> IO CInt
botan_rng_reseed BotanStructT
rng (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz))

-- | Reseeds the random number generator with bits number of bits from the given source RNG.
reseedRNGFromRNG :: RNG -> RNG -> Int -> IO ()
reseedRNGFromRNG :: RNG -> RNG -> Int -> IO ()
reseedRNGFromRNG RNG
r1 RNG
r2 Int
siz =
    RNG -> (BotanStructT -> IO ()) -> IO ()
forall a. RNG -> (BotanStructT -> IO a) -> IO a
withRNG RNG
r1 ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
rng1 -> do
        RNG -> (BotanStructT -> IO ()) -> IO ()
forall a. RNG -> (BotanStructT -> IO a) -> IO a
withRNG RNG
r2 ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
rng2 -> do
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> BotanStructT -> CSize -> IO CInt
botan_rng_reseed_from_rng BotanStructT
rng1 BotanStructT
rng2 (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
siz))

-- | Adds the provided seed material to the internal RNG state.
--
-- This call may be ignored by certain RNG instances (such as 'ProcessorRNG' or, on some systems, the 'SystemRNG').
addEntropyRNG :: RNG -> V.Bytes -> IO ()
addEntropyRNG :: RNG -> Bytes -> IO ()
addEntropyRNG RNG
r Bytes
seed =
    RNG -> (BotanStructT -> IO ()) -> IO ()
forall a. RNG -> (BotanStructT -> IO a) -> IO a
withRNG RNG
r ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
rng -> do
        Bytes -> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
seed ((BA# Word8 -> Int -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
pseed Int
offseed Int
lseed -> do
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> BA# Word8 -> Int -> Int -> IO CInt
hs_botan_rng_add_entropy BotanStructT
rng BA# Word8
pseed
                    (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offseed) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lseed))