{-|

The memory subsystem associated with raaz.


__Warning:__ This module is pretty low level and should not be needed in typical
use cases. Only developers of protocols and primitives might have a
reason to look into this module.

-}

{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE CPP                        #-}

module Raaz.Core.Memory
       (
       -- * The Memory subsystem.
       -- $memorysubsystem$

       -- ** Memory elements.
         Memory(..), VoidMemory, copyMemory
       -- *** Initialisation and Extraction.
       -- $init-extract$
       , Initialisable(..), Extractable(..)
       , InitialisableFromBuffer(..), ExtractableToBuffer(..)
       -- *** A basic memory cell.
       , MemoryCell, withCellPointer, getCellPointer

       -- ** Memory threads.
       , MemoryThread(..), doIO , getMemory, modify, execute
       , MT
       -- **** Some low level `MT` actions.

       , liftPointerAction

       -- ** Memory allocation
       ,  Alloc, pointerAlloc
       ) where

import           Control.Applicative
import           Control.Monad.IO.Class

#if MIN_VERSION_base(4,9,0)
import           Data.Kind
#endif

import           Foreign.Storable            ( Storable )
import           Foreign.Ptr                 ( castPtr, Ptr )
import           Raaz.Core.MonoidalAction
import           Raaz.Core.Transfer
import           Raaz.Core.Types

-- $memorysubsystem$
--
-- Cryptographic operations often need to keep sensitive information
-- like private keys in its memory space. Such sensitive information
-- can leak to the external would if the memory where the data is
-- stored is swapped out to a disk. What makes this particularly
-- dangerous is that the data can reside on the disk almost
-- permanently and might even survive when the hardware is
-- scrapped. The primary purpose of the memory subsystem is to provide
-- a way to allocate and manage /secure memory/, i.e. memory that will
-- not be swapped out as long as the memory is used and will be wiped
-- clean after use. It consists of the following components:
--
-- [The `Memory` type class:] A memory element is some type that holds
-- an internal buffer inside it.
--
-- [The `Alloc` type:] Memory elements need to be allocated and this
-- is involves a lot of low lever pointer arithmetic. The `Alloc`
-- types gives a high level interface for memory allocation. For a
-- memory type `mem`, the type `Alloc mem` can be seen as the
-- _allocation strategy_ for mem. For example, one of the things that
-- it keeps track of is the space required to create an memory element
-- of type `mem`. There is a natural applicative instance for `Alloc`
-- which helps build the allocation strategy for a compound memory
-- type from its components in a modular fashion _without_ explicit
-- size calculation or offset computation.
--
-- [`MemoryThread`s:] Instances of this class are actions that use
-- some kind of memory elements inside it. Such a thread can be run
-- using the combinator `securely` or the combinator `insecurely`. If
-- one use the combinator `securely`, then the allocation of the
-- memory element to be used by the action is done using a locked
-- memory pool which is wiped clean before de-allocation.

-- $init-extract$
--
-- Memory elements often needs to be initialised. Similarly data needs
-- to be extracted out of memory. An instance declaration
-- @`Initialisable` mem a@ for the memory type @mem@ indicates that it
-- can be initialised with the pure value @a@. Similary, if values of
-- type @b@ can be extracted out of a memory element @mem@, we can
-- indicate it with an instance of @`Extractable` mem a@.
--
-- There is an inherent danger in initialising and extracting pure
-- values out of memory. Pure values are stored on the Haskell heap
-- and hence can be swapped out. Consider a memory element @mem@ that
-- stores some sensitive information, say for example the unencrypted
-- private key. Suppose we extract this key out of the memory element
-- as a pure value before its encryption and storage into the key
-- file. It is likely that the key is swapped out to the disk as the
-- extracted key is part of the the haskell heap.
--
-- The `InitialiseFromBuffer` (`ExtractableToBuffer`) class gives an
-- interface for reading from (writing to) buffers directly minimising
-- the chances of inadvertent exposure of sensitive information from
-- the Haskell heap due to swapping.


-- | An action of type @`MT` mem a@ is an action that uses internally
-- a single memory object of type @mem@ and returns a result of type
-- @a@. All the actions are performed on a single memory element and
-- hence the side effects persist. It is analogues to the @ST@ monad.
newtype MT mem a = MT { MT mem a -> mem -> IO a
unMT :: mem -> IO a }


instance Functor (MT mem) where
  fmap :: (a -> b) -> MT mem a -> MT mem b
fmap a -> b
f MT mem a
mst = (mem -> IO b) -> MT mem b
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO b) -> MT mem b) -> (mem -> IO b) -> MT mem b
forall a b. (a -> b) -> a -> b
$ \ mem
m -> a -> b
f (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT MT mem a
mst mem
m

instance Applicative (MT mem) where
  pure :: a -> MT mem a
pure       = (mem -> IO a) -> MT mem a
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO a) -> MT mem a) -> (a -> mem -> IO a) -> a -> MT mem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> mem -> IO a
forall a b. a -> b -> a
const (IO a -> mem -> IO a) -> (a -> IO a) -> a -> mem -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  MT mem (a -> b)
mf <*> :: MT mem (a -> b) -> MT mem a -> MT mem b
<*> MT mem a
ma  = (mem -> IO b) -> MT mem b
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO b) -> MT mem b) -> (mem -> IO b) -> MT mem b
forall a b. (a -> b) -> a -> b
$ \ mem
m -> MT mem (a -> b) -> mem -> IO (a -> b)
forall mem a. MT mem a -> mem -> IO a
unMT MT mem (a -> b)
mf mem
m IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT MT mem a
ma mem
m

