{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Telegram.Bot.Simple.BotApp.Internal where
import Control.Concurrent (ThreadId, forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad (forever, void)
import Control.Monad.Except (catchError)
import Control.Monad.Trans (liftIO)
import Data.Bifunctor (first)
import Data.Text (Text)
import Servant.Client (ClientEnv, ClientM, runClientM)
import qualified System.Cron as Cron
import qualified Telegram.Bot.API as Telegram
import Telegram.Bot.Simple.Eff
data BotApp model action = BotApp
{ botInitialModel :: model
, botAction :: Telegram.Update -> model -> Maybe action
, botHandler :: action -> model -> Eff action model
, botJobs :: [BotJob model action]
}
data BotJob model action = BotJob
{ botJobSchedule :: Text
, botJobTask :: model -> Eff action model
}
data BotEnv model action = BotEnv
{ botModelVar :: TVar model
, botActionsQueue :: TQueue (Maybe Telegram.Update, action)
, botClientEnv :: ClientEnv
, botUser :: Telegram.User
}
instance Functor (BotJob model) where
fmap f BotJob{..} = BotJob{ botJobTask = first f . botJobTask, .. }
runJobTask :: BotEnv model action -> (model -> Eff action model) -> IO ()
runJobTask botEnv@BotEnv{..} task = do
effects <- liftIO $ atomically $ do
model <- readTVar botModelVar
case runEff (task model) of
(newModel, effects) -> do
writeTVar botModelVar newModel
return effects
res <- flip runClientM botClientEnv $
mapM_ ((>>= liftIO . issueAction botEnv Nothing) . runBotM (BotContext botUser Nothing)) effects
case res of
Left err -> print err
Right _ -> return ()
scheduleBotJob :: BotEnv model action -> BotJob model action -> IO [ThreadId]
scheduleBotJob botEnv BotJob{..} = Cron.execSchedule $ do
Cron.addJob (runJobTask botEnv botJobTask) botJobSchedule
scheduleBotJobs :: BotEnv model action -> [BotJob model action] -> IO [ThreadId]
scheduleBotJobs botEnv jobs = concat
<$> traverse (scheduleBotJob botEnv) jobs
defaultBotEnv :: BotApp model action -> ClientEnv -> IO (BotEnv model action)
defaultBotEnv BotApp{..} env = BotEnv
<$> newTVarIO botInitialModel
<*> newTQueueIO
<*> pure env
<*> (either (error . show) Telegram.responseResult <$> runClientM Telegram.getMe env)
issueAction :: BotEnv model action -> Maybe Telegram.Update -> action -> IO ()
issueAction BotEnv{..} update action = atomically $
writeTQueue botActionsQueue (update, action)
processAction
:: BotApp model action
-> BotEnv model action
-> Maybe Telegram.Update
-> action
-> ClientM ()
processAction BotApp{..} botEnv@BotEnv{..} update action = do
effects <- liftIO $ atomically $ do
model <- readTVar botModelVar
case runEff (botHandler action model) of
(newModel, effects) -> do
writeTVar botModelVar newModel
return effects
mapM_ ((>>= liftIO . issueAction botEnv update) . runBotM (BotContext botUser update)) effects
processActionJob :: BotApp model action -> BotEnv model action -> ClientM ()
processActionJob botApp botEnv@BotEnv{..} = do
(update, action) <- liftIO . atomically $ readTQueue botActionsQueue
processAction botApp botEnv update action
processActionsIndefinitely
:: BotApp model action -> BotEnv model action -> IO ThreadId
processActionsIndefinitely botApp botEnv = forkIO . forever $ do
runClientM (processActionJob botApp botEnv) (botClientEnv botEnv)
startBotPolling :: BotApp model action -> BotEnv model action -> ClientM ()
startBotPolling BotApp{..} botEnv@BotEnv{..} = startPolling handleUpdate
where
handleUpdate update = liftIO . void . forkIO $ do
maction <- botAction update <$> readTVarIO botModelVar
case maction of
Nothing -> return ()
Just action -> issueAction botEnv (Just update) action
startPolling :: (Telegram.Update -> ClientM ()) -> ClientM ()
startPolling handleUpdate = go Nothing
where
go lastUpdateId = do
let inc (Telegram.UpdateId n) = Telegram.UpdateId (n + 1)
offset = fmap inc lastUpdateId
res <-
(Right <$> Telegram.getUpdates
(Telegram.GetUpdatesRequest offset Nothing Nothing Nothing))
`catchError` (pure . Left)
nextUpdateId <- case res of
Left servantErr -> do
liftIO (print servantErr)
pure lastUpdateId
Right result -> do
let updates = Telegram.responseResult result
updateIds = map Telegram.updateUpdateId updates
maxUpdateId = maximum (Nothing : map Just updateIds)
mapM_ handleUpdate updates
pure maxUpdateId
liftIO $ threadDelay 1000000
go nextUpdateId