{-# LANGUAGE ScopedTypeVariables #-}

-- | Direct (de-)serialisation to / from raw memory.
--
-- The purpose of the typeclasses in this module is to abstract over data
-- structures that can expose the data they store as one or more raw 'Ptr's,
-- without any additional memory copying or conversion to intermediate data
-- structures.
--
-- This is useful for transmitting data like KES SignKeys over a socket
-- connection: by accessing the memory directly and copying it into or out of
-- a file descriptor, without going through an intermediate @ByteString@
-- representation (or other data structure that resides in the GHC heap), we
-- can more easily assure that the data is never written to disk, including
-- swap, which is an important requirement for KES.
module Cardano.Crypto.DirectSerialise
where

import Cardano.Crypto.Libsodium.Memory (copyMem)
import Control.Exception
import Control.Monad (when)
import Control.Monad.Class.MonadST (MonadST, stToIO)
import Control.Monad.Class.MonadThrow (MonadThrow)
import Data.STRef (newSTRef, readSTRef, writeSTRef)
import Foreign.C.Types
import Foreign.Ptr

data SizeCheckException
  = SizeCheckException
  { SizeCheckException -> Int
expectedSize :: Int
  , SizeCheckException -> Int
actualSize :: Int
  }
  deriving (Int -> SizeCheckException -> ShowS
[SizeCheckException] -> ShowS
SizeCheckException -> String
(Int -> SizeCheckException -> ShowS)
-> (SizeCheckException -> String)
-> ([SizeCheckException] -> ShowS)
-> Show SizeCheckException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SizeCheckException -> ShowS
showsPrec :: Int -> SizeCheckException -> ShowS
$cshow :: SizeCheckException -> String
show :: SizeCheckException -> String
$cshowList :: [SizeCheckException] -> ShowS
showList :: [SizeCheckException] -> ShowS
Show)

instance Exception SizeCheckException

sizeCheckFailed :: Int -> Int -> m ()
sizeCheckFailed :: forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed Int
ex Int
ac =
  SizeCheckException -> m ()
forall a e. Exception e => e -> a
throw (SizeCheckException -> m ()) -> SizeCheckException -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> SizeCheckException
SizeCheckException Int
ex Int
ac

-- | Direct deserialization from raw memory.
--
-- @directDeserialise f@ should allocate a new value of type 'a', and
-- call @f@ with a pointer to the raw memory to be filled. @f@ may be called
-- multiple times, for data structures that store their data in multiple
-- non-contiguous blocks of memory.
--
-- The order in which memory blocks are visited matters.
class DirectDeserialise a where
  directDeserialise :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> m a

-- | Direct serialization to raw memory.
--
-- @directSerialise f x@ should call @f@ to expose the raw memory underyling
-- @x@. For data types that store their data in multiple non-contiguous blocks
-- of memory, @f@ may be called multiple times, once for each block.
--
-- The order in which memory blocks are visited matters.
class DirectSerialise a where
  directSerialise :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> a -> m ()

-- | Helper function for bounds-checked serialization.
-- Verifies that no more than the maximum number of bytes are written, and
-- returns the actual number of bytes written.
directSerialiseTo ::
  forall m a.
  DirectSerialise a =>
  MonadST m =>
  MonadThrow m =>
  (Int -> Ptr CChar -> CSize -> m ()) ->
  Int ->
  a ->
  m Int
directSerialiseTo :: forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m Int
directSerialiseTo Int -> Ptr CChar -> CSize -> m ()
writeBytes Int
dstsize a
val = do
  STRef (PrimState m) Int
posRef <- ST (PrimState m) (STRef (PrimState m) Int)
-> m (STRef (PrimState m) Int)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) (STRef (PrimState m) Int)
 -> m (STRef (PrimState m) Int))
-> ST (PrimState m) (STRef (PrimState m) Int)
-> m (STRef (PrimState m) Int)
forall a b. (a -> b) -> a -> b
$ Int -> ST (PrimState m) (STRef (PrimState m) Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  let pusher :: Ptr CChar -> CSize -> m ()
      pusher :: Ptr CChar -> CSize -> m ()
pusher Ptr CChar
src CSize
srcsize = do
        Int
pos <- ST (PrimState m) Int -> m Int
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) Int -> m Int) -> ST (PrimState m) Int -> m Int
forall a b. (a -> b) -> a -> b
$ STRef (PrimState m) Int -> ST (PrimState m) Int
forall s a. STRef s a -> ST s a
readSTRef STRef (PrimState m) Int
posRef
        let pos' :: Int