instance Monad (MT mem) where
  return :: a -> MT mem a
return    =  (mem -> IO a) -> MT mem a
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO a) -> MT mem a) -> (a -> mem -> IO a) -> a -> MT mem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> mem -> IO a
forall a b. a -> b -> a
const (IO a -> mem -> IO a) -> (a -> IO a) -> a -> mem -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  MT mem a
ma >>= :: MT mem a -> (a -> MT mem b) -> MT mem b
>>= a -> MT mem b
f  =  (mem -> IO b) -> MT mem b
forall mem a. (mem -> IO a) -> MT mem a
MT mem -> IO b
runIt
    where runIt :: mem -> IO b
runIt mem
mem = MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT MT mem a
ma mem
mem IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
a -> MT mem b -> mem -> IO b
forall mem a. MT mem a -> mem -> IO a
unMT (a -> MT mem b
f a
a) mem
mem

-- | __WARNING:__ do not lift a secure memory action.
instance MonadIO (MT mem) where
  liftIO :: IO a -> MT mem a
liftIO = (mem -> IO a) -> MT mem a
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO a) -> MT mem a)
-> (IO a -> mem -> IO a) -> IO a -> MT mem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> mem -> IO a
forall a b. a -> b -> a
const

-- | A class that captures abstract "memory threads". A memory thread
-- can either be run `securely` or `insecurely`. Pure IO actions can
-- be run inside a memory thread using the @runIO@.  However, the IO
-- action that is being run /must not/ directly or indirectly run a
-- `secure` action ever. In particular, the following code is bad.
--
-- > -- BAD EXAMPLE: DO NOT USE.
-- > runIO $ securely $ foo
-- >
--
-- On the other hand the following code is fine
--
-- >
-- > runIO $ insecurely $ someMemoryAction
-- >
--
-- As to why this is dangerous, it has got to do with the fact that
-- @mlock@ and @munlock@ do not nest correctly. A single @munlock@ can
-- unlock multiple calls of @mlock@ on the same page.  Whether a given
-- @IO@ action unlocks memory is difficult to keep track of; for all
-- you know, it might be a FFI call that does an @memunlock@. Hence,
-- currently there is no easy way to enforce this.
--


#if MIN_VERSION_base(4,9,0)
class MemoryThread (mT :: Type -> Type -> Type) where
#else
class MemoryThread (mT :: * -> * -> *) where
#endif


  -- | Run a memory action with the internal memory allocated from a
  -- locked memory buffer. This memory buffer will never be swapped
  -- out by the operating system and will be wiped clean before
  -- releasing.
  --
  -- Memory locking is an expensive operation and usually there would be
  -- a limit to how much locked memory can be allocated. Nonetheless,
  -- actions that work with sensitive information like passwords should
  -- use this to run an memory action.
  securely   :: Memory mem => mT mem a -> IO a

  -- | Run a memory action with the internal memory used by the action
  -- being allocated from unlocked memory. Use this function when you
  -- work with data that is not sensitive to security considerations
  -- (for example, when you want to verify checksums of files).
  insecurely :: Memory mem => mT mem a -> IO a

  -- | Lift an actual memory thread.
  liftMT :: MT mem a -> mT mem a


  -- | Combinator that allows us to run a memory action on a
  -- sub-memory element. A sub-memory of @submem@ of a memory element
  -- @mem@ is given by a projection @proj : mem -> submem@. The action
  -- @onSubMemory proj@ lifts the a memory thread on the sub element
  -- to the compound element.
  --
  onSubMemory :: (mem -> submem) -> mT submem a -> mT mem a


