diff --git a/src/TDLib/EventLoop.hs b/src/TDLib/EventLoop.hs --- a/src/TDLib/EventLoop.hs +++ b/src/TDLib/EventLoop.hs @@ -18,10 +18,8 @@ import Control.Monad import Control.Monad.Loops import Data.Aeson -import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy (toStrict) import qualified Data.HashMap.Strict as HM -import qualified Data.HashMap.Strict as HM import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as M import Data.Maybe @@ -119,6 +117,7 @@ case m of Error _ -> throwIO $ UnableToParseValue v Success r -> pure r + v -> throwIO $ UnableToParseValue v -- | runs the TDLib effect runTDLibEventLoop :: Members '[Embed IO] r => Double -> InChan Update -> Sem (TDLib ': r) a -> Sem r a diff --git a/src/TDLib/TDJson.hs b/src/TDLib/TDJson.hs --- a/src/TDLib/TDJson.hs +++ b/src/TDLib/TDJson.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InterruptibleFFI #-} -- | Bindings to TDLib Json interface module TDLib.TDJson @@ -38,39 +39,39 @@ type ClientPtr = Ptr () -foreign import ccall "td_json_client_create" +foreign import ccall interruptible "td_json_client_create" tdJsonClientCreate :: IO ClientPtr -foreign import ccall "td_json_client_send" +foreign import ccall interruptible "td_json_client_send" tdJsonClientSend :: ClientPtr -> CString -> IO () -foreign import ccall "td_json_client_receive" +foreign import ccall interruptible "td_json_client_receive" tdJsonClientReceive :: ClientPtr -> CDouble -> IO CString -foreign import ccall "td_json_client_execute" - tdJsonClientExecute :: ClientPtr -> CString -> IO () +foreign import ccall interruptible "td_json_client_execute" + tdJsonClientExecute :: ClientPtr -> CString -> IO CString -foreign import ccall "td_json_client_destroy" +foreign import ccall interruptible "td_json_client_destroy" tdJsonClientDestroy :: ClientPtr -> IO () -foreign import ccall "&td_json_client_destroy" +foreign import ccall interruptible "&td_json_client_destroy" p_clientDestory :: FunPtr (ClientPtr -> IO ()) -foreign import ccall "td_set_log_file_path" +foreign import ccall interruptible "td_set_log_file_path" tdSetLogFilePath :: CString -> IO CInt -foreign import ccall "td_set_log_max_file_size" +foreign import ccall interruptible "td_set_log_max_file_size" tdSetLogMaxFileSize :: CLLong -> IO () -foreign import ccall "td_set_log_verbosity_level" +foreign import ccall interruptible "td_set_log_verbosity_level" tdSetLogVerbosityLevel :: CInt -> IO () type CallbackPtr = FunPtr (CString -> IO ()) -foreign import ccall "td_set_log_fatal_error_callback" +foreign import ccall interruptible "td_set_log_fatal_error_callback" tdSetLogFatalErrorCallback :: CallbackPtr -> IO () -foreign import ccall "wrapper" +foreign import ccall interruptible "wrapper" mkCallbackPtr_ :: (CString -> IO ()) -> IO CallbackPtr mkCallbackPtr :: (ByteString -> IO ()) -> IO CallbackPtr @@ -121,11 +122,14 @@ Client -> -- | JSON-serialized null-terminated request to TDLib. ByteString -> - IO () + IO (Maybe ByteString) clientExecute (Client fptr) cmd = useAsCString cmd $ \cstr -> withForeignPtr fptr $ \ptr -> do - tdJsonClientExecute ptr cstr + cs <- tdJsonClientExecute ptr cstr + if cs == nullPtr + then pure Nothing + else Just <$> packCString cs -- | Destroys the TDLib client instance. After this is called the client instance shouldn't be used anymore. destroyClient :: diff --git a/tdlib.cabal b/tdlib.cabal --- a/tdlib.cabal +++ b/tdlib.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e0350137321b986ba9d30546b221776f1fc4d0f228d731766e5bfeb99f0842bb +-- hash: d287bd2284586f7f41e71152629ccc38f4bf2443d1ad489bcca5499b9b6c9a5f name: tdlib -version: 0.1.4 +version: 0.1.5 license: BSD3 license-file: LICENSE copyright: (c) 2020 Poscat @@ -42,19 +42,18 @@ tdjson ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively build-depends: - aeson, + aeson >=1.4.7 && <1.6, base >=4.10 && <5, - base64-bytestring-type, - bytestring >=0.10.10.0 && <0.11, - containers, + bytestring, + containers >=1.6.2.1 && <1.7, monad-loops, - polysemy, - polysemy-plugin, - stm, - tdlib-types, + polysemy >=1.3.0.0 && <1.4, + polysemy-plugin >=0.2.5.0 && <0.3, + stm >=2.5.0.0 && <2.6, + tdlib-types >=0.1.0 && <0.2, text, - unagi-chan, - unordered-containers + unagi-chan >=0.2.5.0 && <0.3, + unordered-containers >=0.2.10.0 && <0.3 test-suite tdlib-test type: exitcode-stdio-1.0 @@ -69,20 +68,19 @@ tdjson ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -threaded -rtsopts -with-rtsopts=-N build-depends: - QuickCheck, - aeson, + QuickCheck >=2.14 && <2.15, + aeson >=1.4.7 && <1.6, base >=4.10 && <5, - base64-bytestring-type, - bytestring >=0.10.10.0 && <0.11, - containers, - generic-random, - hspec, + base64-bytestring-type >=1.0.1 && <1.1, + bytestring, + containers >=1.6.2.1 && <1.7, monad-loops, - polysemy, - polysemy-plugin, - stm, + polysemy >=1.3.0.0 && <1.4, + polysemy-plugin >=0.2.5.0 && <0.3, + quickcheck-text >=0.1.2.1 && <0.2, + stm >=2.5.0.0 && <2.6, tdlib, - tdlib-types, + tdlib-types >=0.1.0 && <0.2, text, - unagi-chan, - unordered-containers + unagi-chan >=0.2.5.0 && <0.3, + unordered-containers >=0.2.10.0 && <0.3 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,23 +1,98 @@ module Main where +import Control.Concurrent (forkIO) import Control.Concurrent.Chan.Unagi -import Polysemy +import Data.ByteString (ByteString) +import Data.ByteString.Base64.Type +import Data.Text.Arbitrary +import Polysemy hiding (run) import TDLib.Effect import TDLib.EventLoop import TDLib.Generated.FunArgs import TDLib.Generated.Functions -import TDLib.Generated.Types -import Test.Hspec +import TDLib.Generated.Types hiding (Text) +import TDLib.Types.Common import Test.QuickCheck +import Test.QuickCheck.Monadic +-- ** Helper functions + +mm :: + Testable a => + InChan Update -> + PropertyM (Sem '[TDLib, Embed IO]) a -> + Property +mm ichan = monadic (rr ichan) + +rr :: + Testable a => + InChan Update -> + Sem '[TDLib, Embed IO] a -> + Property +rr ichan m = (monadicIO . run . runM . runTDLibEventLoop 0.1 ichan) (setVerbosity Fatal >> m) + +updateConsumer :: OutChan Update -> IO () +updateConsumer chan = go + where + go = do + readChan chan + go + +-- ** Main + main :: IO () main = do (ichan, ochan) <- newChan - runM $ runTDLibEventLoop 5 ichan $ do - setLogPath "test-log.txt" - r <- testSquareInt (TestSquareInt 2) - embed $ print r + forkIO $ updateConsumer ochan + quickCheck $ squareInt ichan + quickCheck $ callEmpty ichan + quickCheck $ callString ichan + quickCheck $ callVecInt ichan + quickCheck $ callVecIntObject ichan + quickCheck $ callVecString ichan + quickCheck $ callVecStringObject ichan -hspecTest :: IO () -hspecTest = hspec $ do - pure () +-- ** Properties + +squareInt :: InChan Update -> I32 -> Property +squareInt ichan i = mm ichan $ do + r <- run $ testSquareInt (TestSquareInt i) + assert $ Inr (TestInt $ (i :: Int) ^ (2 :: Int)) == r + +callEmpty :: InChan Update -> Property +callEmpty ichan = mm ichan $ do + ok <- run $ testCallEmpty TestCallEmpty + assert $ Inr Ok == ok + +callString :: InChan Update -> Text -> Property +callString ichan t = mm ichan $ do + r <- run $ testCallString (TestCallString t) + assert $ Inr (TestString t) == r + +callVecInt :: InChan Update -> [I32] -> Property +callVecInt ichan vec = mm ichan $ do + r <- run $ testCallVectorInt (TestCallVectorInt vec) + assert $ Inr (TestVectorInt vec) == r + +callVecIntObject :: InChan Update -> [I32] -> Property +callVecIntObject ichan vec = mm ichan $ do + let v' = fmap TestInt vec + r <- run $ testCallVectorIntObject (TestCallVectorIntObject v') + assert $ Inr (TestVectorIntObject v') == r + +callVecString :: InChan Update -> [Text] -> Property +callVecString ichan vec = mm ichan $ do + r <- run $ testCallVectorString (TestCallVectorString vec) + assert $ Inr (TestVectorString vec) == r + +callVecStringObject :: InChan Update -> [Text] -> Property +callVecStringObject ichan vec = mm ichan $ do + let v' = fmap TestString vec + r <- run $ testCallVectorStringObject (TestCallVectorStringObject v') + assert $ Inr (TestVectorStringObject v') == r + +callBytes :: InChan Update -> ByteString -> Property +callBytes ichan bs = mm ichan $ do + let bs' = makeByteString64 bs + r <- run $ testCallBytes (TestCallBytes bs') + assert $ Inr (TestBytes bs') == r