{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Temporal.Internal.FFI where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import Data.Coerce
import Data.Kind (Type)
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Foreign as Text
import qualified Data.Vector.Storable as Vector
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import qualified Foreign.Marshal.Utils as Marshal
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable
import GHC.Conc (PrimMVar, newStablePtrPrimMVar)
import Temporal.Core.CTypes


withCArray :: Storable a => Vector.Vector a -> (Ptr (CArray a) -> IO b) -> IO b
withCArray :: forall a b.
Storable a =>
Vector a -> (Ptr (CArray a) -> IO b) -> IO b
withCArray Vector a
v Ptr (CArray a) -> IO b
f = Vector a -> (Ptr a -> IO b) -> IO b
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
Vector.unsafeWith Vector a
v ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr a
vPtr ->
  CArray a -> (Ptr (CArray a) -> IO b) -> IO b
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Marshal.with (Ptr a -> Word64 -> CArray a
forall a. Ptr a -> Word64 -> CArray a
CArray Ptr a
vPtr (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Vector a -> Int
forall a. Storable a => Vector a -> Int
Vector.length Vector a
v))) Ptr (CArray a) -> IO b
f


withCArrayBS :: ByteString -> (Ptr (CArray Word8) -> IO b) -> IO b
withCArrayBS :: forall b. ByteString -> (Ptr (CArray Word8) -> IO b) -> IO b
withCArrayBS ByteString
bs Ptr (CArray Word8) -> IO b
f = ByteString -> (CStringLen -> IO b) -> IO b
forall a. ByteString -> (CStringLen -> IO a) -> IO a
ByteString.useAsCStringLen ByteString
bs ((CStringLen -> IO b) -> IO b) -> (CStringLen -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
len) ->
  CArray Word8 -> (Ptr (CArray Word8) -> IO b) -> IO b
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Marshal.with (Ptr Word8 -> Word64 -> CArray Word8
forall a. Ptr a -> Word64 -> CArray a
CArray (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)) Ptr (CArray Word8) -> IO b
f


withCArrayText :: Text -> (Ptr (CArray Word8) -> IO b) -> IO b
withCArrayText :: forall b. Text -> (Ptr (CArray Word8) -> IO b) -> IO b
withCArrayText Text
txt Ptr (CArray Word8) -> IO b
f = Text -> (CStringLen -> IO b) -> IO b
forall a. Text -> (CStringLen -> IO a) -> IO a
Text.withCStringLen Text
txt ((CStringLen -> IO b) -> IO b) -> (CStringLen -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
bytes, Int
len) ->
  CArray Word8 -> (Ptr (CArray Word8) -> IO b) -> IO b
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
Marshal.with (Ptr Word8 -> Word64 -> CArray Word8
forall a. Ptr a -> Word64 -> CArray a
CArray (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
bytes) (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)) Ptr (CArray Word8) -> IO b
f


