{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Crypto.Libsodium.Memory.Internal (
  -- * High-level memory management
  MLockedForeignPtr (..),
  withMLockedForeignPtr,
  finalizeMLockedForeignPtr,
  traceMLockedForeignPtr,

  -- * MLocked allocations
  mlockedMalloc,
  MLockedAllocator (..),
  mlockedAlloca,
  mlockedAllocaSized,
  mlockedAllocForeignPtr,
  mlockedAllocForeignPtrBytes,

  -- * Allocations using an explicit allocator
  mlockedAllocaWith,
  mlockedAllocaSizedWith,
  mlockedAllocForeignPtrWith,
  mlockedAllocForeignPtrBytesWith,

  -- * 'ForeignPtr' operations, generalized to 'MonadST'
  ForeignPtr (..),
  mallocForeignPtrBytes,
  withForeignPtr,

  -- * Unmanaged memory, generalized to 'MonadST'
  zeroMem,
  copyMem,
  allocaBytes,

  -- * ByteString memory access, generalized to 'MonadST'
  unpackByteStringCStringLen,
  packByteStringCStringLen,

  -- * Helper
  unsafeIOToMonadST,
) where

import Control.DeepSeq (NFData (..), rwhnf)
import Control.Exception (Exception, mask_)
import Control.Monad (void, when)
import Control.Monad.Class.MonadST (MonadST, stToIO)
import Control.Monad.Class.MonadThrow (MonadThrow (bracket))
import Control.Monad.Primitive (touch)
import Control.Monad.ST (RealWorld, ST)
import Control.Monad.ST.Unsafe (unsafeIOToST)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Coerce (coerce)
import Data.Kind
import Data.Typeable
import Debug.Trace (traceShowM)
import Foreign.C.Error (errnoToIOError, getErrno)
import Foreign.C.String (CStringLen)
import Foreign.C.Types (CSize (..))
import qualified Foreign.Concurrent as Foreign
import qualified Foreign.ForeignPtr as Foreign hiding (newForeignPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import qualified Foreign.ForeignPtr.Unsafe as Foreign
import Foreign.Marshal.Utils (fillBytes)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (Storable (peek), alignment, sizeOf)
import GHC.IO.Exception (ioException)
import GHC.TypeLits (KnownNat, natVal)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import System.IO.Unsafe (unsafePerformIO)

import Cardano.Crypto.Libsodium.C
import Cardano.Foreign (SizedPtr (..), c_memcpy, c_memset)
import Cardano.Memory.Pool (Pool, grabNextBlock, initPool)

-- | Foreign pointer to securely allocated memory.
newtype MLockedForeignPtr a = SFP {forall a. MLockedForeignPtr a -> ForeignPtr a
_unwrapMLockedForeignPtr :: Foreign.ForeignPtr a}
  deriving (Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
Proxy (MLockedForeignPtr a) -> String
forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
forall a. Proxy (MLockedForeignPtr a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MLockedForeignPtr a) -> String
$cshowTypeOf :: forall a. Proxy (MLockedForeignPtr a) -> String
wNoThunks :: Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
noThunks :: Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a. Context -> MLockedForeignPtr a -> IO (Maybe ThunkInfo)
NoThunks) via OnlyCheckWhnfNamed "MLockedForeignPtr" (MLockedForeignPtr a)

instance NFData (MLockedForeignPtr a) where
  rnf :: MLockedForeignPtr a -> ()
rnf = forall a. a -> ()
rwhnf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MLockedForeignPtr a -> ForeignPtr a
_unwrapMLockedForeignPtr

withMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr :: forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr (SFP ForeignPtr a
fptr) Ptr a -> m b
f = do
  b
r <- Ptr a -> m b
f (forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr ForeignPtr a
fptr)
  b
r forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (forall a. ForeignPtr a -> IO ()
Foreign.touchForeignPtr ForeignPtr a
fptr)

finalizeMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr :: forall (m :: * -> *) a. MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr (SFP ForeignPtr a
fptr) =
  forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall a b. (a -> b) -> a -> b
$ forall a. ForeignPtr a -> IO ()
Foreign.finalizeForeignPtr ForeignPtr a
fptr

{-# WARNING traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-}
traceMLockedForeignPtr :: (Storable a, Show a, MonadST m) => MLockedForeignPtr a -> m ()
traceMLockedForeignPtr :: forall a (m :: * -> *).
(Storable a, Show a, MonadST m) =>
MLockedForeignPtr a -> m ()
traceMLockedForeignPtr MLockedForeignPtr a
fptr = forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr MLockedForeignPtr a
fptr forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
  a
a <- forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr)
  forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM a
a

unsafeIOToMonadST :: MonadST m => IO a -> m a
unsafeIOToMonadST :: forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST = forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. IO a -> ST s a
unsafeIOToST

makeMLockedPool :: forall n s. KnownNat n => ST s (Pool n s)
makeMLockedPool :: forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool = do
  forall (n :: Nat) s.
KnownNat n =>
Int
-> (forall a. Int -> ST s (ForeignPtr a))
-> (Ptr (Block n) -> IO ())
-> ST s (Pool n s)
initPool
    (forall a. Ord a => a -> a -> a
max Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Integer
4096 forall a. Integral a => a -> a -> a
`div` forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n) forall a. Integral a => a -> a -> a
`div` Integer
64)
    ( \Int
size -> forall a s. IO a -> ST s a
unsafeIOToST forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
        Ptr a
ptr <- forall a. CSize -> IO (Ptr a)
sodiumMalloc (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size)
        forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Foreign.newForeignPtr Ptr a
ptr (forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size))
    )
    ( \Ptr (Block n)
ptr -> do
        forall (n :: Nat) a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem (forall {k} (t :: k). Proxy t
Proxy @n) Ptr (Block n)
ptr
    )

