{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Crypto.Libsodium.MLockedSeed
where

import Cardano.Crypto.DirectSerialise
import Cardano.Crypto.Libsodium.C (
  c_sodium_randombytes_buf,
 )
import Cardano.Crypto.Libsodium.MLockedBytes (
  MLockedSizedBytes,
  mlsbCopyWith,
  mlsbFinalize,
  mlsbNewWith,
  mlsbNewZeroWith,
  mlsbUseAsCPtr,
  mlsbUseAsSizedPtr,
 )
import Cardano.Crypto.Libsodium.Memory (
  MLockedAllocator,
  mlockedMalloc,
 )
import Cardano.Foreign (SizedPtr)
import Control.DeepSeq (NFData)
import Control.Monad.Class.MonadST (MonadST)
import Data.Proxy (Proxy (..))
import Data.Word (Word8)
import Foreign.Ptr (Ptr, castPtr)
import GHC.TypeNats (KnownNat, natVal)
import NoThunks.Class (NoThunks)

-- | A seed of size @n@, stored in mlocked memory. This is required to prevent
-- the seed from leaking to disk via swapping and reclaiming or scanning memory
-- after its content has been moved.
newtype MLockedSeed n = MLockedSeed {forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB :: MLockedSizedBytes n}
  deriving (MLockedSeed n -> ()
forall (n :: Nat). MLockedSeed n -> ()
forall a. (a -> ()) -> NFData a
rnf :: MLockedSeed n -> ()
$crnf :: forall (n :: Nat). MLockedSeed n -> ()
NFData, Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
Proxy (MLockedSeed n) -> String
forall (n :: Nat). Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
forall (n :: Nat). Proxy (MLockedSeed n) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MLockedSeed n) -> String
$cshowTypeOf :: forall (n :: Nat). Proxy (MLockedSeed n) -> String
wNoThunks :: Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (n :: Nat). Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
noThunks :: Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (n :: Nat). Context -> MLockedSeed n -> IO (Maybe ThunkInfo)
NoThunks)

instance KnownNat n => DirectSerialise (MLockedSeed n) where
  directSerialise :: forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> MLockedSeed n -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push MLockedSeed n
seed =
    forall (m :: * -> *) (n :: Nat) b.
MonadST m =>
MLockedSeed n -> (Ptr Word8 -> m b) -> m b
mlockedSeedUseAsCPtr MLockedSeed n
seed forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
      Ptr CChar -> CSize -> m ()
push (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal MLockedSeed n
seed)

instance KnownNat n => DirectDeserialise (MLockedSeed n) where
  directDeserialise :: forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (MLockedSeed n)
directDeserialise Ptr CChar -> CSize -> m ()
pull = do
    MLockedSeed n
seed <- forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
m (MLockedSeed n)
mlockedSeedNew
    forall (m :: * -> *) (n :: Nat) b.
MonadST m =>
MLockedSeed n -> (Ptr Word8 -> m b) -> m b
mlockedSeedUseAsCPtr MLockedSeed n
seed forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
      Ptr CChar -> CSize -> m ()
pull (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal MLockedSeed n
seed)
    forall (m :: * -> *) a. Monad m => a -> m a
return MLockedSeed n
seed

withMLockedSeedAsMLSB ::
  Functor m =>
  (MLockedSizedBytes n -> m (MLockedSizedBytes n)) ->
  MLockedSeed n ->
  m (MLockedSeed n)
withMLockedSeedAsMLSB :: forall (m :: * -> *) (n :: Nat).
Functor m =>
(MLockedSizedBytes n -> m (MLockedSizedBytes n))
-> MLockedSeed n -> m (MLockedSeed n)
withMLockedSeedAsMLSB MLockedSizedBytes n -> m (MLockedSizedBytes n)
action =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLockedSizedBytes n -> m (MLockedSizedBytes n)
action forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB

mlockedSeedCopy :: (KnownNat n, MonadST m) => MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopy :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopy = forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopyWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedSeedCopyWith ::
  (KnownNat n, MonadST m) =>
  MLockedAllocator m ->
  MLockedSeed n ->
  m (MLockedSeed n)
