{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Foreign.Wilton.FFI (
registerWiltonCall
, invokeWiltonCall
, invokeWiltonCallByteString
, createWiltonError
) where
import Prelude
( Either(Left, Right), IO, Maybe(Just, Nothing)
, (==), (/=), (>), (>=), (&&), (.), (+), (-), (++)
, fromIntegral, return, show
)
import Control.Exception (SomeException, catch)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson (encode, eitherDecode)
import qualified Data.ByteString as ByteString (concat, drop, length, take)
import qualified Data.ByteString.Char8 as ByteStringChar8 (index)
import qualified Data.ByteString.Lazy as ByteStringLazy (fromChunks, toChunks)
import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString)
import Data.ByteString (ByteString, packCString, packCStringLen, useAsCString)
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.C.String (CString)
import Foreign.C.Types (CChar, CInt(CInt))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Storable (peek, poke, pokeByteOff)
type WiltonCallback = Ptr () -> CString -> CInt -> Ptr CString -> Ptr CInt -> IO CString
type WiltonCallbackInternal = ByteString -> IO (Either ByteString ByteString)
foreign import ccall unsafe "wilton_alloc"
wilton_alloc :: CInt -> IO CString
foreign import ccall unsafe "wilton_free"
wilton_free :: CString -> IO ()
foreign import ccall safe "wiltoncall_register"
wiltoncall_register :: CString -> CInt -> Ptr () -> FunPtr WiltonCallback -> IO CString
foreign import ccall safe "wiltoncall"
wiltoncall :: CString -> CInt -> CString -> CInt -> Ptr CString -> Ptr CInt -> IO CString
foreign import ccall "wrapper"
createCallbackPtr :: WiltonCallback -> IO (FunPtr WiltonCallback)
copyToWiltonBuffer :: ByteString -> IO CString
copyToWiltonBuffer bs = do
res <- wilton_alloc (bytesLength bs + 1)
useAsCString bs (\cs ->
copyBytes res cs (ByteString.length bs))
pokeByteOff res (ByteString.length bs) (0 :: CChar)
return res
encodeJsonBytes :: ToJSON a => a -> ByteString
encodeJsonBytes = ByteString.concat . ByteStringLazy.toChunks . Aeson.encode
bytesLength :: ByteString -> CInt
bytesLength = fromIntegral . ByteString.length
unwrapJsonString :: ByteString -> ByteString
unwrapJsonString st =
if ByteString.length st >= 2
&& ('"' == ByteStringChar8.index st 0)
&& ('"' == ByteStringChar8.index st (ByteString.length st - 1))
then ByteString.take (ByteString.length st - 2) (ByteString.drop 1 st)
else st
wrapBsCallback :: WiltonCallbackInternal -> WiltonCallback
wrapBsCallback cb = fun
where
fun _ jsonCs jsonCsLen jsonOutPtr jsonOutLenPtr = do
dataBs <-
if nullPtr /= jsonCs && jsonCsLen > 0
then packCStringLen (jsonCs, fromIntegral jsonCsLen)
else return (UTF8.fromString "{}")
respEither <-
catch
(cb dataBs)
(\(e :: SomeException) ->
return (Left (UTF8.fromString (show e))))
case respEither of
Left errBs ->
copyToWiltonBuffer errBs
Right respBs -> do
respCs <- copyToWiltonBuffer respBs
poke jsonOutPtr respCs
poke jsonOutLenPtr (bytesLength respBs)
return nullPtr
registerWiltonCall ::
forall a b . (FromJSON a, ToJSON b) =>
ByteString -> (a -> IO b) -> IO (Maybe ByteString)
registerWiltonCall nameBs cbJson = do
let cbCs = wrapBsCallback cbBs
cb <- createCallbackPtr cbCs
errc <-
useAsCString nameBs (\cs ->
wiltoncall_register cs (bytesLength nameBs) nullPtr cb )
if nullPtr /= errc
then do
bs <- packCString errc
wilton_free errc
return (Just bs)
else return Nothing
where
cbBs jsonBs =
case Aeson.eitherDecode (ByteStringLazy.fromChunks [jsonBs]) of
Left e -> return (Left (UTF8.fromString ("Parse error,"
++ " json: [" ++ UTF8.toString jsonBs ++ "],"
++ " message: [" ++ e ++ "]")))
Right (obj :: a) -> do
resObj <- cbJson obj
let resBs = encodeJsonBytes resObj
return (Right resBs)
invokeWiltonCall ::
forall a b . (ToJSON a, FromJSON b) =>
ByteString -> a -> IO (Either ByteString b)
invokeWiltonCall callName callData = do
let callDataBs = encodeJsonBytes callData
let callDataPass = unwrapJsonString callDataBs
resEither <- invokeWiltonCallByteString callName callDataPass
case resEither of
Left err -> return (Left err)
Right jsonBs -> do
let jsonBsNonEmpty = if ByteString.length jsonBs > 0
then jsonBs
else UTF8.fromString "[]"
case Aeson.eitherDecode (ByteStringLazy.fromChunks [jsonBsNonEmpty]) of
Left e ->
return (Left (UTF8.fromString ("Parse error,"
++ " json: [" ++ UTF8.toString jsonBsNonEmpty ++ "],"
++ " message: [" ++ e ++ "]")))
Right (obj :: b) -> return (Right obj)
invokeWiltonCallByteString :: ByteString -> ByteString -> IO (Either ByteString ByteString)
invokeWiltonCallByteString callName callDataBs =
useAsCString callName (\nameCs ->
useAsCString callDataBs (\callDataCs ->
alloca (\(outPtr :: Ptr CString) ->
alloca (\(outLenPtr :: Ptr CInt) -> do
poke outPtr nullPtr
poke outLenPtr 0
errc <- wiltoncall nameCs (bytesLength callName) callDataCs (bytesLength callDataBs) outPtr outLenPtr
out <- peek outPtr
outLen <- peek outLenPtr
res <-
if nullPtr /= errc
then do
bs <- packCString errc
wilton_free errc
return (Left bs)
else
if nullPtr /= out && outLen > 0
then do
outBs <- packCStringLen (out, fromIntegral outLen)
return (Right outBs)
else
return (Right (UTF8.fromString ""))
if nullPtr /= out
then do
wilton_free out
return res
else return res ))))
createWiltonError :: Maybe ByteString -> IO CString
createWiltonError errBsMaybe =
case errBsMaybe of
Just errBs -> copyToWiltonBuffer errBs
_ -> return nullPtr