eraseMem :: forall n a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem :: forall (n :: Nat) a. KnownNat n => Proxy n -> Ptr a -> IO ()
eraseMem Proxy n
proxy Ptr a
ptr = forall a. Ptr a -> Word8 -> Int -> IO ()
fillBytes Ptr a
ptr Word8
0xff (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 -> Integer
natVal Proxy n
proxy)

mlockedPool32 :: Pool 32 RealWorld
mlockedPool32 :: Pool 32 RealWorld
mlockedPool32 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool32 #-}

mlockedPool64 :: Pool 64 RealWorld
mlockedPool64 :: Pool 64 RealWorld
mlockedPool64 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool64 #-}

mlockedPool128 :: Pool 128 RealWorld
mlockedPool128 :: Pool 128 RealWorld
mlockedPool128 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool128 #-}

mlockedPool256 :: Pool 256 RealWorld
mlockedPool256 :: Pool 256 RealWorld
mlockedPool256 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool256 #-}

mlockedPool512 :: Pool 512 RealWorld
mlockedPool512 :: Pool 512 RealWorld
mlockedPool512 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall (n :: Nat) s. KnownNat n => ST s (Pool n s)
makeMLockedPool
{-# NOINLINE mlockedPool512 #-}

data AllocatorException
  = AllocatorNoTracer
  | AllocatorNoGenerator
  deriving (Int -> AllocatorException -> ShowS
[AllocatorException] -> ShowS
AllocatorException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllocatorException] -> ShowS
$cshowList :: [AllocatorException] -> ShowS
show :: AllocatorException -> String
$cshow :: AllocatorException -> String
showsPrec :: Int -> AllocatorException -> ShowS
$cshowsPrec :: Int -> AllocatorException -> ShowS
Show)

instance Exception AllocatorException

mlockedMalloc :: MonadST m => MLockedAllocator m
mlockedMalloc :: forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc =
  MLockedAllocator {mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate = forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO}

