module FFI.Anything.TypeUncurry.Msgpack (
MessagePackRec (..)
, getTypeListFromMsgpackArray
, uncurryMsgpack
, tryUncurryMsgpack
, tryUncurryMsgpackIO
, byteStringToCStringFun
, byteStringToCStringFunIO
, export
, exportIO
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import qualified Data.MessagePack as MSG
import Data.Proxy
import Data.Storable.Endian (peekBE, pokeBE)
import Foreign.C
import Foreign.Marshal.Alloc (mallocBytes)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (castPtr, plusPtr)
import FFI.Anything.TypeUncurry
class MessagePackRec l where
fromObjectRec :: (Monad m) => [MSG.Object] -> m (TypeList l)
instance MessagePackRec '[] where
fromObjectRec v | null v = pure Nil
fromObjectRec _ = fail "fromObjectRec: passed object is not expected []"
instance (MSG.MessagePack a, MessagePackRec l) => MessagePackRec (a ': l) where
fromObjectRec (x:xs) = (:::) <$> MSG.fromObject x <*> fromObjectRec xs
fromObjectRec _ = fail "fromObjectRec: passed object is not expected (x:xs)"
getTypeListFromMsgpackArray :: forall m l . (MessagePackRec l, ParamLength l, Monad m) => MSG.Object -> m (TypeList l)
getTypeListFromMsgpackArray obj = case obj of
MSG.ObjectArray v | length v == len -> fromObjectRec v
_ -> fail "getTypeListFromMsgpackArray: wrong object length"
where
len = paramLength (Proxy :: Proxy l)
instance (MessagePackRec l, ParamLength l) => MSG.MessagePack (TypeList l) where
fromObject = getTypeListFromMsgpackArray
toObject = error "call-haskell-from-anything: Serialising a TypeList is not supported (and not needed)!"
errorMsg :: String -> String
errorMsg locationStr = "call-haskell-from-anything: " ++ locationStr ++ ": got wrong number of function arguments or non-array"
uncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> ByteString)
uncurryMsgpack f = \bs -> BSL.toStrict . MSG.pack $ (translate f $ fromMaybe (error (errorMsg "uncurryMsgpack")) $ MSG.unpack $ BSL.fromStrict bs)
uncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> IO ByteString)
uncurryMsgpackIO f = \bs -> BSL.toStrict . MSG.pack <$> (translate f $ fromMaybe (error (errorMsg "uncurryMsgpackIO")) $ MSG.unpack $ BSL.fromStrict bs)
tryUncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> Maybe ByteString)
tryUncurryMsgpack f = \bs -> case MSG.unpack $ BSL.fromStrict bs of
Nothing -> Nothing
Just args -> Just . BSL.toStrict . MSG.pack $ (translate f $ args)
tryUncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> Maybe (IO ByteString))
tryUncurryMsgpackIO f = \bs -> case MSG.unpack $ BSL.fromStrict bs of
Nothing -> Nothing
Just args -> Just $ BSL.toStrict . MSG.pack <$> (translate f $ args)
byteStringToMallocedCStringWith64bitLength :: ByteString -> IO CString
byteStringToMallocedCStringWith64bitLength bs =
unsafeUseAsCStringLen bs $ \(ptr, len) -> do
targetPtr <- mallocBytes (8 + len)
pokeBE (castPtr targetPtr) (fromIntegral len :: Int64)
copyBytes (targetPtr `plusPtr` 8) ptr len
return targetPtr
byteStringToCStringFun :: (ByteString -> ByteString) -> CString -> IO CString
byteStringToCStringFun f cs = do
msgLength :: Int64 <- peekBE (castPtr cs)
cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength)
let res_bs = f cs_bs
res_cs <- byteStringToMallocedCStringWith64bitLength res_bs
return res_cs
byteStringToCStringFunIO :: (ByteString -> IO ByteString) -> CString -> IO CString
byteStringToCStringFunIO f cs = do
msgLength :: Int64 <- peekBE (castPtr cs)
cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength)
res_bs <- f cs_bs
res_cs <- byteStringToMallocedCStringWith64bitLength res_bs
return res_cs
export :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> CString -> IO CString
export = byteStringToCStringFun . uncurryMsgpack
exportIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> CString -> IO CString
exportIO = byteStringToCStringFunIO . uncurryMsgpackIO