{-# LANGUAGE ExistentialQuantification #-}

-- | A heavyweight TDLib effect intepreter written using event loop
module TDLib.EventLoop
  ( -- * effect interpreter
    runTDLibEventLoop,

    -- * low level functions
    Ans,
    Locks,
    runCommand,
    loop,
  )
where

import Control.Concurrent (forkIO, killThread)
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Control.Monad.Loops
import Data.Aeson
import Data.ByteString.Lazy (toStrict)
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 (..), error)
import TDLib.TDJson

type Ans = TVar (IntMap Value)

type Locks = TVar (IntMap ())

type Counter = TVar Int

newCounter :: IO Counter
newCounter :: IO Counter
newCounter = Int -> IO Counter
forall a. a -> IO (TVar a)
newTVarIO 0

countUp :: Counter -> IO Int
countUp :: Counter -> IO Int
countUp counter :: Counter
counter = STM Int -> IO Int
forall a. STM a -> IO a
atomically (STM Int -> IO Int) -> STM Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
  Int
i <- Counter -> STM Int
forall a. TVar a -> STM a
readTVar Counter
counter
  let n :: Int
n = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
  Counter -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Counter
counter Int
n
  Int -> STM Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n

lookupExtra :: Value -> Maybe Int
lookupExtra :: Value -> Maybe Int
lookupExtra v :: Value
v@(Object hm :: Object
hm) =
  case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "@extra" Object
hm of
    Nothing -> Maybe Int
forall a. Maybe a
Nothing
    Just v' :: Value
v' -> case Value -> Result Int
forall a. FromJSON a => Value -> Result a
fromJSON Value
v' of
      Error _ -> TDLibError -> Maybe Int
forall a e. Exception e => e -> a
throw (TDLibError -> Maybe Int) -> TDLibError -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Value -> TDLibError
ExtraFieldNotInt Value
v
      Success i :: Int
i -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
lookupExtra _ = [Char] -> Maybe Int
forall a. HasCallStack => [Char] -> a
error "Not a object"

insertAns :: Int -> Locks -> Ans -> Value -> STM ()
insertAns :: Int -> Locks -> Ans -> Value -> STM ()
insertAns index :: Int
index lck :: Locks
lck ans :: Ans
ans val :: Value
val = do
  IntMap ()
m <- Locks -> STM (IntMap ())
forall a. TVar a -> STM a
readTVar Locks
lck
  let r :: Maybe ()
r = Int -> IntMap () -> Maybe ()
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
index IntMap ()
m
  if Maybe () -> Bool
forall a. Maybe a -> Bool
isJust Maybe ()
r
    then Locks -> IntMap () -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Locks
lck (Int -> IntMap () -> IntMap ()
forall a. Int -> IntMap a -> IntMap a
M.delete Int
index IntMap ()
m)
    else Ans -> (IntMap Value -> IntMap Value) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Ans
ans (Int -> Value -> IntMap Value -> IntMap Value
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
index Value
val)

waitRead :: Int -> Ans -> STM Value
waitRead :: Int -> Ans -> STM Value
waitRead index :: Int
index ans :: Ans
ans = do
  IntMap Value
m <- Ans -> STM (IntMap Value)
forall a. TVar a -> STM a
readTVar Ans
ans
  let mr :: Maybe Value
mr = Int -> IntMap Value -> Maybe Value
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
index IntMap Value
m
  case Maybe Value
mr of
    Nothing -> STM Value
forall a. STM a
retry
    Just v :: Value
v -> do
      Ans -> IntMap Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Ans
ans (Int -> IntMap Value -> IntMap Value
forall a. Int -> IntMap a -> IntMap a
M.delete Int
index IntMap Value
m)
      Value -> STM Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

lock :: Int -> Locks -> STM ()
lock :: Int -> Locks -> STM ()
lock index :: Int
index lck :: Locks
lck = Locks -> (IntMap () -> IntMap ()) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Locks
lck (Int -> () -> IntMap () -> IntMap ()
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
index ())

readAns :: Int -> Locks -> Ans -> IO Value
readAns :: Int -> Locks -> Ans -> IO Value
readAns index :: Int
index lck :: Locks
lck ans :: Ans
ans =
  IO Value