instance MemoryThread MT where
  securely :: MT mem a -> IO a
securely               = (mem -> IO a) -> IO a
forall m a. Memory m => (m -> IO a) -> IO a
withSecureMemory ((mem -> IO a) -> IO a)
-> (MT mem a -> mem -> IO a) -> MT mem a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT
  insecurely :: MT mem a -> IO a
insecurely             = (mem -> IO a) -> IO a
forall m a. Memory m => (m -> IO a) -> IO a
withMemory ((mem -> IO a) -> IO a)
-> (MT mem a -> mem -> IO a) -> MT mem a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT
  liftMT :: MT mem a -> MT mem a
liftMT                 = MT mem a -> MT mem a
forall a. a -> a
id
  onSubMemory :: (mem -> submem) -> MT submem a -> MT mem a
onSubMemory mem -> submem
proj MT submem a
mtsub = (mem -> IO a) -> MT mem a
forall mem a. (mem -> IO a) -> MT mem a
MT ((mem -> IO a) -> MT mem a) -> (mem -> IO a) -> MT mem a
forall a b. (a -> b) -> a -> b
$ MT submem a -> submem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT MT submem a
mtsub (submem -> IO a) -> (mem -> submem) -> mem -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. mem -> submem
proj

------------- Lifting pointer actions -----------------------------

-- | Run a given memory action in the memory thread.
execute :: MemoryThread mT => (mem -> IO a) -> mT mem a
execute :: (mem -> IO a) -> mT mem a
execute = MT mem a -> mT mem a
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
MT mem a -> mT mem a
liftMT (MT mem a -> mT mem a)
-> ((mem -> IO a) -> MT mem a) -> (mem -> IO a) -> mT mem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (mem -> IO a) -> MT mem a
forall mem a. (mem -> IO a) -> MT mem a
MT

-- | Perform an IO action inside the memory thread.
doIO :: MemoryThread mT => IO a -> mT mem a
doIO :: IO a -> mT mem a
doIO = (mem -> IO a) -> mT mem a
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute ((mem -> IO a) -> mT mem a)
-> (IO a -> mem -> IO a) -> IO a -> mT mem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> mem -> IO a
forall a b. a -> b -> a
const

-- | A pointer action inside a monad @m@ is some function that takes a
-- pointer action of type @Pointer -> m a@ and supplies it with an
-- appropriate pointer. In particular, memory allocators are pointer
-- actions.
type PointerAction m a b = (Pointer -> m a) -> m b

-- | An IO allocator can be lifted to the memory thread level as follows.
liftPointerAction :: PointerAction IO a b -> PointerAction (MT mem) a b
liftPointerAction :: PointerAction IO a b -> PointerAction (MT mem) a b
liftPointerAction PointerAction IO a b
allocator Pointer -> MT mem a
mtAction
  = (mem -> IO b) -> MT mem b
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute ((mem -> IO b) -> MT mem b) -> (mem -> IO b) -> MT mem b
forall a b. (a -> b) -> a -> b
$ \ mem
mem -> PointerAction IO a b
allocator (\ Pointer
ptr -> MT mem a -> mem -> IO a
forall mem a. MT mem a -> mem -> IO a
unMT (Pointer -> MT mem a
mtAction Pointer
ptr) mem
mem)

-- TODO: This is a very general pattern needs more exploration.

-- | Get the underlying memory element of the memory thread.
getMemory :: MemoryThread mT => mT mem mem
getMemory :: mT mem mem
getMemory = (mem -> IO mem) -> mT mem mem
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute mem -> IO mem
forall (m :: * -> *) a. Monad m => a -> m a
return

------------------------ A memory allocator -----------------------


type AllocField = Field Pointer

-- | A memory allocator for the memory type @mem@. The `Applicative`
-- instance of @Alloc@ can be used to build allocations for
-- complicated memory elements from simpler ones.
type Alloc mem = TwistRF AllocField (BYTES Int) mem

