--
-- Fresco Framework for Multi-Language Programming
-- Copyright 2015-2016 Peter Althainz
--
-- Distributed under the Apache License, Version 2.0
-- (See attached file LICENSE or copy at
-- http:--www.apache.org/licenses/LICENSE-2.0)
--
-- file: haskell/Fresco/System.hs
--
{-# LANGUAGE ForeignFunctionInterface, CPP #-}
-- | Helper functions for binding ffi, encoding, decoding via messagepack
module Fresco.System
where
import Data.ByteString
import Data.ByteString.Unsafe
import qualified Data.ByteString.Lazy as BL
import Data.MessagePack
import Data.Either
import Data.Maybe
import Data.Serialize
import Foreign
import Foreign.C
import Foreign.Ptr
import Fresco.Component
#ifdef UseWinDLLLoading
import System.Win32.DLL
#else
import System.Posix.DynamicLinker
#endif
import System.Environment
import System.IO.Unsafe
import Data.IORef
toMsg :: ComponentClass o => o -> ByteString
toMsg o = encode (toObj o)
fromMsg :: ComponentClass o => ByteString -> Maybe o
fromMsg bs = case decode bs of
Right o -> Just $ fromObj o
_ -> Nothing
-- helper functions
type MsgFunction = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Word32
foreign import ccall "dynamic"
mkMsgFun :: FunPtr MsgFunction -> MsgFunction
foreign import ccall "wrapper"
mkMsgFunPtr :: MsgFunction -> IO (FunPtr MsgFunction)
callMsgFunction :: FunPtr MsgFunction -> Ptr () -> Word64 -> ByteString -> IO Int
callMsgFunction mf p ct msg = do
let f = mkMsgFun mf
let dat = msg
unsafeUseAsCStringLen' dat $ \(dat'1, dat'2) -> f p ct dat'1 dat'2 >>= \res -> return (fromIntegral res)
-- unsafeUseAsCStringLen' dat $ \(dat'1, dat'2) -> print "msgfun" >> print dat'1 >> print dat'2 >> f p dat'1 dat'2 >>= \res -> return (fromIntegral res)
type InitFunction = Ptr () -> IO Word32
foreign import ccall "dynamic"
mkInitFun :: FunPtr InitFunction -> InitFunction
callInitFunction :: FunPtr InitFunction -> Ptr () -> IO Int
callInitFunction ifp p = do
let f = mkInitFun ifp
res <- f p
return (fromIntegral res)
-- Entity Interface
type EntityCreateFunction = ((Ptr CChar) -> (Word32 -> ((Ptr (Ptr ())) -> (IO ()))))
foreign import ccall "dynamic"
mkEntityCreateFunction :: FunPtr EntityCreateFunction -> EntityCreateFunction
type EntitySetFunction = ((Ptr CChar) -> (Word32 -> ((Ptr ()) -> (IO ()))))
foreign import ccall "dynamic"
mkEntitySetFunction :: FunPtr EntitySetFunction -> EntitySetFunction
-- pub extern "C" fn entity_get_data(ep: EntityPointer, ct: u64, pp: *mut *mut DataPointer)
type EntityGetDataFunction = ((Ptr ()) -> Word64 -> (Ptr (Ptr ())) -> IO ())
foreign import ccall "dynamic"
mkEntityGetDataFunction :: FunPtr EntityGetDataFunction -> EntityGetDataFunction
-- pub extern "C" fn entity_data_read(dp: *mut DataPointer, p_cp: *mut *const libc::c_char, p_len: *mut libc::c_int)
type EntityDataReadFunction = ((Ptr ()) -> (Ptr (Ptr CChar)) -> (Ptr Word32) -> IO ())
foreign import ccall "dynamic"
mkEntityDataReadFunction :: FunPtr EntityDataReadFunction -> EntityDataReadFunction
-- pub extern "C" fn entity_data_release(dp: *mut DataPointer)
type EntityDataReleaseFunction = ((Ptr ()) -> IO ())
foreign import ccall "dynamic"
mkEntityDataReleaseFunction :: FunPtr EntityDataReleaseFunction -> EntityDataReleaseFunction
-- pub extern "C" fn callback_system_create(pp: *mut *mut CallbackSystem) {
type CallbackSystemCreateFunction = ((Ptr (Ptr ())) -> (IO ()))
foreign import ccall "dynamic"
mkCallbackSystemCreateFunction :: FunPtr CallbackSystemCreateFunction -> CallbackSystemCreateFunction
-- pub extern "C" fn callback_system_register_receiver (cbs: *mut CallbackSystem, ep: EntityPointer, ct: u64, mfp: MessageFunctionPointer) {
type CallbackSystemRegisterReceiverFunction = ((Ptr ()) -> ((Ptr ()) -> (Word64 -> ((FunPtr ((Ptr ()) -> (Word64 -> ((Ptr CChar) -> (Word32 -> (IO Word32))))) -> (IO ()))))))
foreign import ccall "dynamic"
mkCallbackSystemRegisterReceiverFunction :: FunPtr CallbackSystemRegisterReceiverFunction -> CallbackSystemRegisterReceiverFunction
-- pub extern "C" fn callback_system_step(cbs: *mut CallbackSystem) {
type CallbackSystemStepFunction = ((Ptr ()) -> (IO ()))
foreign import ccall "dynamic"
mkCallbackSystemStepFunction:: FunPtr CallbackSystemStepFunction -> CallbackSystemStepFunction
data EntityInterface = EntityInterface {
efCreate :: EntityCreateFunction,
efSet :: EntitySetFunction,
cbsfCreate :: CallbackSystemCreateFunction,
cbsfRegisterReceiver :: CallbackSystemRegisterReceiverFunction,
cbsfStep :: CallbackSystemStepFunction,
edGet :: EntityGetDataFunction,
edRead :: EntityDataReadFunction,
edRelease :: EntityDataReleaseFunction
}
#ifdef UseWinDLLLoading
dynamicEI :: IORef EntityInterface
{-# NOINLINE dynamicEI #-}
dynamicEI = unsafePerformIO (do
libname <- getEnv "INTONACO"
dll <- loadLibrary libname
efc <- getProcAddress dll "entity_create"
let efc' = mkEntityCreateFunction $ castPtrToFunPtr efc
efs <- getProcAddress dll "entity_set"
let efs' = mkEntitySetFunction $ castPtrToFunPtr efs
cbc <- getProcAddress dll "callback_system_create"
let cbc' = mkCallbackSystemCreateFunction $ castPtrToFunPtr cbc
cbr <- getProcAddress dll "callback_system_register_receiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction $ castPtrToFunPtr cbr
cbs <- getProcAddress dll "callback_system_step"
let cbs' = mkCallbackSystemStepFunction $ castPtrToFunPtr cbs
edg <- getProcAddress dll "entity_get_data"
let edg' = mkEntityGetDataFunction $ castPtrToFunPtr edg
edr <- getProcAddress dll "entity_data_read"
let edr' = mkEntityDataReadFunction $ castPtrToFunPtr edr
edd <- getProcAddress dll "entity_data_release"
let edd' = mkEntityDataReleaseFunction $ castPtrToFunPtr edd
ref <- newIORef $ EntityInterface efc' efs' cbc' cbr' cbs' edg' edr' edd'
return ref
)
#else
dynamicEI :: IORef EntityInterface
{-# NOINLINE dynamicEI #-}
dynamicEI = unsafePerformIO (
do
libname <- getEnv "INTONACO"
dll <- dlopen libname [RTLD_NOW]
efc <- dlsym dll "entity_create"
let efc' = mkEntityCreateFunction efc
efs <- dlsym dll "entity_set"
let efs' = mkEntitySetFunction efs
cbc <- dlsym dll "callback_system_create"
let cbc' = mkCallbackSystemCreateFunction cbc
cbr <- dlsym dll "callback_system_register_receiver"
let cbr' = mkCallbackSystemRegisterReceiverFunction cbr
cbs <- dlsym dll "callback_system_step"
let cbs' = mkCallbackSystemStepFunction cbs
edg <- dlsym dll "entity_get_data"
let edg' = mkEntityGetDataFunction edg
edr <- dlsym dll "entity_data_read"
let edr' = mkEntityDataReadFunction edr
edd <- dlsym dll "entity_data_release"
let edd' = mkEntityDataReleaseFunction edd
ref <- newIORef $ EntityInterface efc' efs' cbc' cbr' cbs' edg' edr' edd'
return ref
)
#endif
type CStringCLen i = (CString, i)
unsafeUseAsCStringLen' :: (Integral i) => ByteString -> (CStringCLen i -> IO a) -> IO a
unsafeUseAsCStringLen' str fn =
unsafeUseAsCStringLen str (\(ptr, len) -> fn (ptr, fromIntegral len))
entityCreate :: (ByteString) -> IO ((Ptr ()))
entityCreate a1 =
unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) ->
alloca $ \a2' ->
(do
dei <- readIORef dynamicEI
(efCreate dei) a1'1 a1'2 a2') >>
peek a2' >>= \a2'' ->
return (a2'')
entitySet :: (ByteString) -> (Ptr ()) -> IO ()
entitySet a1 a2 =
unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) ->
let {a2' = id a2} in
(do
dei <- readIORef dynamicEI
(efSet dei) a1'1 a1'2 a2') >>
return ()
entityGetData :: (Ptr ()) -> Word64 -> IO ((Ptr ()))
entityGetData a1 a2 =
alloca $ \a3' ->
(do
dei <- readIORef dynamicEI
(edGet dei) a1 (fromIntegral a2) a3') >>
peek a3' >>= \a3'' ->
return (a3'')
entityDataRead :: Ptr () -> IO ByteString
entityDataRead a1 =
alloca $ \a2' ->
alloca $ \a3' ->
(do
dei <- readIORef dynamicEI
(edRead dei) a1 a2' a3') >>
peek a2' >>= \a2'' ->
peek a3' >>= \a3'' ->
(do
bs <- packCStringLen (a2'', fromIntegral a3'')
return bs
)
entityDataRelease :: Ptr () -> IO ()
entityDataRelease a1 = do
dei <- readIORef dynamicEI
(edRelease dei) a1
return ()
callbackSystemCreate :: IO ((Ptr ()))
callbackSystemCreate =
alloca $ \a1' ->
(do
dei <- readIORef dynamicEI
(cbsfCreate dei) a1') >>
peek a1'>>= \a1'' ->
return (a1'')
callbackSystemRegisterReceiver :: (Ptr ()) -> (Ptr ()) -> (Word64) -> (FunPtr (Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Word32)) -> IO ()
callbackSystemRegisterReceiver a1 a2 a3 a4 =
let {a1' = id a1} in
let {a2' = id a2} in
let {a3' = fromIntegral a3} in
let {a4' = id a4} in
(do
dei <- readIORef dynamicEI
(cbsfRegisterReceiver dei) a1' a2' a3' a4') >>
return ()
callbackSystemStep :: (Ptr ()) -> IO ()
callbackSystemStep a1 =
let {a1' = id a1} in
(do
dei <- readIORef dynamicEI
(cbsfStep dei) a1') >>
return ()