tdlib 0.1.1 → 0.1.3
raw patch · 7 files changed
+254/−60 lines, 7 filesdep +QuickCheckdep +aesondep +base64-bytestring-type
Dependencies added: QuickCheck, aeson, base64-bytestring-type, containers, generic-random, hspec, monad-loops, polysemy, polysemy-plugin, stm, tdlib-types, text, unagi-chan, unordered-containers
Files
- CHANGELOG.md +4/−0
- README.md +1/−1
- src/TDLib/Errors.hs +14/−0
- src/TDLib/EventLoop.hs +136/−0
- src/TDLib/TDJson.hs +6/−14
- tdlib.cabal +72/−44
- test/Spec.hs +21/−1
CHANGELOG.md view
@@ -8,3 +8,7 @@ * Fix typo +## 0.1.2++* Handle null pointers+
README.md view
@@ -1,6 +1,6 @@ # tdlib -Low level Haskell bindings to the TDLib JSON interface.+Haskell bindings to the TDLib API though the json interface. ## Building
+ src/TDLib/Errors.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveAnyClass #-}++module TDLib.Errors where++import Control.Exception+import Data.Aeson+import Data.ByteString (ByteString)++data TDLibError+ = ExtraFieldNotInt !Value+ | UnableToParseJSON !ByteString+ | UnableToParseValue !Value+ | UnknownError+ deriving (Show, Eq, Exception)
+ src/TDLib/EventLoop.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ExistentialQuantification #-}++-- | A heavyweight TDLib effect intepreter written using event loop+module TDLib.EventLoop where++import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.Chan.Unagi+import Control.Concurrent.STM+import Control.Exception+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+import Polysemy+import TDLib.Effect+import TDLib.Errors+import TDLib.Generated.Types hiding (Error (..))+import TDLib.TDJson+import TDLib.Types.Common hiding (Error)++type Ans = TVar (IntMap Value)++type Locks = TVar (IntMap ())++type Counter = TVar Int++newCounter :: IO Counter+newCounter = newTVarIO 0++countUp :: Counter -> IO Int+countUp counter = atomically $ do+ i <- readTVar counter+ let n = i + 1+ writeTVar counter n+ pure n++lookupExtra :: Value -> Maybe Int+lookupExtra v@(Object hm) =+ case HM.lookup "@extra" hm of+ Nothing -> Nothing+ Just v' -> case fromJSON v' of+ Error _ -> throw $ ExtraFieldNotInt v+ Success i -> Just i+lookupExtra _ = error "Not a object"++insertAns :: Int -> Locks -> Ans -> Value -> STM ()+insertAns index lck ans val = do+ m <- readTVar lck+ let r = M.lookup index m+ if isJust r+ then writeTVar lck (M.delete index m)+ else modifyTVar ans (M.insert index val)++waitRead :: Int -> Ans -> STM Value+waitRead index ans = do+ m <- readTVar ans+ let mr = M.lookup index m+ case mr of+ Nothing -> retry+ Just v -> do+ writeTVar ans (M.delete index m)+ pure v++lock :: Int -> Locks -> STM ()+lock index lck = modifyTVar lck (M.insert index ())++readAns :: Int -> Locks -> Ans -> IO Value+readAns index lck ans =+ readV `onException` cleanUp+ where+ readV = atomically $ do+ waitRead index ans+ cleanUp = atomically $ do+ m <- readTVar ans+ let ma = M.lookup index m+ case ma of+ Nothing -> lock index lck+ _ -> writeTVar ans (M.delete index m)++loop :: Client -> Double -> Locks -> Ans -> InChan Update -> IO a+loop client timeout lck ans chan = forever $ do+ bs <- untilJust $ clientReceive client timeout+ let m = decodeStrict bs+ case m of+ Nothing -> throwIO $ UnableToParseJSON bs+ Just v -> do+ case lookupExtra v of+ Nothing -> do+ let r = fromJSON v+ case r of+ Error _ -> throwIO $ UnableToParseValue v+ Success u -> writeChan chan u+ Just i -> atomically $ insertAns i lck ans v++runCommand :: (ToJSON a, FromJSON b, FromJSON err) => Client -> Int -> Locks -> Ans -> a -> IO (err ∪ b)+runCommand client i lck ans cmd =+ case toJSON cmd of+ Object hm -> do+ let o' = Object (hm <> HM.fromList [("@extra" .= i)])+ clientSend client (toStrict $ encode o')+ v <- readAns i lck ans+ let m = fromJSON v+ case m of+ Error _ -> throwIO $ UnableToParseValue v+ Success r -> pure r++runTDLibEventLoop :: Members '[Embed IO] r => Double -> InChan Update -> Sem (TDLib ': r) a -> Sem r a+runTDLibEventLoop timeout chan m = do+ lck <- embed $ newTVarIO mempty+ ans <- embed $ newTVarIO mempty+ c <- embed newClient+ tid <- embed $ forkIO $ loop c timeout lck ans chan+ counter <- embed newCounter+ let runTD = interpret $ \case+ RunCmd cmd -> do+ i <- embed $ countUp counter+ embed $ runCommand c i lck ans cmd+ SetVerbosity verbosity -> do+ embed $ setLogVerbosityLevel verbosity+ SetFatalErrorCallback callback -> do+ embed $ setLogFatalErrorCallback callback+ SetLogPath path -> do+ embed $ setLogFilePath path+ SetLogMaxSize size -> do+ embed $ setLogMaxFileSize size+ r <- runTD m+ embed $ do+ killThread tid+ destroyClient c+ pure r
src/TDLib/TDJson.hs view
@@ -4,8 +4,7 @@ -- | Bindings to TDLib Json interface module TDLib.TDJson- ( Verbosity (..),- Client,+ ( Client, -- * Creating, Destroying and Interacting with clients newClient,@@ -31,6 +30,7 @@ import Foreign.C import Foreign.ForeignPtr import Foreign.Ptr+import TDLib.Types.Common -- | TDLib client, will be automacially destroyed as soon as there are no references pointing to it (backed by 'ForeignPtr') newtype Client = Client (ForeignPtr ())@@ -38,16 +38,6 @@ type ClientPtr = Ptr () --- | Logging verbosity-data Verbosity- = Fatal- | Error- | Warning- | Info- | Debug- | Verbose- deriving (Show, Eq, Enum)- foreign import ccall "td_json_client_create" tdJsonClientCreate :: IO ClientPtr @@ -117,11 +107,13 @@ -- | The maximum number of seconds allowed for this function to wait for new data. Double -> -- | JSON-serialized null-terminated incoming update or request response. May be NULL if the timeout expires.- IO ByteString+ IO (Maybe ByteString) clientReceive (Client fptr) t = withForeignPtr fptr $ \ptr -> do cs <- tdJsonClientReceive ptr (CDouble t)- packCString cs+ if cs == nullPtr+ then pure Nothing+ else Just <$> packCString cs -- | Synchronously executes TDLib request. May be called from any thread. Only a few requests can be executed synchronously. Returned pointer will be deallocated by TDLib during next call to 'clientReceive' or 'clientExecute' in the same thread, so it can't be used after that. clientExecute ::
tdlib.cabal view
@@ -4,57 +4,85 @@ -- -- see: https://github.com/sol/hpack ----- hash: 33e664198769cc03ac4f268b9eade1c40128e7135e2ac1bf25d9f8a814cf4608+-- hash: 50a170d1232470269e1a3fb32c1ee38e2e1b8b8be070e885ce94d096ea17abb6 -name: tdlib-version: 0.1.1-synopsis: Bidings to the tdlib json interface-description: Please see the README on GitHub at <https://github.com/poscat0x04/tdlib#readme>-category: FFI-homepage: https://github.com/poscat0x04/tdlib#readme-bug-reports: https://github.com/poscat0x04/tdlib/issues-author: Poscat-maintainer: poscat@mail.poscat.moe-copyright: (c) 2020 Poscat-license: BSD3-license-file: LICENSE-build-type: Simple+name: tdlib+version: 0.1.3+license: BSD3+license-file: LICENSE+copyright: (c) 2020 Poscat+maintainer: poscat@mail.poscat.moe+author: Poscat+homepage: https://github.com/poscat0x04/tdlib#readme+bug-reports: https://github.com/poscat0x04/tdlib/issues+synopsis: Bidings to the tdlib json interface+description: Please see the README on GitHub at <https://github.com/poscat0x04/tdlib#readme>+category: FFI+build-type: Simple extra-source-files: README.md CHANGELOG.md source-repository head- type: git- location: https://github.com/poscat0x04/tdlib+ type: git+ location: https://github.com/poscat0x04/tdlib library- exposed-modules:- TDLib.TDJson- other-modules:- Paths_tdlib- hs-source-dirs:- src- default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards- extra-libraries:- tdjson- build-depends:- base >=4.10 && <5- , bytestring >=0.10.10.0 && <0.11- default-language: Haskell2010+ exposed-modules:+ TDLib.Errors+ TDLib.EventLoop+ TDLib.TDJson+ hs-source-dirs:+ src+ other-modules:+ Paths_tdlib+ default-language: Haskell2010+ default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards+ extra-libraries:+ tdjson+ ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively+ build-depends:+ aeson,+ base >=4.10 && <5,+ base64-bytestring-type,+ bytestring >=0.10.10.0 && <0.11,+ containers,+ monad-loops,+ polysemy,+ polysemy-plugin,+ stm,+ tdlib-types,+ text,+ unagi-chan,+ unordered-containers test-suite tdlib-test- type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules:- Paths_tdlib- hs-source-dirs:- test- default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards- ghc-options: -threaded -rtsopts -with-rtsopts=-N- extra-libraries:- tdjson- build-depends:- base >=4.10 && <5- , bytestring >=0.10.10.0 && <0.11- , tdlib- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ other-modules:+ Paths_tdlib+ default-language: Haskell2010+ default-extensions: OverloadedStrings FlexibleInstances FlexibleContexts FunctionalDependencies InstanceSigs ConstraintKinds DeriveGeneric DeriveFunctor DeriveFoldable DeriveTraversable TypeOperators TypeApplications TypeFamilies KindSignatures PartialTypeSignatures DataKinds StarIsType ScopedTypeVariables ExplicitForAll ViewPatterns BangPatterns LambdaCase TupleSections EmptyCase MultiWayIf UnicodeSyntax PatternSynonyms RecordWildCards+ extra-libraries:+ tdjson+ ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck,+ aeson,+ base >=4.10 && <5,+ base64-bytestring-type,+ bytestring >=0.10.10.0 && <0.11,+ containers,+ generic-random,+ hspec,+ monad-loops,+ polysemy,+ polysemy-plugin,+ stm,+ tdlib,+ tdlib-types,+ text,+ unagi-chan,+ unordered-containers
test/Spec.hs view
@@ -1,3 +1,23 @@ module Main where -main = pure ()+import Control.Concurrent.Chan.Unagi+import Polysemy+import TDLib.Effect+import TDLib.EventLoop+import TDLib.Generated.FunArgs+import TDLib.Generated.Functions+import TDLib.Generated.Types+import Test.Hspec+import Test.QuickCheck++main :: IO ()+main = do+ (ichan, ochan) <- newChan+ runM $ runTDLibEventLoop 5 ichan $ do+ setLogPath "test-log.txt"+ r <- testSquareInt (TestSquareInt 2)+ embed $ print r++hspecTest :: IO ()+hspecTest = hspec $ do+ pure ()