readV IO Value -> IO () -> IO Value
forall a b. IO a -> IO b -> IO a
`onException` IO ()
cleanUp
  where
    readV :: IO Value
readV = STM Value -> IO Value
forall a. STM a -> IO a
atomically (STM Value -> IO Value) -> STM Value -> IO Value
forall a b. (a -> b) -> a -> b
$ do
      Int -> Ans -> STM Value
waitRead Int
index Ans
ans
    cleanUp :: IO ()
cleanUp = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      IntMap Value
m <- Ans -> STM (IntMap Value)
forall a. TVar a -> STM a
readTVar Ans
ans
      let ma :: Maybe Value
ma = Int -> IntMap Value -> Maybe Value
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
index IntMap Value
m
      case Maybe Value
ma of
        Nothing -> Int -> Locks -> STM ()
lock Int
index Locks
lck
        _ -> Ans -> IntMap Value -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Ans
ans (Int -> IntMap Value -> IntMap Value
forall a. Int -> IntMap a -> IntMap a
M.delete Int
index IntMap Value
m)

-- | runs the event loop that receives updates from the client and dispatches them
loop :: Client -> Double -> Locks -> Ans -> (Update -> IO ()) -> IO a
loop :: Client -> Double -> Locks -> Ans -> (Update -> IO ()) -> IO a
loop client :: Client
client timeout :: Double
timeout lck :: Locks
lck ans :: Ans
ans cont :: Update -> IO ()
cont = IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
  ByteString
bs <- IO (Maybe ByteString) -> IO ByteString
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m a
untilJust (IO (Maybe ByteString) -> IO ByteString)
-> IO (Maybe ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Client -> Double -> IO (Maybe ByteString)
clientReceive Client
client Double
timeout
  let m :: Maybe Value
m = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict ByteString
bs
  case Maybe Value
m of
    Nothing -> TDLibError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TDLibError -> IO ()) -> TDLibError -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> TDLibError
UnableToParseJSON ByteString
bs
    Just v :: Value
v -> do
      case Value -> Maybe Int
lookupExtra Value
v of
        Nothing -> do
          let r :: Result Update
r = Value -> Result Update
forall a. FromJSON a => Value -> Result a
fromJSON Value
v
          case Result Update
r of
            Error _ -> TDLibError -> IO ()
forall e a. Exception e => e -> IO a
throwIO (TDLibError -> IO ()) -> TDLibError -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> TDLibError
UnableToParseValue Value
v
            Success u :: Update
u -> Update -> IO ()
cont Update
u
        Just i :: Int
i -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Locks -> Ans -> Value -> STM ()
insertAns Int
i Locks
lck Ans
ans Value
v

-- | runs a command and waits for its answer
runCommand :: (ToJSON cmd, FromJSON res) => Client -> Int -> Locks -> Ans -> cmd -> IO res
runCommand :: Client -> Int -> Locks -> Ans -> cmd -> IO res
runCommand client :: Client
client i :: Int
i lck :: Locks
lck ans :: Ans
ans cmd :: cmd
cmd =
  case cmd -> Value
forall a. ToJSON a => a -> Value
toJSON cmd
cmd of
    Object hm :: Object
hm -> do
      let o' :: Value
