You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
108 lines
3.2 KiB
108 lines
3.2 KiB
3 years ago
|
|
||
|
|
module TXML
|
||
|
|
(
|
||
|
|
initialize
|
||
|
|
, uninitialize
|
||
|
|
, sendCommand
|
||
|
|
, setCallback
|
||
|
|
, freeCallback
|
||
|
|
, Callback
|
||
|
|
, LogLevel(..)
|
||
|
|
) where
|
||
|
|
|
||
|
|
import qualified Data.ByteString.Char8 as BS
|
||
|
|
import qualified Data.Text as T
|
||
|
|
import Data.Text.Encoding
|
||
|
|
import Data.Text.Encoding.Error
|
||
|
|
import Foreign.C.String
|
||
|
|
import Foreign.C.Types
|
||
|
|
import Foreign.Ptr
|
||
|
|
|
||
|
|
foreign import ccall "Initialize" c_Initialize :: CString -> CInt -> IO CString
|
||
|
|
foreign import ccall "UnInitialize" c_UnInitialize :: IO CString
|
||
|
|
foreign import ccall "SendCommand" c_SendCommand :: CString -> IO CString
|
||
|
|
foreign import ccall "SetCallback" c_SetCallback ::
|
||
|
|
FunPtr (CString -> IO CBool) -> IO CBool
|
||
|
|
foreign import ccall "FreeMemory" c_FreeMemory :: CString -> IO CBool
|
||
|
|
|
||
|
|
{-
|
||
|
|
foreign import ccall "SetLogLevel" c_SetLogLevel :: CInt -> IO CString
|
||
|
|
foreign import ccall "SetCallbackEx" c_SetCallbackEx ::
|
||
|
|
FunPtr (CString -> CBool) -> Ptr () -> IO CBool
|
||
|
|
-}
|
||
|
|
|
||
|
|
foreign import ccall "wrapper" createCallbackPtr ::
|
||
|
|
(CString -> IO CBool) -> IO (FunPtr (CString -> IO CBool))
|
||
|
|
|
||
|
|
data LogLevel =
|
||
|
|
Debug
|
||
|
|
| Info
|
||
|
|
| Warning
|
||
|
|
deriving (Show, Eq, Ord)
|
||
|
|
|
||
|
|
newtype Callback = Callback { unCallback :: FunPtr (CString -> IO CBool)}
|
||
|
|
|
||
|
|
logLevelToInt :: LogLevel -> CInt
|
||
|
|
logLevelToInt Debug = 3
|
||
|
|
logLevelToInt Info = 2
|
||
|
|
logLevelToInt Warning = 1
|
||
|
|
|
||
|
|
strErrorStringToResult :: CString -> IO (Either T.Text ())
|
||
|
|
strErrorStringToResult str =
|
||
|
|
if nullPtr /= str
|
||
|
|
then do
|
||
|
|
packed <- BS.packCString str
|
||
|
|
let result = decodeUtf8With lenientDecode $ packed
|
||
|
|
_ <- c_FreeMemory str
|
||
|
|
pure $ Left result
|
||
|
|
else
|
||
|
|
pure $ Right ()
|
||
|
|
|
||
|
|
rawStringToResult :: CString -> IO (Either T.Text ())
|
||
|
|
rawStringToResult str =
|
||
|
|
if nullPtr /= str
|
||
|
|
then do
|
||
|
|
packed <- BS.packCString str
|
||
|
|
let result = decodeUtf8With lenientDecode $ packed
|
||
|
|
_ <- c_FreeMemory str
|
||
|
|
if "<result success=\"true\"/>" `T.isPrefixOf` result
|
||
|
|
then pure $ Right ()
|
||
|
|
else pure $ Left result
|
||
|
|
else
|
||
|
|
pure $ Left ""
|
||
|
|
|
||
|
|
initialize :: FilePath -> LogLevel -> IO (Either T.Text ())
|
||
|
|
initialize fp loglevel =
|
||
|
|
BS.useAsCString (encodeUtf8 . T.pack $ fp) $ \fpcstr ->
|
||
|
|
c_Initialize fpcstr (logLevelToInt loglevel) >>= strErrorStringToResult
|
||
|
|
|
||
|
|
uninitialize :: IO (Either T.Text ())
|
||
|
|
uninitialize = c_UnInitialize >>= rawStringToResult
|
||
|
|
|
||
|
|
sendCommand :: T.Text -> IO (Either T.Text ())
|
||
|
|
sendCommand cmdData = do
|
||
|
|
BS.useAsCString (encodeUtf8 cmdData) $ \fpcstr ->
|
||
|
|
c_SendCommand fpcstr >>= rawStringToResult
|
||
|
|
|
||
|
|
setCallback :: (T.Text -> IO Bool) -> IO (Maybe Callback)
|
||
|
|
setCallback callback = do
|
||
|
|
wrappedCallback <- createCallbackPtr (\x -> do
|
||
|
|
packed <- BS.packCString x
|
||
|
|
boolToCBool <$> (callback $
|
||
|
|
decodeUtf8With lenientDecode
|
||
|
|
packed))
|
||
|
|
ret <- c_SetCallback wrappedCallback
|
||
|
|
if ret /= 0
|
||
|
|
then return . Just . Callback $ wrappedCallback
|
||
|
|
else do
|
||
|
|
freeHaskellFunPtr wrappedCallback
|
||
|
|
return Nothing
|
||
|
|
where
|
||
|
|
boolToCBool False = 0
|
||
|
|
boolToCBool True = 1
|
||
|
|
|
||
|
|
freeCallback :: Callback -> IO ()
|
||
|
|
freeCallback = freeHaskellFunPtr . unCallback
|
||
|
|
|
||
|
|
|