mlockedMallocIO :: CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO :: forall a. CSize -> IO (MLockedForeignPtr a)
mlockedMallocIO CSize
size =
  forall a. ForeignPtr a -> MLockedForeignPtr a
SFP forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    if
      | CSize
size forall a. Ord a => a -> a -> Bool
<= CSize
32 -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 32 RealWorld
mlockedPool32
      | CSize
size forall a. Ord a => a -> a -> Bool
<= CSize
64 -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 64 RealWorld
mlockedPool64
      | CSize
size forall a. Ord a => a -> a -> Bool
<= CSize
128 -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 128 RealWorld
mlockedPool128
      | CSize
size forall a. Ord a => a -> a -> Bool
<= CSize
256 -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 256 RealWorld
mlockedPool256
      | CSize
size forall a. Ord a => a -> a -> Bool
<= CSize
512 -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) s.
KnownNat n =>
Pool n s -> ST s (ForeignPtr (Block n))
grabNextBlock Pool 512 RealWorld
mlockedPool512
      | Bool
otherwise -> do
          forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
            Ptr a
ptr <- forall a. CSize -> IO (Ptr a)
sodiumMalloc CSize
size
            forall a. Ptr a -> IO () -> IO (ForeignPtr a)
Foreign.newForeignPtr Ptr a
ptr forall a b. (a -> b) -> a -> b
$ do
              forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr CSize
size

sodiumMalloc :: CSize -> IO (Ptr a)
sodiumMalloc :: forall a. CSize -> IO (Ptr a)
sodiumMalloc CSize
size = do
  Ptr a
ptr <- forall a. CSize -> IO (Ptr a)
c_sodium_malloc CSize
size
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr a
ptr forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr) forall a b. (a -> b) -> a -> b
$ do
    Errno
errno <- IO Errno
getErrno
    forall a. IOException -> IO a
ioException forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_malloc" Errno
errno forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  CInt
res <- forall a. Ptr a -> CSize -> IO CInt
c_sodium_mlock Ptr a
ptr CSize
size
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res forall a. Eq a => a -> a -> Bool
/= CInt
0) forall a b. (a -> b) -> a -> b
$ do
    Errno
errno <- IO Errno
getErrno
    forall a. IOException -> IO a
ioException forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_mlock" Errno
errno forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr

sodiumFree :: Ptr a -> CSize -> IO ()
sodiumFree :: forall a. Ptr a -> CSize -> IO ()
sodiumFree Ptr a
ptr CSize
size = do
  CInt
res <- forall a. Ptr a -> CSize -> IO CInt
c_sodium_munlock Ptr a
ptr CSize
size
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
res forall a. Eq a => a -> a -> Bool
/= CInt
0) forall a b. (a -> b) -> a -> b
$ do
    Errno
errno <- IO Errno
getErrno
    forall a. IOException -> IO a
ioException forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOException
errnoToIOError String
"c_sodium_munlock" Errno
errno forall a. Maybe a
Nothing forall a. Maybe a
Nothing
  forall a. Ptr a -> IO ()
c_sodium_free Ptr a
ptr