withTokioResult :: TokioResult a -> (Ptr (Ptr a) -> IO b) -> IO b
withTokioResult :: forall a b. TokioResult a -> (Ptr (Ptr a) -> IO b) -> IO b
withTokioResult TokioResult a
fp Ptr (Ptr a) -> IO b
f = TokioResult a -> (Ptr (Ptr a) -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr TokioResult a
fp ((Ptr (Ptr a) -> IO b) -> IO b) -> (Ptr (Ptr a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr a)
ptr -> do
  Ptr (Ptr a) -> Ptr a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr a)
ptr Ptr a
forall a. Ptr a
nullPtr
  Ptr (Ptr a) -> IO b
f Ptr (Ptr a)
ptr


peekTokioResult :: TokioSlot a -> Maybe (FinalizerPtr a) -> IO (Maybe (ForeignPtr a))
peekTokioResult :: forall a.
TokioSlot a -> Maybe (FinalizerPtr a) -> IO (Maybe (ForeignPtr a))
peekTokioResult TokioSlot a
slot Maybe (FinalizerPtr a)
mfp = do
  inner <- TokioSlot a -> IO (Ptr a)
forall a. Storable a => Ptr a -> IO a
peek TokioSlot a
slot
  if inner == nullPtr
    then return Nothing
    else
      Just <$> case mfp of
        Maybe (FinalizerPtr a)
Nothing -> Ptr a -> IO (ForeignPtr a)
forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr a
inner
        Just FinalizerPtr a
fp -> FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr a
fp Ptr a
inner


type TokioCall e a = StablePtr PrimMVar -> Int -> TokioSlot e -> TokioSlot a -> IO ()


type TokioSlot a = Ptr (Ptr a)


type TokioResult a = ForeignPtr (Ptr a)


{- | Dropping can't be done automatically if the result is returned without async exceptions
intervening, because we don't want to drop things like `Client` while they're still in use.
So we should return ForeignPtrs for things that need to stay alive, and then we can drop when we're done.
-}
makeTokioAsyncCall
  :: TokioCall err res
  -> Maybe (FinalizerPtr err)
  -> Maybe (FinalizerPtr res)
  -> IO (Either (ForeignPtr err) (ForeignPtr res))
makeTokioAsyncCall :: forall err res.
TokioCall err res
-> Maybe (FinalizerPtr err)
-> Maybe (FinalizerPtr res)
-> IO (Either (ForeignPtr err) (ForeignPtr res))
makeTokioAsyncCall TokioCall err res
call Maybe (FinalizerPtr err)
readErr Maybe (FinalizerPtr res)
readSuccess = ((forall a. IO a -> IO a)
 -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
uninterruptibleMask (((forall a. IO a -> IO a)
  -> IO (Either (ForeignPtr err) (ForeignPtr res)))
 -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> ((forall a. IO a -> IO a)
    -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  sp <- newStablePtrPrimMVar mvar
  errorSlot <- mallocForeignPtr
  resultSlot <- mallocForeignPtr
  withTokioResult errorSlot $ \Ptr (Ptr err)
err -> ForeignPtr (Ptr res)
-> (Ptr (Ptr res) -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a b. TokioResult a -> (Ptr (Ptr a) -> IO b) -> IO b
withTokioResult ForeignPtr (Ptr res)
resultSlot ((Ptr (Ptr res) -> IO (Either (ForeignPtr err) (ForeignPtr res)))
 -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> (Ptr (Ptr res) -> IO (Either (ForeignPtr err) (ForeignPtr res)))
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr res)
res -> do
    let peekEither :: IO (Either (ForeignPtr err) (ForeignPtr res))
peekEither = do
          e <- Ptr (Ptr err)
-> Maybe (FinalizerPtr err) -> IO (Maybe (ForeignPtr err))
forall a.
TokioSlot a -> Maybe (FinalizerPtr a) -> IO (Maybe (ForeignPtr a))
peekTokioResult Ptr (Ptr err)
err Maybe (FinalizerPtr err)
readErr
          case e of
            Maybe (ForeignPtr err)
Nothing -> do
              r <- Ptr (Ptr res)
-> Maybe (FinalizerPtr res) -> IO (Maybe (ForeignPtr res))
forall a.
TokioSlot a -> Maybe (FinalizerPtr a) -> IO (Maybe (ForeignPtr a))
peekTokioResult Ptr (Ptr res)
res Maybe (FinalizerPtr res)
readSuccess
              case r of
                Maybe (ForeignPtr res)
Nothing -> [Char] -> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a. HasCallStack => [Char] -> a
error [Char]
"Both error and result are null"
                Just ForeignPtr res
r -> Either (ForeignPtr err) (ForeignPtr res)
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr res -> Either (ForeignPtr err) (ForeignPtr res)
forall a b. b -> Either a b
Right ForeignPtr res
r)
            Just ForeignPtr err
e -> Either (ForeignPtr err) (ForeignPtr res)
-> IO (Either (ForeignPtr err) (ForeignPtr res))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr err -> Either (ForeignPtr err) (ForeignPtr res)
forall a b. a -> Either a b
Left ForeignPtr err
e)

    (cap, _) <- ThreadId -> IO (Int, Bool)
threadCapability (ThreadId -> IO (Int, Bool)) -> IO ThreadId -> IO (Int, Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
    call sp cap err res
    let handleCleanup = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
          MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar
          -- We still need to get the result out of the slot and into a ForeignPtr so that we can drop it
          IO (Either (ForeignPtr err) (ForeignPtr res)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO (Either (ForeignPtr err) (ForeignPtr res))
peekEither
    () <- restore (takeMVar mvar) `onException` handleCleanup
    peekEither