o' = Object -> Value
Object (Object
hm Object -> Object -> Object
forall a. Semigroup a => a -> a -> a
<> [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [("@extra" Text -> Int -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
i)])
      Client -> ByteString -> IO ()
clientSend Client
client (ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
o')
      Value
v <- Int -> Locks -> Ans -> IO Value
readAns Int
i Locks
lck Ans
ans
      let m :: Result res
m = Value -> Result res
forall a. FromJSON a => Value -> Result a
fromJSON Value
v
      case Result res
m of
        Error _ -> TDLibError -> IO res
forall e a. Exception e => e -> IO a
throwIO (TDLibError -> IO res) -> TDLibError -> IO res
forall a b. (a -> b) -> a -> b
$ Value -> TDLibError
UnableToParseValue Value
v
        Success r :: res
r -> res -> IO res
forall (f :: * -> *) a. Applicative f => a -> f a
pure res
r
    v :: Value
v -> TDLibError -> IO res
forall e a. Exception e => e -> IO a
throwIO (TDLibError -> IO res) -> TDLibError -> IO res
forall a b. (a -> b) -> a -> b
$ Value -> TDLibError
UnableToParseValue Value
v

-- | runs the TDLib effect
runTDLibEventLoop :: Members '[Embed IO] r => Double -> (Update -> IO ()) -> Sem (TDLib ': r) a -> Sem r a
runTDLibEventLoop :: Double -> (Update -> IO ()) -> Sem (TDLib : r) a -> Sem r a
runTDLibEventLoop timeout :: Double
timeout cont :: Update -> IO ()
cont m :: Sem (TDLib : r) a
m = do
  Locks
lck <- IO Locks -> Sem r Locks
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Locks -> Sem r Locks) -> IO Locks -> Sem r Locks
forall a b. (a -> b) -> a -> b
$ IntMap () -> IO Locks
forall a. a -> IO (TVar a)
newTVarIO IntMap ()
forall a. Monoid a => a
mempty
  Ans
ans <- IO Ans -> Sem r Ans
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Ans -> Sem r Ans) -> IO Ans -> Sem r Ans
forall a b. (a -> b) -> a -> b
$ IntMap Value -> IO Ans
forall a. a -> IO (TVar a)
newTVarIO IntMap Value
forall a. Monoid a => a
mempty
  Client
c <- IO Client -> Sem r Client
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO Client
newClient
  ThreadId
tid <- IO ThreadId -> Sem r ThreadId
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO ThreadId -> Sem r ThreadId) -> IO ThreadId -> Sem r ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Client -> Double -> Locks -> Ans -> (Update -> IO ()) -> IO ()
forall a.
Client -> Double -> Locks -> Ans -> (Update -> IO ()) -> IO a
loop Client
c Double
timeout Locks
lck Ans
ans Update -> IO ()
cont
  Counter
counter <- IO Counter -> Sem r Counter
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO Counter
newCounter
  let runTD :: Sem (TDLib : r) a -> Sem r a
runTD = (forall x (m :: * -> *). TDLib m x -> Sem r x)
-> Sem (TDLib : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (m :: * -> *). TDLib m x -> Sem r x)
 -> Sem (TDLib : r) a -> Sem r a)
-> (forall x (m :: * -> *). TDLib m x -> Sem r x)
-> Sem (TDLib : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
        RunCmd cmd -> do
          Int
i <- IO Int -> Sem r Int
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Int -> Sem r Int) -> IO Int -> Sem r Int
forall a b. (a -> b) -> a -> b
$ Counter -> IO Int
countUp Counter
counter
          IO x -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO x -> Sem r x) -> IO x -> Sem r x
forall a b. (a -> b) -> a -> b
$ Client -> Int -> Locks -> Ans -> cmd -> IO x
forall cmd res.
(ToJSON cmd, FromJSON res) =>
Client -> Int -> Locks -> Ans -> cmd -> IO res
runCommand Client
c Int
i Locks
lck Ans
ans cmd
cmd
        SetVerbosity verbosity -> do
          IO () -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r x) -> IO () -> Sem r x
forall a b. (a -> b) -> a -> b
$ Verbosity -> IO ()
setLogVerbosityLevel Verbosity
verbosity
        SetFatalErrorCallback callback -> do
          IO () -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r x) -> IO () -> Sem r x
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ()) -> IO ()
setLogFatalErrorCallback ByteString -> IO ()
callback
        SetLogPath path -> do
          IO Bool -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Bool -> Sem r x) -> IO Bool -> Sem r x
forall a b. (a -> b) -> a -> b
$ ByteString -> IO Bool
setLogFilePath ByteString
path
        SetLogMaxSize size -> do
          IO () -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r x) -> IO () -> Sem r x
forall a b. (a -> b) -> a -> b
$ Int64 -> IO ()
setLogMaxFileSize Int64
size
  a
r <- Sem (TDLib : r) a -> Sem r a
runTD Sem (TDLib : r) a
m
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
    ThreadId -> IO ()
killThread ThreadId
tid
    Client -> IO ()
destroyClient Client
c
  a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r