pos' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
srcsize
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pos' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
dstsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed (Int
dstsize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos) (Int
pos' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos)
        Int -> Ptr CChar -> CSize -> m ()
writeBytes Int
pos Ptr CChar
src (CSize -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
srcsize)
        ST (PrimState m) () -> m ()
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ STRef (PrimState m) Int -> Int -> ST (PrimState m) ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef (PrimState m) Int
posRef Int
pos'
  (Ptr CChar -> CSize -> m ()) -> a -> m ()
forall a (m :: * -> *).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
directSerialise Ptr CChar -> CSize -> m ()
pusher a
val
  ST (PrimState m) Int -> m Int
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) Int -> m Int) -> ST (PrimState m) Int -> m Int
forall a b. (a -> b) -> a -> b
$ STRef (PrimState m) Int -> ST (PrimState m) Int
forall s a. STRef s a -> ST s a
readSTRef STRef (PrimState m) Int
posRef

-- | Helper function for size-checked serialization.
-- Verifies that exactly the specified number of bytes are written.
directSerialiseToChecked ::
  forall m a.
  DirectSerialise a =>
  MonadST m =>
  MonadThrow m =>
  (Int -> Ptr CChar -> CSize -> m ()) ->
  Int ->
  a ->
  m ()
directSerialiseToChecked :: forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m ()
directSerialiseToChecked Int -> Ptr CChar -> CSize -> m ()
writeBytes Int
dstsize a
val = do
  Int
bytesWritten <- (Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m Int
forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m Int
directSerialiseTo Int -> Ptr CChar -> CSize -> m ()
writeBytes Int
dstsize a
val
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bytesWritten Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
dstsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed Int
dstsize Int
bytesWritten

-- | Helper function for the common use case of serializing to an in-memory
-- buffer.
-- Verifies that no more than the maximum number of bytes are written, and
-- returns the actual number of bytes written.
directSerialiseBuf ::
  forall m a.
  DirectSerialise a =>
  MonadST m =>
  MonadThrow m =>
  Ptr CChar ->
  Int ->
  a ->
  m Int
directSerialiseBuf :: forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> a -> m Int
directSerialiseBuf Ptr CChar
dst =
  (Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m Int
forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> a -> m Int
directSerialiseTo (Ptr CChar -> Ptr CChar -> CSize -> m ()
forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem (Ptr CChar -> Ptr CChar -> CSize -> m ())
-> (Int -> Ptr CChar) -> Int -> Ptr CChar -> CSize -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr CChar -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CChar
dst)

-- | Helper function for size-checked serialization to an in-memory buffer.
-- Verifies that exactly the specified number of bytes are written.
directSerialiseBufChecked ::
  forall m a.
  DirectSerialise a =>
  MonadST m =>
  MonadThrow m =>
  Ptr CChar ->
  Int ->
  a ->
  m ()
directSerialiseBufChecked :: forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> a -> m ()
directSerialiseBufChecked Ptr CChar
buf Int
dstsize a
val = do
  Int
bytesWritten <- Ptr CChar -> Int -> a -> m Int
forall (m :: * -> *) a.
(DirectSerialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> a -> m Int
directSerialiseBuf Ptr CChar
buf Int
dstsize a
val
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bytesWritten Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
dstsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed Int
dstsize Int
bytesWritten

-- | Helper function for size-checked deserialization.
-- Verifies that no more than the maximum number of bytes are read, and returns
-- the actual number of bytes read.
directDeserialiseFrom ::
  forall m a.
  DirectDeserialise a =>
  MonadST m =>
  MonadThrow m =>
  (Int -> Ptr CChar -> CSize -> m ()) ->
  Int ->
  m (a, Int)
directDeserialiseFrom :: forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> m (a, Int)
directDeserialiseFrom Int -> Ptr CChar -> CSize -> m ()
readBytes Int
srcsize = do
  STRef (PrimState m) Int
posRef <- ST (PrimState m) (STRef (PrimState m) Int)
-> m (STRef (PrimState m) Int)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) (STRef (PrimState m) Int)
 -> m (STRef (PrimState m) Int))
-> ST (PrimState m) (STRef (PrimState m) Int)
-> m (STRef (PrimState m) Int)
forall a b. (a -> b) -> a -> b
$ Int -> ST (PrimState m) (STRef (PrimState m) Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  let puller :: Ptr CChar -> CSize -> m ()
      puller :: Ptr CChar -> CSize -> m ()
puller Ptr CChar
dst CSize
dstsize = do
        Int
pos <- ST (PrimState m) Int -> m Int
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) Int -> m Int) -> ST (PrimState m) Int -> m Int
forall a b. (a -> b) -> a -> b
$ STRef (PrimState m) Int -> ST (PrimState m) Int
forall s a. STRef s a -> ST s a
readSTRef STRef (PrimState m) Int
posRef
        let pos' :: Int
