{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE UnboxedTuples              #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
module Cardano.Crypto.PinnedSizedBytes
  (
    PinnedSizedBytes,
    -- * Initialization
    psbZero,
    -- * Conversions
    psbFromBytes,
    psbToBytes,
    psbFromByteString,
    psbFromByteStringCheck,
    psbToByteString,
    -- * C usage
    psbUseAsCPtr,
    psbUseAsCPtrLen,
    psbUseAsSizedPtr,
    psbCreate,
    psbCreateLen,
    psbCreateSized,
    psbCreateResult,
    psbCreateResultLen,
    psbCreateSizedResult,
    ptrPsbToSizedPtr,
  ) where

import Data.Kind (Type)
import Control.DeepSeq (NFData)
import Control.Monad.ST (runST)
import Control.Monad.Primitive  (primitive_, touch)
import Data.Primitive.ByteArray
          ( ByteArray (..)
          , MutableByteArray (..)
          , copyByteArrayToAddr
          , newPinnedByteArray
          , unsafeFreezeByteArray
          , foldrByteArray
          , byteArrayContents
          , writeByteArray
          , mutableByteArrayContents
          )
import Data.Proxy (Proxy (..))
import Data.String (IsString (..))
import Data.Word (Word8)
import Foreign.C.Types (CSize)
import Foreign.Ptr (FunPtr, castPtr)
import Foreign.Storable (Storable (..))
import GHC.TypeLits (KnownNat, Nat, natVal)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import Language.Haskell.TH.Syntax (Q, TExp(..))
import Language.Haskell.TH.Syntax.Compat (examineSplice)
import Numeric (showHex)
import System.IO.Unsafe (unsafeDupablePerformIO)

import GHC.Exts (Int (..), copyAddrToByteArray#)
import GHC.Ptr (Ptr (..))

import qualified Data.Primitive as Prim
import qualified Data.ByteString as BS

import Cardano.Foreign
import Cardano.Crypto.Libsodium.C (c_sodium_compare)
import Cardano.Crypto.Util (decodeHexString)

{- HLINT ignore "Reduce duplication" -}

-- $setup
-- >>> :set -XDataKinds -XTypeApplications -XOverloadedStrings
-- >>> import Cardano.Crypto.PinnedSizedBytes

-- | @n@ bytes. 'Storable'.
--
-- We have two @*Bytes@ types:
--
-- * @PinnedSizedBytes@ is backed by pinned ByteArray.
-- * @MLockedSizedBytes@ is backed by ForeignPtr to @mlock@-ed memory region.
--
-- The 'ByteString' is pinned datatype, but it's represented by
-- 'ForeignPtr' + offset (and size).
--
-- I'm sorry for adding more types for bytes. :(
--
newtype PinnedSizedBytes (n :: Nat) = PSB ByteArray
  deriving Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
Proxy (PinnedSizedBytes n) -> String
forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
forall (n :: Nat). Proxy (PinnedSizedBytes n) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PinnedSizedBytes n) -> String
$cshowTypeOf :: forall (n :: Nat). Proxy (PinnedSizedBytes n) -> String
wNoThunks :: Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
noThunks :: Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (n :: Nat).
Context -> PinnedSizedBytes n -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "PinnedSizedBytes" (PinnedSizedBytes n)
  deriving PinnedSizedBytes n -> ()
forall (n :: Nat). PinnedSizedBytes n -> ()
forall a. (a -> ()) -> NFData a
rnf :: PinnedSizedBytes n -> ()
$crnf :: forall (n :: Nat). PinnedSizedBytes n -> ()
NFData

instance Show (PinnedSizedBytes n) where
    showsPrec :: Int -> PinnedSizedBytes n -> ShowS
showsPrec Int
_ (PSB ByteArray
ba)
        = Char -> ShowS
showChar Char
'"'
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prim a => (a -> b -> b) -> b -> ByteArray -> b
foldrByteArray (\Word8
w ShowS
acc -> Word8 -> ShowS
show8 Word8
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
acc) forall a. a -> a
id ByteArray
ba
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'"'
      where
        show8 :: Word8 -> ShowS
        show8 :: Word8 -> ShowS
show8 Word8
w | Word8
w forall a. Ord a => a -> a -> Bool
< Word8
16    = Char -> ShowS
showChar Char
'0' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w
                | Bool
otherwise = forall a. (Integral a, Show a) => a -> ShowS
showHex Word8
w

-- | The comparison is done in constant time for a given size @n@.
instance KnownNat n => Eq (PinnedSizedBytes n) where
    PinnedSizedBytes n
x == :: PinnedSizedBytes n -> PinnedSizedBytes n -> Bool
== PinnedSizedBytes n
y = forall a. Ord a => a -> a -> Ordering
compare PinnedSizedBytes n
x PinnedSizedBytes n
y forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance KnownNat n => Ord (PinnedSizedBytes n) where
    compare :: PinnedSizedBytes n -> PinnedSizedBytes n -> Ordering
compare PinnedSizedBytes n
x PinnedSizedBytes n
y =
        forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
            forall (n :: Nat) r.
PinnedSizedBytes n -> (Ptr Word8 -> IO r) -> IO r
psbUseAsCPtr PinnedSizedBytes n
x forall a b. (a -> b) -> a -> b
$ \Ptr Word8
xPtr ->
                forall (n :: Nat) r.
PinnedSizedBytes n -> (Ptr Word8 -> IO r) -> IO r
psbUseAsCPtr PinnedSizedBytes n
y forall a b. (a -> b) -> a -> b
$ \Ptr Word8
yPtr -> do
                    Int
res <- forall a. Ptr a -> Ptr a -> CSize -> IO Int
c_sodium_compare Ptr Word8
xPtr Ptr Word8
yPtr CSize
size
                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> a -> Ordering
compare Int
res Int
0)
      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 :: Proxy n))