-- | Make an allocator for a given memory type.
makeAlloc :: LengthUnit l => l -> (Pointer -> mem) -> Alloc mem
makeAlloc :: l -> (Pointer -> mem) -> Alloc mem
makeAlloc l
l Pointer -> mem
memCreate = WrappedArrow (->) Pointer mem -> BYTES Int -> Alloc mem
forall (f :: * -> *) m a. f a -> m -> TwistRF f m a
TwistRF ((Pointer -> mem) -> WrappedArrow (->) Pointer mem
forall (a :: * -> * -> *) b c. a b c -> WrappedArrow a b c
WrapArrow Pointer -> mem
memCreate) (BYTES Int -> Alloc mem) -> BYTES Int -> Alloc mem
forall a b. (a -> b) -> a -> b
$ l -> BYTES Int
forall src dest. (LengthUnit src, LengthUnit dest) => src -> dest
atLeast l
l

-- | Allocates a buffer of size @l@ and returns the pointer to it pointer.
pointerAlloc :: LengthUnit l => l -> Alloc Pointer
pointerAlloc :: l -> Alloc Pointer
pointerAlloc l
l = l -> (Pointer -> Pointer) -> Alloc Pointer
forall l mem. LengthUnit l => l -> (Pointer -> mem) -> Alloc mem
makeAlloc l
l Pointer -> Pointer
forall a. a -> a
id

---------------------------------------------------------------------

-- | Any cryptographic primitives use memory to store stuff. This
-- class abstracts all types that hold some memory. Cryptographic
-- application often requires securing the memory from being swapped
-- out (think of memory used to store private keys or passwords). This
-- abstraction supports memory securing. If your platform supports
-- memory locking, then securing a memory will prevent the memory from
-- being swapped to the disk. Once secured the memory location is
-- overwritten by nonsense before being freed.
--
-- While some basic memory elements like `MemoryCell` are exposed from
-- the library, often we require compound memory objects built out of
-- simpler ones. The `Applicative` instance of the `Alloc` can be made
-- use of in such situation to simplify such instance declaration as
-- illustrated in the instance declaration for a pair of memory
-- elements.
--
-- > instance (Memory ma, Memory mb) => Memory (ma, mb) where
-- >
-- >    memoryAlloc             = (,) <$> memoryAlloc <*> memoryAlloc
-- >
-- >    unsafeToPointer (ma, _) =  unsafeToPointer ma
--
class Memory m where

  -- | Returns an allocator for this memory.
  memoryAlloc     :: Alloc m

  -- | Returns the pointer to the underlying buffer.
  unsafeToPointer :: m -> Pointer

-- | A memory element that holds nothing.
data VoidMemory = VoidMemory { VoidMemory -> Pointer
unVoidMemory :: Pointer  }

instance Memory VoidMemory where
  memoryAlloc :: Alloc VoidMemory
memoryAlloc      = BYTES Int -> (Pointer -> VoidMemory) -> Alloc VoidMemory
forall l mem. LengthUnit l => l -> (Pointer -> mem) -> Alloc mem
makeAlloc (BYTES Int
0 :: BYTES Int) Pointer -> VoidMemory
VoidMemory
  unsafeToPointer :: VoidMemory -> Pointer
unsafeToPointer  = VoidMemory -> Pointer
unVoidMemory


instance ( Memory ma, Memory mb ) => Memory (ma, mb) where
    memoryAlloc :: Alloc (ma, mb)
memoryAlloc             = (,) (ma -> mb -> (ma, mb))
-> TwistRF AllocField (BYTES Int) ma
-> TwistRF AllocField (BYTES Int) (mb -> (ma, mb))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) ma
forall m. Memory m => Alloc m
memoryAlloc TwistRF AllocField (BYTES Int) (mb -> (ma, mb))
-> TwistRF AllocField (BYTES Int) mb -> Alloc (ma, mb)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) mb
forall m. Memory m => Alloc m
memoryAlloc
    unsafeToPointer :: (ma, mb) -> Pointer
unsafeToPointer (ma
ma, mb
_) =  ma -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer ma
ma

instance ( Memory ma
         , Memory mb
         , Memory mc
         )
         => Memory (ma, mb, mc) where
  memoryAlloc :: Alloc (ma, mb, mc)
memoryAlloc              = (,,)
                             (ma -> mb -> mc -> (ma, mb, mc))
-> TwistRF AllocField (BYTES Int) ma
-> TwistRF AllocField (BYTES Int) (mb -> mc -> (ma, mb, mc))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) ma
forall m. Memory m => Alloc m
memoryAlloc
                             TwistRF AllocField (BYTES Int) (mb -> mc -> (ma, mb, mc))