mlockedSeedCopyWith :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopyWith MLockedAllocator m
allocator = forall (m :: * -> *) (n :: Nat).
Functor m =>
(MLockedSizedBytes n -> m (MLockedSizedBytes n))
-> MLockedSeed n -> m (MLockedSeed n)
withMLockedSeedAsMLSB (forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m
-> MLockedSizedBytes n -> m (MLockedSizedBytes n)
mlsbCopyWith MLockedAllocator m
allocator)

mlockedSeedNew :: (KnownNat n, MonadST m) => m (MLockedSeed n)
mlockedSeedNew :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
m (MLockedSeed n)
mlockedSeedNew = forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedSeedNewWith :: (KnownNat n, MonadST m) => MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewWith :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewWith MLockedAllocator m
allocator =
  forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (m :: * -> *).
MLockedAllocator m
-> (KnownNat n, MonadST m) => m (MLockedSizedBytes n)
mlsbNewWith MLockedAllocator m
allocator

mlockedSeedNewZero :: (KnownNat n, MonadST m) => m (MLockedSeed n)
mlockedSeedNewZero :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
m (MLockedSeed n)
mlockedSeedNewZero = forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewZeroWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedSeedNewZeroWith :: (KnownNat n, MonadST m) => MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewZeroWith :: forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewZeroWith MLockedAllocator m
allocator =
  forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSizedBytes n)
mlsbNewZeroWith MLockedAllocator m
allocator

mlockedSeedNewRandom :: forall n. KnownNat n => IO (MLockedSeed n)
mlockedSeedNewRandom :: forall (n :: Nat). KnownNat n => IO (MLockedSeed n)
mlockedSeedNewRandom = forall (n :: Nat).
KnownNat n =>
MLockedAllocator IO -> IO (MLockedSeed n)
mlockedSeedNewRandomWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedSeedNewRandomWith :: forall n. KnownNat n => MLockedAllocator IO -> IO (MLockedSeed n)
mlockedSeedNewRandomWith :: forall (n :: Nat).
KnownNat n =>
MLockedAllocator IO -> IO (MLockedSeed n)
mlockedSeedNewRandomWith MLockedAllocator IO
allocator = do
  MLockedSeed n
mls <- forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSizedBytes n)
mlsbNewZeroWith MLockedAllocator IO
allocator
  forall (m :: * -> *) (n :: Nat) b.
MonadST m =>
MLockedSeed n -> (Ptr Word8 -> m b) -> m b
mlockedSeedUseAsCPtr MLockedSeed n
mls forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dst -> do
    forall a. Ptr a -> CSize -> IO ()
c_sodium_randombytes_buf Ptr Word8
dst CSize
size
  forall (m :: * -> *) a. Monad m => a -> m a
return MLockedSeed n
mls
  where
    size :: CSize
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy @n)

mlockedSeedFinalize :: MonadST m => MLockedSeed n -> m ()
mlockedSeedFinalize :: forall (m :: * -> *) (n :: Nat). MonadST m => MLockedSeed n -> m ()
mlockedSeedFinalize = forall (m :: * -> *) (n :: Nat).
MonadST m =>
MLockedSizedBytes n -> m ()
mlsbFinalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB

mlockedSeedUseAsCPtr :: MonadST m => MLockedSeed n -> (Ptr Word8 -> m b) -> m b
mlockedSeedUseAsCPtr :: forall (m :: * -> *) (n :: Nat) b.
MonadST m =>
MLockedSeed n -> (Ptr Word8 -> m b) -> m b
mlockedSeedUseAsCPtr MLockedSeed n
seed = forall (m :: * -> *) (n :: Nat) r.
MonadST m =>
MLockedSizedBytes n -> (Ptr Word8 -> m r) -> m r
mlsbUseAsCPtr (forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB MLockedSeed n
seed)

mlockedSeedUseAsSizedPtr :: MonadST m => MLockedSeed n -> (SizedPtr n -> m b) -> m b
mlockedSeedUseAsSizedPtr :: forall (m :: * -> *) (n :: Nat) b.
MonadST m =>
MLockedSeed n -> (SizedPtr n -> m b) -> m b
mlockedSeedUseAsSizedPtr MLockedSeed n
seed = forall (n :: Nat) r (m :: * -> *).
MonadST m =>
MLockedSizedBytes n -> (SizedPtr n -> m r) -> m r
mlsbUseAsSizedPtr (forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB MLockedSeed n
seed)