-- | This instance is meant to be used with @TemplateHaskell@
--
-- >>> import Cardano.Crypto.PinnedSizedBytes
-- >>> :set -XTemplateHaskell
-- >>> :set -XOverloadedStrings
-- >>> :set -XDataKinds
-- >>> print ($$("0xdeadbeef") :: PinnedSizedBytes 4)
-- "deadbeef"
-- >>> print ($$("deadbeef") :: PinnedSizedBytes 4)
-- "deadbeef"
-- >>> let bsb = $$("0xdeadbeef") :: PinnedSizedBytes 5
-- <interactive>:9:14: error:
--     • <PinnedSizedBytes>: Expected in decoded form to be: 5 bytes, but got: 4
--     • In the Template Haskell splice $$("0xdeadbeef")
--       In the expression: $$("0xdeadbeef") :: PinnedSizedBytes 5
--       In an equation for ‘bsb’:
--           bsb = $$("0xdeadbeef") :: PinnedSizedBytes 5
-- >>> let bsb = $$("nogood") :: PinnedSizedBytes 5
-- <interactive>:11:14: error:
--     • <PinnedSizedBytes>: Malformed hex: invalid character at offset: 0
--     • In the Template Haskell splice $$("nogood")
--       In the expression: $$("nogood") :: PinnedSizedBytes 5
--       In an equation for ‘bsb’: bsb = $$("nogood") :: PinnedSizedBytes 5
instance KnownNat n => IsString (Q (TExp (PinnedSizedBytes n))) where
    fromString :: String -> Q (TExp (PinnedSizedBytes n))
fromString String
hexStr = do
      let n :: Int
n = forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)
      case String -> Int -> Either String ByteString
decodeHexString String
hexStr Int
n of
        Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"<PinnedSizedBytes>: " forall a. [a] -> [a] -> [a]
++ String
err
        Right ByteString
_  -> forall (m :: * -> *) a. Splice m a -> m (TExp a)
examineSplice [|| either error psbFromByteString (decodeHexString hexStr n) ||]