-> TwistRF AllocField (BYTES Int) mb
-> TwistRF AllocField (BYTES Int) (mc -> (ma, mb, mc))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) mb
forall m. Memory m => Alloc m
memoryAlloc
                             TwistRF AllocField (BYTES Int) (mc -> (ma, mb, mc))
-> TwistRF AllocField (BYTES Int) mc -> Alloc (ma, mb, mc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) mc
forall m. Memory m => Alloc m
memoryAlloc
  unsafeToPointer :: (ma, mb, mc) -> Pointer
unsafeToPointer (ma
ma,mb
_,mc
_) =  ma -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer ma
ma

instance ( Memory ma
         , Memory mb
         , Memory mc
         , Memory md
         )
         => Memory (ma, mb, mc, md) where
  memoryAlloc :: Alloc (ma, mb, mc, md)
memoryAlloc                = (,,,)
                               (ma -> mb -> mc -> md -> (ma, mb, mc, md))
-> TwistRF AllocField (BYTES Int) ma
-> TwistRF
     AllocField (BYTES Int) (mb -> mc -> md -> (ma, mb, mc, md))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) ma
forall m. Memory m => Alloc m
memoryAlloc
                               TwistRF AllocField (BYTES Int) (mb -> mc -> md -> (ma, mb, mc, md))
-> TwistRF AllocField (BYTES Int) mb
-> TwistRF AllocField (BYTES Int) (mc -> md -> (ma, mb, mc, md))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) mb
forall m. Memory m => Alloc m
memoryAlloc
                               TwistRF AllocField (BYTES Int) (mc -> md -> (ma, mb, mc, md))
-> TwistRF AllocField (BYTES Int) mc
-> TwistRF AllocField (BYTES Int) (md -> (ma, mb, mc, md))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) mc
forall m. Memory m => Alloc m
memoryAlloc
                               TwistRF AllocField (BYTES Int) (md -> (ma, mb, mc, md))
-> TwistRF AllocField (BYTES Int) md -> Alloc (ma, mb, mc, md)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) md
forall m. Memory m => Alloc m
memoryAlloc

  unsafeToPointer :: (ma, mb, mc, md) -> Pointer
unsafeToPointer (ma
ma,mb
_,mc
_,md
_) =  ma -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer ma
ma

-- | Copy data from a given memory location to the other. The first
-- argument is destionation and the second argument is source to match
-- with the convention followed in memcpy.
copyMemory :: Memory m => Dest m -- ^ Destination
                       -> Src  m -- ^ Source
                       -> IO ()
copyMemory :: Dest m -> Src m -> IO ()
copyMemory Dest m
dmem Src m
smem = Dest Pointer -> Src Pointer -> BYTES Int -> IO ()
forall (m :: * -> *) l.
(MonadIO m, LengthUnit l) =>
Dest Pointer -> Src Pointer -> l -> m ()
memcpy (m -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer (m -> Pointer) -> Dest m -> Dest Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dest m
dmem) (m -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer (m -> Pointer) -> Src m -> Src Pointer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Src m
smem) BYTES Int
sz
  where sz :: BYTES Int
sz       = TwistRF AllocField (BYTES Int) m -> BYTES Int
forall (f :: * -> *) m a. TwistRF f m a -> m
twistMonoidValue (TwistRF AllocField (BYTES Int) m -> BYTES Int)
-> TwistRF AllocField (BYTES Int) m -> BYTES Int
forall a b. (a -> b) -> a -> b
$ Src m -> TwistRF AllocField (BYTES Int) m
forall m. Memory m => Src m -> Alloc m
getAlloc Src m
smem
        getAlloc :: Memory m => Src m -> Alloc m
        getAlloc :: Src m -> Alloc m
getAlloc Src m
_ = Alloc m
forall m. Memory m => Alloc m
memoryAlloc

-- | Perform an action which makes use of this memory. The memory
-- allocated will automatically be freed when the action finishes
-- either gracefully or with some exception. Besides being safer,
-- this method might be more efficient as the memory might be
-- allocated from the stack directly and will have very little GC
-- overhead.
withMemory   :: Memory m => (m -> IO a) -> IO a
withMemory :: (m -> IO a) -> IO a
withMemory   = Alloc m -> (m -> IO a) -> IO a
forall m a. Alloc m -> (m -> IO a) -> IO a
withM Alloc m
forall m. Memory m => Alloc m
memoryAlloc
  where withM :: Alloc m -> (m -> IO a) -> IO a
        withM :: Alloc m -> (m -> IO a) -> IO a
