-- -- Fresco Framework for Multi-Language Programming -- Copyright 2015 - 2017 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.Lazy import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.ByteString (packCStringLen) import Data.Binary.Serialise.CBOR import Data.Either import Data.Maybe 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 :: Serialise o => o -> ByteString toMsg o = serialise o fromMsg :: Serialise o => ByteString -> o fromMsg bs = deserialise bs -- helper functions -- different callback functions and dynamic wrapper generation type MsgFn = Ptr () -> Ptr CChar -> Word32 -> IO () foreign import ccall "dynamic" mkMsgFn :: FunPtr MsgFn -> MsgFn foreign import ccall "wrapper" mkMsgFnPtr :: MsgFn -> IO (FunPtr MsgFn) type MsgEntityFn = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Int32 foreign import ccall "dynamic" mkMsgEntityFn :: FunPtr MsgEntityFn -> MsgEntityFn foreign import ccall "wrapper" mkMsgEntityFnPtr :: MsgEntityFn -> IO (FunPtr MsgEntityFn) callMsgEntityFn :: FunPtr MsgEntityFn -> Ptr () -> Word64 -> ByteString -> IO Int callMsgEntityFn mf p ct msg = do let f = mkMsgEntityFn 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 EntityDestroyFunction = Ptr () -> IO () foreign import ccall "dynamic" mkEntityDestroyFunction :: FunPtr EntityDestroyFunction -> EntityDestroyFunction type EntityReadComponentFunction = Ptr () -> Word64 -> Ptr () -> FunPtr MsgFn -> IO () foreign import ccall "dynamic" mkEntityReadComponentFunction :: FunPtr EntityReadComponentFunction -> EntityReadComponentFunction type EntityWriteComponentFunction = Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO () foreign import ccall "dynamic" mkEntityWriteComponentFunction :: FunPtr EntityWriteComponentFunction -> EntityWriteComponentFunction type EntityReadIdFunction = Ptr () -> Ptr () -> FunPtr MsgFn -> IO () foreign import ccall "dynamic" mkEntityReadIdFunction :: FunPtr EntityReadIdFunction -> EntityReadIdFunction -- Object Lib System Interface type ObjectLibSystemInitFunction = Ptr CChar -> Ptr (Ptr ()) -> IO () foreign import ccall "dynamic" mkObjectLibSystemInitFunction :: FunPtr ObjectLibSystemInitFunction -> ObjectLibSystemInitFunction type ObjectLibSystemAddEntityFunction = Ptr () -> Ptr () -> IO () foreign import ccall "dynamic" mkObjectLibSystemAddEntityFunction:: FunPtr ObjectLibSystemAddEntityFunction -> ObjectLibSystemAddEntityFunction type ObjectLibSystemRemoveEntityFunction = Ptr () -> Ptr () -> IO () foreign import ccall "dynamic" mkObjectLibSystemRemoveEntityFunction:: FunPtr ObjectLibSystemRemoveEntityFunction -> ObjectLibSystemRemoveEntityFunction type ObjectLibSystemShutdownFunction = Ptr () -> IO () foreign import ccall "dynamic" mkObjectLibSystemShutdownFunction:: FunPtr ObjectLibSystemShutdownFunction -> ObjectLibSystemShutdownFunction type ObjectLibSystemStepFunction = Ptr () -> IO () foreign import ccall "dynamic" mkObjectLibSystemStepFunction:: FunPtr ObjectLibSystemStepFunction -> ObjectLibSystemStepFunction -- Callback System Interface type CallbackSystemInitFunction = Ptr (Ptr ()) -> IO () foreign import ccall "dynamic" mkCallbackSystemInitFunction :: FunPtr CallbackSystemInitFunction -> CallbackSystemInitFunction type CallbackSystemRegisterReceiverFunction = Ptr () -> Ptr () -> Word64 -> FunPtr MsgEntityFn -> IO () foreign import ccall "dynamic" mkCallbackSystemRegisterReceiverFunction :: FunPtr CallbackSystemRegisterReceiverFunction -> CallbackSystemRegisterReceiverFunction type CallbackSystemShutdownFunction = Ptr () -> IO () foreign import ccall "dynamic" mkCallbackSystemShutdownFunction:: FunPtr CallbackSystemShutdownFunction -> CallbackSystemShutdownFunction type CallbackSystemStepFunction = Ptr () -> IO () foreign import ccall "dynamic" mkCallbackSystemStepFunction:: FunPtr CallbackSystemStepFunction -> CallbackSystemStepFunction data EntityInterface = EntityInterface { eCreate :: EntityCreateFunction, eRead :: EntityReadComponentFunction, eWrite :: EntityWriteComponentFunction, eId :: EntityReadIdFunction, eDestroy :: EntityDestroyFunction, olsInit :: ObjectLibSystemInitFunction, olsAddEntity :: ObjectLibSystemAddEntityFunction, olsRemoveEntity :: ObjectLibSystemRemoveEntityFunction, olsShutdown :: ObjectLibSystemShutdownFunction, olsStep :: ObjectLibSystemStepFunction, cbsInit :: CallbackSystemInitFunction, cbsRegisterReceiver :: CallbackSystemRegisterReceiverFunction, cbsShutdown :: CallbackSystemShutdownFunction, cbsStep :: CallbackSystemStepFunction } #ifdef UseWinDLLLoading dynamicEI :: IORef EntityInterface {-# NOINLINE dynamicEI #-} dynamicEI = unsafePerformIO (do libname <- getEnv "INTONACO" dll <- loadLibrary libname ec <- getProcAddress dll "inEntityCreate" let ec' = mkEntityCreateFunction $ castPtrToFunPtr ec er <- getProcAddress dll "inEntityReadComponent" let er' = mkEntityReadComponentFunction $ castPtrToFunPtr er ew <- getProcAddress dll "inEntityWriteComponent" let ew' = mkEntityWriteComponentFunction $ castPtrToFunPtr ew ei <- getProcAddress dll "inEntityId" let ei' = mkEntityReadIdFunction $ castPtrToFunPtr ei ed <- getProcAddress dll "inEntityDestroy" let ed' = mkEntityDestroyFunction $ castPtrToFunPtr ed oli <- getProcAddress dll "inObjectLibSystemInit" let oli' = mkObjectLibSystemInitFunction $ castPtrToFunPtr oli ola <- getProcAddress dll "inObjectLibSystemAddEntity" let ola' = mkObjectLibSystemAddEntityFunction $ castPtrToFunPtr ola olr <- getProcAddress dll "inObjectLibSystemRemoveEntity" let olr' = mkObjectLibSystemRemoveEntityFunction $ castPtrToFunPtr olr olu <- getProcAddress dll "inObjectLibSystemShutdown" let olu' = mkObjectLibSystemShutdownFunction $ castPtrToFunPtr olu ols <- getProcAddress dll "inObjectLibSystemStep" let ols' = mkObjectLibSystemStepFunction $ castPtrToFunPtr ols cbi <- getProcAddress dll "inCallbackSystemInit" let cbi' = mkCallbackSystemInitFunction $ castPtrToFunPtr cbi cbr <- getProcAddress dll "inCallbackSystemRegisterReceiver" let cbr' = mkCallbackSystemRegisterReceiverFunction $ castPtrToFunPtr cbr cbu <- getProcAddress dll "inCallbackSystemShutdown" let cbu' = mkCallbackSystemShutdownFunction $ castPtrToFunPtr cbu cbs <- getProcAddress dll "inCallbackSystemStep" let cbs' = mkCallbackSystemStepFunction $ castPtrToFunPtr cbs ref <- newIORef $ EntityInterface ec' er' ew' ei' ed' oli' ola' olr' olu' ols' cbi' cbr' cbu' cbs' return ref ) #else dynamicEI :: IORef EntityInterface {-# NOINLINE dynamicEI #-} dynamicEI = unsafePerformIO ( do libname <- getEnv "INTONACO" dll <- dlopen libname [RTLD_NOW] ec <- dlsym dll "inEntityCreate" let ec' = mkEntityCreateFunction ec er <- dlsym dll "inEntityReadComponent" let er' = mkEntityReadComponentFunction er ew <- dlsym dll "inEntityWriteComponent" let ew' = mkEntityWriteComponentFunction ew ei <- dlsym dll "inEntityId" let ei' = mkEntityReadIdFunction ei ed <- dlsym dll "inEntityDestroy" let ed' = mkEntityDestroyFunction ed oli <- dlsym dll "inObjectLibSystemInit" let oli' = mkObjectLibSystemInitFunction oli ola <- dlsym dll "inObjectLibSystemAddEntity" let ola' = mkObjectLibSystemAddEntityFunction ola olr <- dlsym dll "inObjectLibSystemRemoveEntity" let olr' = mkObjectLibSystemRemoveEntityFunction olr olu <- dlsym dll "inObjectLibSystemShutdown" let olu' = mkObjectLibSystemShutdownFunction olu ols <- dlsym dll "inObjectLibSystemStep" let ols' = mkObjectLibSystemStepFunction ols cbi <- dlsym dll "inCallbackSystemInit" let cbi' = mkCallbackSystemInitFunction cbi cbr <- dlsym dll "inCallbackSystemRegisterReceiver" let cbr' = mkCallbackSystemRegisterReceiverFunction cbr cbu <- dlsym dll "inCallbackSystemShutdown" let cbu' = mkCallbackSystemShutdownFunction cbu cbs <- dlsym dll "inCallbackSystemStep" let cbs' = mkCallbackSystemStepFunction cbs ref <- newIORef $ EntityInterface ec' er' ew' ei' ed' oli' ola' olr' olu' ols' cbi' cbr' cbu' cbs' return ref ) #endif type CStringCLen i = (CString, i) unsafeUseAsCStringLen' :: (Integral i) => ByteString -> (CStringCLen i -> IO a) -> IO a unsafeUseAsCStringLen' str fn = unsafeUseAsCStringLen (toStrict 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 (eCreate dei) a1'1 a1'2 a2') >> peek a2' >>= \a2'' -> return (a2'') entityDestroy :: Ptr () -> IO () entityDestroy a1 = (do dei <- readIORef dynamicEI (eDestroy dei) a1) >> return () entityId :: Ptr () -> IO ByteString entityId ep = do dei <- readIORef dynamicEI pbs <- newIORef undefined fp <- (mkMsgFnPtr (\_ p len -> do bs <- packCStringLen (p, fromIntegral len) writeIORef pbs bs return () )) (eId dei) ep nullPtr fp bs <- readIORef pbs return (fromStrict bs) entityWrite :: (Ptr ()) -> Word64 -> ByteString -> IO () entityWrite a1 a2 a3 = unsafeUseAsCStringLen' a3 $ \(a3'1, a3'2) -> (do dei <- readIORef dynamicEI (eWrite dei) a1 a2 a3'1 a3'2) >> return () entityRead :: Ptr () -> Word64 -> IO ByteString entityRead ep ct = do dei <- readIORef dynamicEI pbs <- newIORef undefined fp <- (mkMsgFnPtr (\_ p len -> do bs <- packCStringLen (p, fromIntegral len) writeIORef pbs bs return () )) (eRead dei) ep ct (nullPtr) fp bs <- readIORef pbs return (fromStrict bs) objectLibSystemCreate :: ByteString -> IO (Ptr ()) objectLibSystemCreate a1 = unsafeUseAsCStringLen' a1 $ \(a1'1, a1'2) -> alloca $ \a2' -> (do dei <- readIORef dynamicEI (olsInit dei) a1'1 a2') >> peek a2'>>= \a2'' -> return (a2'') objectLibSystemAddEntity :: (Ptr ()) -> (Ptr ()) -> IO () objectLibSystemAddEntity a1 a2 = let {a1' = id a1; a2' = id a2} in (do dei <- readIORef dynamicEI (olsAddEntity dei) a1' a2') >> return () objectLibSystemStep :: (Ptr ()) -> IO () objectLibSystemStep a1 = let {a1' = id a1} in (do dei <- readIORef dynamicEI (olsStep dei) a1') >> return () objectLibSystemShutdown :: (Ptr ()) -> IO () objectLibSystemShutdown a1 = let {a1' = id a1} in (do dei <- readIORef dynamicEI (olsShutdown dei) a1') >> return () callbackSystemCreate :: IO ((Ptr ())) callbackSystemCreate = alloca $ \a1' -> (do dei <- readIORef dynamicEI (cbsInit dei) a1') >> peek a1'>>= \a1'' -> return (a1'') callbackSystemRegisterReceiver :: (Ptr ()) -> (Ptr ()) -> (Word64) -> (FunPtr (Ptr () -> Word64 -> Ptr CChar -> Word32 -> IO Int32)) -> 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 (cbsRegisterReceiver dei) a1' a2' a3' a4') >> return () callbackSystemStep :: (Ptr ()) -> IO () callbackSystemStep a1 = let {a1' = id a1} in (do dei <- readIORef dynamicEI (cbsStep dei) a1') >> return () callbackSystemShutdown :: (Ptr ()) -> IO () callbackSystemShutdown a1 = let {a1' = id a1} in (do dei <- readIORef dynamicEI (cbsShutdown dei) a1') >> return ()