-- -- 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 ()