withM Alloc m
alctr m -> IO a
action = BYTES Int -> (Pointer -> IO a) -> IO a
forall l b. LengthUnit l => l -> (Pointer -> IO b) -> IO b
allocaBuffer BYTES Int
sz Pointer -> IO a
actualAction
          where sz :: BYTES Int
sz                 = Alloc m -> BYTES Int
forall (f :: * -> *) m a. TwistRF f m a -> m
twistMonoidValue Alloc m
alctr
                getM :: Pointer -> m
getM               = Field Pointer m -> Pointer -> m
forall space b. Field space b -> space -> b
computeField (Field Pointer m -> Pointer -> m)
-> Field Pointer m -> Pointer -> m
forall a b. (a -> b) -> a -> b
$ Alloc m -> Field Pointer m
forall (f :: * -> *) m a. TwistRF f m a -> f a
twistFunctorValue Alloc m
alctr
                wipeIt :: Pointer -> IO ()
wipeIt Pointer
cptr        = Pointer -> Word8 -> BYTES Int -> IO ()
forall (m :: * -> *) l.
(MonadIO m, LengthUnit l) =>
Pointer -> Word8 -> l -> m ()
memset Pointer
cptr Word8
0 BYTES Int
sz
                actualAction :: Pointer -> IO a
actualAction  Pointer
cptr = m -> IO a
action (Pointer -> m
getM Pointer
cptr) IO a -> IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Pointer -> IO ()
wipeIt Pointer
cptr


-- | Similar to `withMemory` but allocates a secure memory for the
-- action. Secure memories are never swapped on to disk and will be
-- wiped clean of sensitive data after use. However, be careful when
-- using this function in a child thread. Due to the daemonic nature
-- of Haskell threads, if the main thread exists before the child
-- thread is done with its job, sensitive data can leak. This is
-- essentially a limitation of the bracket which is used internally.
withSecureMemory :: Memory m => (m -> IO a) -> IO a
withSecureMemory :: (m -> IO a) -> IO a
withSecureMemory = TwistRF AllocField (BYTES Int) m -> (m -> IO a) -> IO a
forall l b b.
LengthUnit l =>
TwistRF AllocField l b -> (b -> IO b) -> IO b
withSM TwistRF AllocField (BYTES Int) m
forall m. Memory m => Alloc m
memoryAlloc
  where -- withSM :: Memory m => Alloc m -> (m -> IO a) -> IO a
        withSM :: TwistRF AllocField l b -> (b -> IO b) -> IO b