-- | See 'psbFromBytes'.
psbToBytes :: PinnedSizedBytes n -> [Word8]
psbToBytes :: forall (n :: Nat). PinnedSizedBytes n -> [Word8]
psbToBytes (PSB ByteArray
ba) = forall a b. Prim a => (a -> b -> b) -> b -> ByteArray -> b
foldrByteArray (:) [] ByteArray
ba

psbToByteString :: PinnedSizedBytes n -> BS.ByteString
psbToByteString :: forall (n :: Nat). PinnedSizedBytes n -> ByteString
psbToByteString = [Word8] -> ByteString
BS.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). PinnedSizedBytes n -> [Word8]
psbToBytes

-- | See @'IsString' ('PinnedSizedBytes' n)@ instance.
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2,3,4]
-- [1,2,3,4]
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2]
-- [0,0,1,2]
--
-- >>> psbToBytes . (id @(PinnedSizedBytes 4)) . psbFromBytes $ [1,2,3,4,5,6]
-- [3,4,5,6]
--
{-# DEPRECATED psbFromBytes "This is not referentially transparent" #-}
psbFromBytes :: forall n. KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes :: forall (n :: Nat). KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes [Word8]
ws0 = forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB (forall a. Prim a => Int -> [a] -> ByteArray
pinnedByteArrayFromListN Int
size [Word8]
ws)
  where
    size :: Int
    size :: Int
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 :: Proxy n))

    ws :: [Word8]
    ws :: [Word8]
ws = forall a. [a] -> [a]
reverse
        forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
size
        forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Word8
0)
        forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [Word8]
ws0

-- | Convert a ByteString into PinnedSizedBytes. Input should contain the exact
-- number of bytes as expected by type level @n@ size, otherwise error.
psbFromByteString :: KnownNat n => BS.ByteString -> PinnedSizedBytes n
psbFromByteString :: forall (n :: Nat). KnownNat n => ByteString -> PinnedSizedBytes n
psbFromByteString ByteString
bs =
  case forall (n :: Nat).
KnownNat n =>
ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck ByteString
bs of
    Maybe (PinnedSizedBytes n)
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"psbFromByteString: Size mismatch, got: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (ByteString -> Int
BS.length ByteString
bs)
    Just PinnedSizedBytes n
psb -> PinnedSizedBytes n
psb

psbFromByteStringCheck :: forall n. KnownNat n => BS.ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck :: forall (n :: Nat).
KnownNat n =>
ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck ByteString
bs
    | ByteString -> Int
BS.length ByteString
bs forall a. Eq a => a -> a -> Bool
== Int
size = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$
        forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr Addr#
addr#, Int
_) -> do
            marr :: MutableByteArray RealWorld
marr@(MutableByteArray MutableByteArray# RealWorld
marr#) <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
size
            forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr# MutableByteArray# RealWorld
marr# Int#
0# (case Int
size of I# Int#
s -> Int#
s)
            ByteArray
arr <- forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
marr
            forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr)
    | Bool
otherwise            = forall a. Maybe a
Nothing
  where
    size :: Int
    size :: Int
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 :: Proxy n))

{-# DEPRECATED psbZero "This is not referentially transparent" #-}
psbZero :: KnownNat n =>  PinnedSizedBytes n
psbZero :: forall (n :: Nat). KnownNat n => PinnedSizedBytes n
psbZero = forall (n :: Nat). KnownNat n => [Word8] -> PinnedSizedBytes n
psbFromBytes []

instance KnownNat n => Storable (PinnedSizedBytes n) where
    sizeOf :: PinnedSizedBytes n -> Int
sizeOf PinnedSizedBytes n
_          = 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 :: Proxy n))
    alignment :: PinnedSizedBytes n -> Int
alignment PinnedSizedBytes n
_       = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: FunPtr (Int -> Int))

    peek :: Ptr (PinnedSizedBytes n) -> IO (PinnedSizedBytes n)
peek (Ptr Addr#
addr#) = do
        let size :: Int
            size :: Int
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 :: Proxy n))
        marr :: MutableByteArray RealWorld
