{-# LANGUAGE ExistentialQuantification #-}

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

    -- * low level functions
    runCommand,
    loop,
  )
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 :: 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 -> InChan Update -> IO a
loop :: Client -> Double -> Locks -> Ans -> InChan Update -> IO a
loop client :: Client
client timeout :: Double
timeout lck :: Locks
lck ans :: Ans
ans chan :: InChan Update
chan = 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 -> InChan Update -> Update -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan Update
chan 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 a, FromJSON b, FromJSON err) => Client -> Int -> Locks -> Ans -> a -> IO (err ∪ b)
runCommand :: Client -> Int -> Locks -> Ans -> a -> IO (err ∪ b)
runCommand client :: Client
client i :: Int
i lck :: Locks
lck ans :: Ans
ans cmd :: a
cmd =
  case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
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 (err ∪ b)
m = Value -> Result (err ∪ b)
forall a. FromJSON a => Value -> Result a
fromJSON Value
v
      case Result (err ∪ b)
m of
        Error _ -> TDLibError -> IO (err ∪ b)
forall e a. Exception e => e -> IO a
throwIO (TDLibError -> IO (err ∪ b)) -> TDLibError -> IO (err ∪ b)
forall a b. (a -> b) -> a -> b
$ Value -> TDLibError
UnableToParseValue Value
v
        Success r :: err ∪ b
r -> (err ∪ b) -> IO (err ∪ b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure err ∪ b
r

-- | runs the TDLib effect
runTDLibEventLoop :: Members '[Embed IO] r => Double -> InChan Update -> Sem (TDLib ': r) a -> Sem r a
runTDLibEventLoop :: Double -> InChan Update -> Sem (TDLib : r) a -> Sem r a
runTDLibEventLoop timeout :: Double
timeout chan :: InChan Update
chan 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 -> InChan Update -> IO ()
forall a. Client -> Double -> Locks -> Ans -> InChan Update -> IO a
loop Client
c Double
timeout Locks
lck Ans
ans InChan Update
chan
  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 (err ∪ res) -> Sem r x
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (err ∪ res) -> Sem r x) -> IO (err ∪ res) -> Sem r x
forall a b. (a -> b) -> a -> b
$ Client -> Int -> Locks -> Ans -> cmd -> IO (err ∪ res)
forall a b err.
(ToJSON a, FromJSON b, FromJSON err) =>
Client -> Int -> Locks -> Ans -> a -> IO (err ∪ b)
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