zeroMem :: MonadST m => Ptr a -> CSize -> m ()
zeroMem :: forall (m :: * -> *) a. MonadST m => Ptr a -> CSize -> m ()
zeroMem Ptr a
ptr CSize
size = forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> Int -> CSize -> IO (Ptr ())
c_memset (forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
0 CSize
size

copyMem :: MonadST m => Ptr a -> Ptr a -> CSize -> m ()
copyMem :: forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem Ptr a
dst Ptr a
src CSize
size = forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> Ptr a -> CSize -> IO (Ptr ())
c_memcpy (forall a b. Ptr a -> Ptr b
castPtr Ptr a
dst) (forall a b. Ptr a -> Ptr b
castPtr Ptr a
src) CSize
size

-- | A 'ForeignPtr' type, generalized to 'MonadST'. The type is tagged with
-- the correct Monad @m@ in order to ensure that foreign pointers created in
-- one ST context can only be used within the same ST context.
newtype ForeignPtr (m :: Type -> Type) a = ForeignPtr {forall (m :: * -> *) a. ForeignPtr m a -> ForeignPtr a
unsafeRawForeignPtr :: Foreign.ForeignPtr a}

mallocForeignPtrBytes :: MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes :: forall (m :: * -> *) a. MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes Int
size =
  forall (m :: * -> *) a. ForeignPtr a -> ForeignPtr m a
ForeignPtr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST (forall a. Int -> IO (ForeignPtr a)
Foreign.mallocForeignPtrBytes Int
size)

-- | 'Foreign.withForeignPtr', generalized to 'MonadST'.
-- Caveat: if the monadic action passed to 'withForeignPtr' does not terminate
-- (e.g., 'forever'), the 'ForeignPtr' finalizer may run prematurely.
withForeignPtr :: MonadST m => ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr :: forall (m :: * -> *) a b.
MonadST m =>
ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr (ForeignPtr ForeignPtr a
fptr) Ptr a -> m b
f = do
  b
result <- Ptr a -> m b
f forall a b. (a -> b) -> a -> b
$ forall a. ForeignPtr a -> Ptr a
Foreign.unsafeForeignPtrToPtr ForeignPtr a
fptr
  forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch ForeignPtr a
fptr
  forall (m :: * -> *) a. Monad m => a -> m a
return b
result

allocaBytes :: (MonadThrow m, MonadST m) => Int -> (Ptr a -> m b) -> m b
allocaBytes :: forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
size Ptr a -> m b
action = do
  ForeignPtr m a
fptr <- forall (m :: * -> *) a. MonadST m => Int -> m (ForeignPtr m a)
mallocForeignPtrBytes Int
size
  forall (m :: * -> *) a b.
MonadST m =>
ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr ForeignPtr m a
fptr Ptr a -> m b
action

-- | Unpacks a ByteString into a temporary buffer and runs the provided 'ST'
-- function on it.
unpackByteStringCStringLen :: (MonadThrow m, MonadST m) => ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen :: forall (m :: * -> *) a.
(MonadThrow m, MonadST m) =>
ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen ByteString
bs CStringLen -> m a
f = do
  let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
  forall (m :: * -> *) a b.
(MonadThrow m, MonadST m) =>
Int -> (Ptr a -> m b) -> m b
allocaBytes Int
len forall a b. (a -> b) -> a -> b
$ \Ptr CChar
buf -> do
    forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall a b. (a -> b) -> a -> b
$ forall a. ByteString -> (Ptr CChar -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs forall a b. (a -> b) -> a -> b
$ \Ptr CChar
ptr -> do
      forall (m :: * -> *) a.
MonadST m =>
Ptr a -> Ptr a -> CSize -> m ()
copyMem Ptr CChar
buf Ptr CChar
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
    CStringLen -> m a
f (Ptr CChar
buf, Int
len)

packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString
packByteStringCStringLen :: forall (m :: * -> *). MonadST m => CStringLen -> m ByteString
packByteStringCStringLen =
  forall (m :: * -> *) a. MonadST m => IO a -> m a
unsafeIOToMonadST forall b c a. (b -> c) -> (a -> b) -> a -> c
. CStringLen -> IO ByteString
BS.packCStringLen

newtype MLockedAllocator m
  = MLockedAllocator
  { forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a)
  }

mlockedAllocaSized ::
  forall m n b. (MonadST m, MonadThrow m, KnownNat n) => (SizedPtr n -> m b) -> m b
mlockedAllocaSized :: forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
(SizedPtr n -> m b) -> m b
mlockedAllocaSized = forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
MLockedAllocator m -> (SizedPtr n -> m b) -> m b
mlockedAllocaSizedWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedAllocaSizedWith ::
  forall m n b.
  (MonadST m, MonadThrow m, KnownNat n) =>
  MLockedAllocator m ->
  (SizedPtr n -> m b) ->
  m b
mlockedAllocaSizedWith :: forall (m :: * -> *) (n :: Nat) b.
(MonadST m, MonadThrow m, KnownNat n) =>
MLockedAllocator m -> (SizedPtr n -> m b) -> m b
mlockedAllocaSizedWith MLockedAllocator m
allocator SizedPtr n -> m b
k = forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith MLockedAllocator m
allocator CSize
size (SizedPtr n -> m b
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr)
  where
    size :: CSize
    size :: CSize
size = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @n))