marr@(MutableByteArray MutableByteArray# RealWorld
marr#) <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
size
        forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
primitive_ forall a b. (a -> b) -> a -> b
$ forall d.
Addr#
-> MutableByteArray# d -> Int# -> Int# -> State# d -> State# d
copyAddrToByteArray# Addr#
addr# MutableByteArray# RealWorld
marr# Int#
0# (case Int
size of I# Int#
s -> Int#
s)
        ByteArray
arr <- forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
marr
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr)

    poke :: Ptr (PinnedSizedBytes n) -> PinnedSizedBytes n -> IO ()
poke Ptr (PinnedSizedBytes n)
p (PSB ByteArray
arr) = do
        let size :: Int
            size :: Int
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 :: Proxy n))
        forall (m :: * -> *).
PrimMonad m =>
Ptr Word8 -> ByteArray -> Int -> Int -> m ()
copyByteArrayToAddr (forall a b. Ptr a -> Ptr b
castPtr Ptr (PinnedSizedBytes n)
p) ByteArray
arr Int
0 Int
size

-- | Use a 'PinnedSizedBytes' in a setting where its size is \'forgotten\'
-- temporarily.
--
-- = Note
--
-- The 'Ptr' given to the function argument /must not/ be used as the result of
-- type @r@.
psbUseAsCPtr ::
  forall (n :: Nat) (r :: Type) .
  PinnedSizedBytes n ->
  (Ptr Word8 -> IO r) ->
  IO r
psbUseAsCPtr :: forall (n :: Nat) r.
PinnedSizedBytes n -> (Ptr Word8 -> IO r) -> IO r
psbUseAsCPtr (PSB ByteArray
ba) = forall a. ByteArray -> (Ptr Word8 -> IO a) -> IO a
runAndTouch ByteArray
ba

-- | As 'psbUseAsCPtr', but also gives the function argument the size we are
-- allowed to use as a 'CSize'.
--
-- This is mostly boilerplate removal, as it is quite common for C APIs to take
-- a combination of a pointer to some data and its length. A possible use case
-- (and one we run into) is where we know that we can expect a certain data
-- length (using 'PinnedSizedBytes' as its representation), but the C API allows
-- any length we like, provided we give the right argument to indicate this.
-- Therefore, having a helper like this one allows us to avoid having to
-- manually 'natVal' a 'Proxy', as well as ensuring we don't get mismatches
-- accidentally.
--
-- The same caveats apply to the use of this function as to the use of
-- 'psbUseAsCPtr'.
psbUseAsCPtrLen ::
  forall (n :: Nat) (r :: Type) .
  (KnownNat n) =>
  PinnedSizedBytes n ->
  (Ptr Word8 -> CSize -> IO r) ->
  IO r
psbUseAsCPtrLen :: forall (n :: Nat) r.
KnownNat n =>
PinnedSizedBytes n -> (Ptr Word8 -> CSize -> IO r) -> IO r
psbUseAsCPtrLen (PSB ByteArray
ba) Ptr Word8 -> CSize -> IO r
f = do
  let CSize
len :: CSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @n
  forall a. ByteArray -> (Ptr Word8 -> IO a) -> IO a
runAndTouch ByteArray
ba (Ptr Word8 -> CSize -> IO r
`f` CSize
len)

-- | As 'psbUseAsCPtr', but does not \'forget\' the size.
--
-- The same caveats apply to this use of this function as to the use of
-- 'psbUseAsCPtr'.
psbUseAsSizedPtr ::
  forall (n :: Nat) (r :: Type) .
  PinnedSizedBytes n ->
  (SizedPtr n -> IO r) ->
  IO r
psbUseAsSizedPtr :: forall (n :: Nat) r.
PinnedSizedBytes n -> (SizedPtr n -> IO r) -> IO r
psbUseAsSizedPtr (PSB ByteArray
ba) SizedPtr n -> IO r
k = do
    r
r <- SizedPtr n -> IO r
k (forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr forall a b. (a -> b) -> a -> b
$ ByteArray -> Ptr Word8
byteArrayContents ByteArray
ba)
    r
r forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch ByteArray
ba

-- | As 'psbCreateResult', but presumes that no useful value is produced: that
-- is, the function argument is run only for its side effects.
psbCreate ::
  forall (n :: Nat) .
  (KnownNat n) =>
  (Ptr Word8 -> IO ()) ->
  IO (PinnedSizedBytes n)
psbCreate :: forall (n :: Nat).
KnownNat n =>
(Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
psbCreate Ptr Word8 -> IO ()
f = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResult Ptr Word8 -> IO ()
f

-- | As 'psbCreateResultLen', but presumes that no useful value is produced:
-- that is, the function argument is run only for its side effects.
psbCreateLen ::
  forall (n :: Nat) .
  (KnownNat n) =>
  (Ptr Word8 -> CSize -> IO ()) ->
  IO (PinnedSizedBytes n)
psbCreateLen :: forall (n :: Nat).
KnownNat n =>
(Ptr Word8 -> CSize -> IO ()) -> IO (PinnedSizedBytes n)
psbCreateLen Ptr Word8 -> CSize -> IO ()
f = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> CSize -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResultLen Ptr Word8 -> CSize -> IO ()
f

-- | Given an \'initialization action\', which also produces some result, allocate
-- new pinned memory of the specified size, perform the action, then return the
-- result together with the initialized pinned memory (as a 'PinnedSizedBytes').
--
-- = Note
--
-- It is essential that @r@ is not the 'Ptr' given to the function argument.
-- Returning this 'Ptr' is /extremely/ unsafe:
--
-- * It breaks referential transparency guarantees by aliasing supposedly
-- immutable memory; and
-- * This 'Ptr' could refer to memory which has already been garbage collected,
-- which can lead to segfaults or out-of-bounds reads.
--
-- This poses both correctness /and/ security risks, so please don't do it.
psbCreateResult ::
  forall (n :: Nat) (r :: Type) .
  (KnownNat n) =>
  (Ptr Word8 -> IO r) ->
  IO (PinnedSizedBytes n, r)
psbCreateResult :: forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResult Ptr Word8 -> IO r
f = forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> CSize -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResultLen (\Ptr Word8
p CSize
_ -> Ptr Word8 -> IO r
f Ptr Word8
p)

-- | As 'psbCreateResult', but also gives the number of bytes we are allowed to
-- operate on as a 'CSize'.
--
-- This function is provided for two reasons:
--
-- * It is a common practice in C libraries to pass a pointer to data plus a
-- length. While /our/ use case might know the size we expect, the C function we
-- are calling might be more general. This simplifies calling such functions.
-- * We avoid 'natVal'ing a 'Proxy' /twice/, since we have to do it anyway.
--
-- The same caveats apply to this function as to 'psbCreateResult': the 'Ptr'
-- given to the function argument /must not/ be returned as @r@.
psbCreateResultLen ::
  forall (n :: Nat) (r :: Type) .
  (KnownNat n) =>
  (Ptr Word8 -> CSize -> IO r) ->
  IO (PinnedSizedBytes n, r)
psbCreateResultLen :: forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> CSize -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResultLen Ptr Word8 -> CSize -> IO r
f = do
  let Int
len :: Int = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @n
  MutableByteArray RealWorld
mba <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray Int
len
  r
res <- Ptr Word8 -> CSize -> IO r
f (forall s. MutableByteArray s -> Ptr Word8
mutableByteArrayContents MutableByteArray RealWorld
mba) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  ByteArray
arr <- forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray RealWorld
mba
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (n :: Nat). ByteArray -> PinnedSizedBytes n
PSB ByteArray
arr, r
res)

-- | As 'psbCreateSizedResult', but presumes that no useful value is produced:
-- that is, the function argument is run only for its side effects.
psbCreateSized ::
  forall (n :: Nat).
  (KnownNat n) =>
  (SizedPtr n -> IO ()) ->
  IO (PinnedSizedBytes n)