pos' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
dstsize
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pos' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
srcsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed (Int
srcsize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos) (Int
pos' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
pos)
        Int -> Ptr CChar -> CSize -> m ()
readBytes Int
pos Ptr CChar
dst (CSize -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
dstsize)
        ST (PrimState m) () -> m ()
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (ST (PrimState m) () -> m ()) -> ST (PrimState m) () -> m ()
forall a b. (a -> b) -> a -> b
$ STRef (PrimState m) Int -> Int -> ST (PrimState m) ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef (PrimState m) Int
posRef Int
pos'
  (,) (a -> Int -> (a, Int)) -> m a -> m (Int -> (a, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr CChar -> CSize -> m ()) -> m a
forall a (m :: * -> *).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
puller m (Int -> (a, Int)) -> m Int -> m (a, Int)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ST (PrimState m) Int -> m Int
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (STRef (PrimState m) Int -> ST (PrimState m) Int
forall s a. STRef s a -> ST s a
readSTRef STRef (PrimState m) Int
posRef)

-- | Helper function for size-checked deserialization.
-- Verifies that exactly the specified number of bytes are read.
directDeserialiseFromChecked ::
  forall m a.
  DirectDeserialise a =>
  MonadST m =>
  MonadThrow m =>
  (Int -> Ptr CChar -> CSize -> m ()) ->
  Int ->
  m a
directDeserialiseFromChecked :: forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> m a
directDeserialiseFromChecked Int -> Ptr CChar -> CSize -> m ()
readBytes Int
srcsize = do
  (a
r, Int
bytesRead) <- (Int -> Ptr CChar -> CSize -> m ()) -> Int -> m (a, Int)
forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> m (a, Int)
directDeserialiseFrom Int -> Ptr CChar -> CSize -> m ()
readBytes Int
srcsize
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bytesRead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
srcsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed Int
srcsize Int
bytesRead
  a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Helper function for the common use case of deserializing from an in-memory
-- buffer.
-- Verifies that no more than the maximum number of bytes are read, and returns
-- the actual number of bytes read.
directDeserialiseBuf ::
  forall m a.
  DirectDeserialise a =>
  MonadST m =>
  MonadThrow m =>
  Ptr CChar ->
  Int ->
  m (a, Int)
directDeserialiseBuf :: forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> m (a, Int)
directDeserialiseBuf Ptr CChar
src =
  (Int -> Ptr CChar -> CSize -> m ()) -> Int -> m (a, Int)
forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Int -> Ptr CChar -> CSize -> m ()) -> Int -> m (a, Int)
directDeserialiseFrom (\Int
pos Ptr CChar
dst -> Ptr CChar -> Ptr CChar -> CSize -> m ()
forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem Ptr CChar
dst (Ptr CChar -> Int -> Ptr CChar
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr CChar
src Int
pos))

-- | Helper function for size-checked deserialization from an in-memory buffer.
-- Verifies that exactly the specified number of bytes are read.
directDeserialiseBufChecked ::
  forall m a.
  DirectDeserialise a =>
  MonadST m =>
  MonadThrow m =>
  Ptr CChar ->
  Int ->
  m a
directDeserialiseBufChecked :: forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> m a
directDeserialiseBufChecked Ptr CChar
buf Int
srcsize = do
  (a
r, Int
bytesRead) <- Ptr CChar -> Int -> m (a, Int)
forall (m :: * -> *) a.
(DirectDeserialise a, MonadST m, MonadThrow m) =>
Ptr CChar -> Int -> m (a, Int)
directDeserialiseBuf Ptr CChar
buf Int
srcsize
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
bytesRead Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
srcsize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    Int -> Int -> m ()
forall (m :: * -> *). Int -> Int -> m ()
sizeCheckFailed Int
srcsize Int
bytesRead
  a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r