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.
107 lines
3.2 KiB
107 lines
3.2 KiB
|
|
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 |
|
|
|
|
|
|