psbCreateSized :: forall (n :: Nat).
KnownNat n =>
(SizedPtr n -> IO ()) -> IO (PinnedSizedBytes n)
psbCreateSized SizedPtr n -> IO ()
k = forall (n :: Nat).
KnownNat n =>
(Ptr Word8 -> IO ()) -> IO (PinnedSizedBytes n)
psbCreate (SizedPtr n -> IO ()
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr)

-- | As 'psbCreateResult', but gives a 'SizedPtr' to the function argument. The
-- same caveats apply to this function as to 'psbCreateResult': the 'SizedPtr'
-- given to the function argument /must not/ be resulted as @r@.
psbCreateSizedResult ::
  forall (n :: Nat) (r :: Type) .
  (KnownNat n) =>
  (SizedPtr n -> IO r) ->
  IO (PinnedSizedBytes n, r)
psbCreateSizedResult :: forall (n :: Nat) r.
KnownNat n =>
(SizedPtr n -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateSizedResult SizedPtr n -> IO r
f = forall (n :: Nat) r.
KnownNat n =>
(Ptr Word8 -> IO r) -> IO (PinnedSizedBytes n, r)
psbCreateResult (SizedPtr n -> IO r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr)

ptrPsbToSizedPtr :: Ptr (PinnedSizedBytes n) -> SizedPtr n
ptrPsbToSizedPtr :: forall (n :: Nat). Ptr (PinnedSizedBytes n) -> SizedPtr n
ptrPsbToSizedPtr = forall (n :: Nat). Ptr Void -> SizedPtr n
SizedPtr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Ptr a -> Ptr b
castPtr

-------------------------------------------------------------------------------
-- derivative from primitive
-------------------------------------------------------------------------------

-- | Create a 'ByteArray' from a list of a known length. If the length
--   of the list does not match the given length, or if the length is zero,
--   then this throws an exception.
pinnedByteArrayFromListN :: forall a. Prim.Prim a => Int -> [a] -> ByteArray
pinnedByteArrayFromListN :: forall a. Prim a => Int -> [a] -> ByteArray
pinnedByteArrayFromListN Int
0 [a]
_ =
    forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length zero"
pinnedByteArrayFromListN Int
n [a]
ys = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray (PrimState (ST s))
marr <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newPinnedByteArray (Int
n forall a. Num a => a -> a -> a
* forall a. Prim a => a -> Int
Prim.sizeOf (forall a. [a] -> a
head [a]
ys))
    let go :: Int -> [a] -> ST s ()
go !Int
ix [] = if Int
ix forall a. Eq a => a -> a -> Bool
== Int
n
          then forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length less than specified size"
        go !Int
ix (a
x : [a]
xs) = if Int
ix forall a. Ord a => a -> a -> Bool
< Int
n
          then do
            forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
writeByteArray MutableByteArray (PrimState (ST s))
marr Int
ix a
x
            Int -> [a] -> ST s ()
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1) [a]
xs
          else forall a. String -> String -> a
die String
"pinnedByteArrayFromListN" String
"list length greater than specified size"
    forall {a}. Prim a => Int -> [a] -> ST s ()
go Int
0 [a]
ys
    forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray (PrimState (ST s))
marr

die :: String -> String -> a
die :: forall a. String -> String -> a
die String
fun String
problem = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"PinnedSizedBytes." forall a. [a] -> [a] -> [a]
++ String
fun forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
problem

-- Wrapper that combines applying a function, then touching
runAndTouch ::
  forall (a :: Type) .
  ByteArray ->
  (Ptr Word8 -> IO a) ->
  IO a
runAndTouch :: forall a. ByteArray -> (Ptr Word8 -> IO a) -> IO a
runAndTouch ByteArray
ba Ptr Word8 -> IO a
f = do
  a
r <- Ptr Word8 -> IO a
f (ByteArray -> Ptr Word8
byteArrayContents ByteArray
ba)
  a
r forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. PrimMonad m => a -> m ()
touch ByteArray
ba