withSM TwistRF AllocField l b
alctr b -> IO b
action = l -> (Pointer -> IO b) -> IO b
forall l b. LengthUnit l => l -> (Pointer -> IO b) -> IO b
allocaSecure l
sz ((Pointer -> IO b) -> IO b) -> (Pointer -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ b -> IO b
action (b -> IO b) -> (Pointer -> b) -> Pointer -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> b
getM
          where sz :: l
sz     = TwistRF AllocField l b -> l
forall (f :: * -> *) m a. TwistRF f m a -> m
twistMonoidValue TwistRF AllocField l b
alctr
                getM :: Pointer -> b
getM   = Field Pointer b -> Pointer -> b
forall space b. Field space b -> space -> b
computeField (Field Pointer b -> Pointer -> b)
-> Field Pointer b -> Pointer -> b
forall a b. (a -> b) -> a -> b
$ TwistRF AllocField l b -> Field Pointer b
forall (f :: * -> *) m a. TwistRF f m a -> f a
twistFunctorValue TwistRF AllocField l b
alctr


----------------------- Initialising and Extracting stuff ----------------------

-- | Memories that can be initialised with a pure value. The pure
-- value resides in the Haskell heap and hence can potentially be
-- swapped. Therefore, this class should be avoided if compromising
-- the initialisation value can be dangerous. Consider using
-- `InitialiseableFromBuffer`
--

class Memory m => Initialisable m v where
  initialise :: v -> MT m ()

-- | Memories from which pure values can be extracted. Once a pure value is
-- extracted,
class Memory m => Extractable m v where
  extract  :: MT m v


-- | Apply the given function to the value in the cell. For a function @f :: b -> a@,
-- the action @modify f@ first extracts a value of type @b@ from the
-- memory element, applies @f@ to it and puts the result back into the
-- memory.
--
-- > modify f = do b          <- extract
-- >               initialise $  f b
--
modify :: (Initialisable mem a, Extractable mem b, MemoryThread mT ) =>  (b -> a) -> mT mem ()
modify :: (b -> a) -> mT mem ()
modify b -> a
f = MT mem () -> mT mem ()
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
MT mem a -> mT mem a
liftMT (MT mem () -> mT mem ()) -> MT mem () -> mT mem ()
forall a b. (a -> b) -> a -> b
$ MT mem b
forall m v. Extractable m v => MT m v
extract MT mem b -> (b -> MT mem ()) -> MT mem ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> MT mem ()
forall m v. Initialisable m v => v -> MT m ()
initialise (a -> MT mem ()) -> (b -> a) -> b -> MT mem ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f

-- | A memory type that can be initialised from a pointer buffer. The initialisation performs
-- a direct copy from the input buffer and hence the chances of the
-- initialisation value ending up in the swap is minimised.
class Memory m => InitialisableFromBuffer m where
  initialiser :: m -> ReadM (MT m)

-- | A memory type that can extract bytes into a buffer. The extraction will perform
-- a direct copy and hence the chances of the extracted value ending
-- up in the swap space is minimised.
class Memory m => ExtractableToBuffer m where
  extractor :: m -> WriteM (MT m)

--------------------- Some instances of Memory --------------------

-- | A memory location to store a value of type having `Storable`
-- instance.
newtype MemoryCell a = MemoryCell { MemoryCell a -> Ptr a
unMemoryCell :: Ptr a }


instance Storable a => Memory (MemoryCell a) where

  memoryAlloc :: Alloc (MemoryCell a)
memoryAlloc = a -> Alloc (MemoryCell a)
forall b. Storable b => b -> Alloc (MemoryCell b)
allocator a
forall a. HasCallStack => a
undefined
    where allocator :: Storable b => b -> Alloc (MemoryCell b)
          allocator :: b -> Alloc (MemoryCell b)
allocator b
b = ALIGN -> (Pointer -> MemoryCell b) -> Alloc (MemoryCell b)
forall l mem. LengthUnit l => l -> (Pointer -> mem) -> Alloc mem
makeAlloc (b -> ALIGN
forall a. Storable a => a -> ALIGN
alignedSizeOf b
b) ((Pointer -> MemoryCell b) -> Alloc (MemoryCell b))
-> (Pointer -> MemoryCell b) -> Alloc (MemoryCell b)
forall a b. (a -> b) -> a -> b
$ Ptr b -> MemoryCell b
forall a. Ptr a -> MemoryCell a
MemoryCell (Ptr b -> MemoryCell b)
-> (Pointer -> Ptr b) -> Pointer -> MemoryCell b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Ptr b
forall a b. Ptr a -> Ptr b
castPtr

  unsafeToPointer :: MemoryCell a -> Pointer
unsafeToPointer  = Ptr a -> Pointer
forall a b. Ptr a -> Ptr b
castPtr (Ptr a -> Pointer)
-> (MemoryCell a -> Ptr a) -> MemoryCell a -> Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. MemoryCell a -> Ptr a
unMemoryCell

-- | The location where the actual storing of element happens. This
-- pointer is guaranteed to be aligned to the alignment restriction of @a@
actualCellPtr :: Storable a => MemoryCell a -> Ptr a
actualCellPtr :: MemoryCell a -> Ptr a
actualCellPtr = Ptr a -> Ptr a
forall a. Storable a => Ptr a -> Ptr a
nextAlignedPtr (Ptr a -> Ptr a)
-> (MemoryCell a -> Ptr a) -> MemoryCell a -> Ptr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. MemoryCell a -> Ptr a
unMemoryCell

-- | Work with the underlying pointer of the memory cell. Useful while
-- working with ffi functions.
withCellPointer :: (MemoryThread mT, Storable a) => (Ptr a -> IO b) -> mT (MemoryCell a) b
{-# INLINE withCellPointer #-}
withCellPointer :: (Ptr a -> IO b) -> mT (MemoryCell a) b
withCellPointer Ptr a -> IO b
action = (MemoryCell a -> IO b) -> mT (MemoryCell a) b
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute ((MemoryCell a -> IO b) -> mT (MemoryCell a) b)
-> (MemoryCell a -> IO b) -> mT (MemoryCell a) b
forall a b. (a -> b) -> a -> b
$ Ptr a -> IO b
action (Ptr a -> IO b) -> (MemoryCell a -> Ptr a) -> MemoryCell a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. Storable a => MemoryCell a -> Ptr a
actualCellPtr


-- | Get the pointer associated with the given memory cell.
getCellPointer :: (MemoryThread mT, Storable a) => mT (MemoryCell a) (Ptr a)
{-# INLINE getCellPointer #-}
getCellPointer :: mT (MemoryCell a) (Ptr a)
getCellPointer = MT (MemoryCell a) (Ptr a) -> mT (MemoryCell a) (Ptr a)
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
MT mem a -> mT mem a
liftMT (MT (MemoryCell a) (Ptr a) -> mT (MemoryCell a) (Ptr a))
-> MT (MemoryCell a) (Ptr a) -> mT (MemoryCell a) (Ptr a)
forall a b. (a -> b) -> a -> b
$ MemoryCell a -> Ptr a
forall a. Storable a => MemoryCell a -> Ptr a
actualCellPtr (MemoryCell a -> Ptr a)
-> MT (MemoryCell a) (MemoryCell a) -> MT (MemoryCell a) (Ptr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MT (MemoryCell a) (MemoryCell a)
forall (mT :: * -> * -> *) mem. MemoryThread mT => mT mem mem
getMemory

instance Storable a => Initialisable (MemoryCell a) a where
  initialise :: a -> MT (MemoryCell a) ()
initialise a
a = (MemoryCell a -> IO ()) -> MT (MemoryCell a) ()
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute ((MemoryCell a -> IO ()) -> MT (MemoryCell a) ())
-> (MemoryCell a -> IO ()) -> MT (MemoryCell a) ()
forall a b. (a -> b) -> a -> b
$ (Ptr a -> a -> IO ()) -> a -> Ptr a -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
pokeAligned a
a (Ptr a -> IO ())
-> (MemoryCell a -> Ptr a) -> MemoryCell a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. MemoryCell a -> Ptr a
unMemoryCell
  {-# INLINE initialise #-}

instance Storable a => Extractable (MemoryCell a) a where
  extract :: MT (MemoryCell a) a
extract = (MemoryCell a -> IO a) -> MT (MemoryCell a) a
forall (mT :: * -> * -> *) mem a.
MemoryThread mT =>
(mem -> IO a) -> mT mem a
execute ((MemoryCell a -> IO a) -> MT (MemoryCell a) a)
-> (MemoryCell a -> IO a) -> MT (MemoryCell a) a
forall a b. (a -> b) -> a -> b
$ Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peekAligned (Ptr a -> IO a) -> (MemoryCell a -> Ptr a) -> MemoryCell a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. MemoryCell a -> Ptr a
unMemoryCell
  {-# INLINE extract #-}

instance EndianStore a => InitialisableFromBuffer (MemoryCell a) where
  initialiser :: MemoryCell a -> ReadM (MT (MemoryCell a))
initialiser  = Int -> Dest (Ptr a) -> ReadM (MT (MemoryCell a))
forall a (m :: * -> *).
(EndianStore a, MonadIO m) =>
Int -> Dest (Ptr a) -> ReadM m
readInto Int
1 (Dest (Ptr a) -> ReadM (MT (MemoryCell a)))
-> (MemoryCell a -> Dest (Ptr a))
-> MemoryCell a
-> ReadM (MT (MemoryCell a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Dest (Ptr a)
forall a. a -> Dest a
destination (Ptr a -> Dest (Ptr a))
-> (MemoryCell a -> Ptr a) -> MemoryCell a -> Dest (Ptr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. Storable a => MemoryCell a -> Ptr a
actualCellPtr

instance EndianStore a => ExtractableToBuffer (MemoryCell a) where
  extractor :: MemoryCell a -> WriteM (MT (MemoryCell a))
extractor  = Int -> Src (Ptr a) -> WriteM (MT (MemoryCell a))
forall (m :: * -> *) a.
(MonadIO m, EndianStore a) =>
Int -> Src (Ptr a) -> WriteM m
writeFrom Int
1 (Src (Ptr a) -> WriteM (MT (MemoryCell a)))
-> (MemoryCell a -> Src (Ptr a))
-> MemoryCell a
-> WriteM (MT (MemoryCell a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Src (Ptr a)
forall a. a -> Src a
source (Ptr a -> Src (Ptr a))
-> (MemoryCell a -> Ptr a) -> MemoryCell a -> Src (Ptr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MemoryCell a -> Ptr a
forall a. Storable a => MemoryCell a -> Ptr a
actualCellPtr