mlockedAllocForeignPtrBytes :: MonadST m => CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytes :: forall (m :: * -> *) a.
MonadST m =>
CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytes = forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedAllocForeignPtrBytesWith :: MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith :: forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith MLockedAllocator m
_ CSize
_ CSize
0 =
  forall a. HasCallStack => String -> a
error String
"Zero alignment"
mlockedAllocForeignPtrBytesWith MLockedAllocator m
allocator CSize
size CSize
align = do
  forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator m
allocator CSize
size'
  where
    size' :: CSize
    size' :: CSize
size'
      | CSize
m forall a. Eq a => a -> a -> Bool
== CSize
0 = CSize
size
      | Bool
otherwise = (CSize
q forall a. Num a => a -> a -> a
+ CSize
1) forall a. Num a => a -> a -> a
* CSize
align
      where
        (CSize
q, CSize
m) = CSize
size forall a. Integral a => a -> a -> (a, a)
`quotRem` CSize
align

mlockedAllocForeignPtr :: forall a m. (MonadST m, Storable a) => m (MLockedForeignPtr a)
mlockedAllocForeignPtr :: forall a (m :: * -> *).
(MonadST m, Storable a) =>
m (MLockedForeignPtr a)
mlockedAllocForeignPtr = forall a (m :: * -> *).
Storable a =>
MLockedAllocator m -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedAllocForeignPtrWith ::
  forall a m.
  Storable a =>
  MLockedAllocator m ->
  m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith :: forall a (m :: * -> *).
Storable a =>
MLockedAllocator m -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrWith MLockedAllocator m
allocator =
  forall (m :: * -> *) a.
MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a)
mlockedAllocForeignPtrBytesWith MLockedAllocator m
allocator CSize
size CSize
align
  where
    dummy :: a
    dummy :: a
dummy = forall a. HasCallStack => a
undefined

    size :: CSize
    size :: CSize
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
sizeOf a
dummy

    align :: CSize
    align :: CSize
align = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Storable a => a -> Int
alignment a
dummy

mlockedAlloca :: forall a b m. (MonadST m, MonadThrow m) => CSize -> (Ptr a -> m b) -> m b
mlockedAlloca :: forall a b (m :: * -> *).
(MonadST m, MonadThrow m) =>
CSize -> (Ptr a -> m b) -> m b
mlockedAlloca = forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith forall (m :: * -> *). MonadST m => MLockedAllocator m
mlockedMalloc

mlockedAllocaWith ::
  forall a b m.
  (MonadThrow m, MonadST m) =>
  MLockedAllocator m ->
  CSize ->
  (Ptr a -> m b) ->
  m b
mlockedAllocaWith :: forall a b (m :: * -> *).
(MonadThrow m, MonadST m) =>
MLockedAllocator m -> CSize -> (Ptr a -> m b) -> m b
mlockedAllocaWith MLockedAllocator m
allocator CSize
size =
  forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (MLockedForeignPtr a)
alloc forall (m :: * -> *) a. MonadST m => MLockedForeignPtr a -> m ()
finalizeMLockedForeignPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b.
MonadST m =>
MLockedForeignPtr a -> (Ptr a -> m b) -> m b
withMLockedForeignPtr
  where
    alloc :: m (MLockedForeignPtr a)
alloc = forall (m :: * -> *).
MLockedAllocator m -> forall a. CSize -> m (MLockedForeignPtr a)
mlAllocate MLockedAllocator m
allocator CSize
size