{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DataKinds, TypeOperators #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-}
-- | Easy FFI via MessagePack.
--
-- You can use this module to expose any Haskell function to other Programming languages.
--
-- It allows to convert functions that take multiple arguments
-- into functions that take one argument:
-- A 'ByteString' which contains all arguments encoded as a MessagePack array.
--
-- Common use cases:
--
-- * Write functions in fast native Haskell code, compile them into a dynamic.
-- library (@.so@ \/ @.dll@) and call them via C\/Python\/Ruby\/whatever via @dlopen()@ or equivalents.
--
-- * Expose Haskell functions via a socket / the web
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
-- | Helper to allow writing a 'MSG.MessagePack' instance for 'TypeList's.
--
-- We need this because we have to call 'parseArray' at the top-level
-- 'MSG.MessagePack' instance, but not at each function argument step.
class MessagePackRec l where
fromObjectRec :: (Monad m) => [MSG.Object] -> m (TypeList l)
-- | When no more types need to be unpacked, we are done.
instance MessagePackRec '[] where
fromObjectRec v | null v = pure Nil
fromObjectRec _ = fail "fromObjectRec: passed object is not expected []"
-- | Unpack one type by just parsing the next element.
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)"
-- | Parses a tuple of arbitrary size ('TypeList's) from a MessagePack array.
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)!"
-- | Standard error message when unpacking failed.
errorMsg :: String -> String
errorMsg locationStr = "call-haskell-from-anything: " ++ locationStr ++ ": got wrong number of function arguments or non-array"
-- | Translates a function of type @a -> b -> ... -> r@ to
-- a function that:
--
-- * takes as a single argument a 'ByteString' containing all arguments serialized in a MessagePack array
--
-- * returns its result serialized in a 'ByteString' via MessagePack 'MSG.pack'
--
-- This function throws an 'error' if the de-serialization of the arguments fails!
-- It is recommended to use 'tryUncurryMsgpack' instead.
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)
-- | Like 'uncurryMsgpack', but for 'IO' functions.
--
-- This function throws an 'error' if the de-serialization of the arguments fails!
-- It is recommended to use 'tryUncurryMsgpackIO' instead.
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)
-- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing
-- the function arguments does not contain the right number/types of arguments.
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)
-- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing
-- the function arguments does not contain the right number/types of arguments.
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)
-- | O(n). Makes a copy of the ByteString's contents into a malloc()ed area.
-- You need to free() the returned string when you're done with it.
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
-- * Exporting
-- TODO implement via byteStringToCStringFunIO?
-- | Transforms a 'ByteString'-mapping function to 'CString'-mapping function
-- for use in the FFI.
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
-- | Transforms a 'ByteString'-mapping 'IO' function to 'CString'-mapping function
-- for use in the FFI.
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
-- | Exports a "pure" function
-- to an FFI function that takes its arguments as a serialized MessagePack message.
--
-- Calling this function throws an 'error' if the de-serialization of the arguments fails!
-- Use 'tryExport' if you want to handle this case.
export :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> CString -> IO CString
export = byteStringToCStringFun . uncurryMsgpack
-- | Exports an 'IO' function to an FFI function that takes its arguments as a serialized MessagePack message.
--
-- Calling this function throws an 'error' if the de-serialization of the arguments fails!
-- Use 'tryExportIO' if you want to handle this case.
exportIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> CString -> IO CString
exportIO = byteStringToCStringFunIO . uncurryMsgpackIO
-- TODO make equivalent using tryUncurryMsgpack (tryExport)
-- TODO make equivalent using tryUncurryMsgpackIO (tryExport)