{-# 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
{ forall model action. BotApp model action -> model
botInitialModel :: model
, forall model action.
BotApp model action -> Update -> model -> Maybe action
botAction :: Telegram.Update -> model -> Maybe action
, forall model action.
BotApp model action -> action -> model -> Eff action model
botHandler :: action -> model -> Eff action model
, forall model action. BotApp model action -> [BotJob model action]
botJobs :: [BotJob model action]
}
data BotJob model action = BotJob
{ forall model action. BotJob model action -> Text
botJobSchedule :: Text
, forall model action.
BotJob model action -> model -> Eff action model
botJobTask :: model -> Eff action model
}
data BotEnv model action = BotEnv
{ forall model action. BotEnv model action -> TVar model
botModelVar :: TVar model
, forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botActionsQueue :: TQueue (Maybe Telegram.Update, action)
, forall model action. BotEnv model action -> ClientEnv
botClientEnv :: ClientEnv
, forall model action. BotEnv model action -> User
botUser :: Telegram.User
}
instance Functor (BotJob model) where
fmap :: forall a b. (a -> b) -> BotJob model a -> BotJob model b
fmap a -> b
f BotJob{Text
model -> Eff a model
botJobTask :: model -> Eff a model
botJobSchedule :: Text
botJobTask :: forall model action.
BotJob model action -> model -> Eff action model
botJobSchedule :: forall model action. BotJob model action -> Text
..} = BotJob{ botJobTask :: model -> Eff b model
botJobTask = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. model -> Eff a model
botJobTask, Text
botJobSchedule :: Text
botJobSchedule :: Text
.. }
runJobTask :: BotEnv model action -> (model -> Eff action model) -> IO ()
runJobTask :: forall model action.
BotEnv model action -> (model -> Eff action model) -> IO ()
runJobTask botEnv :: BotEnv model action
botEnv@BotEnv{TVar model
TQueue (Maybe Update, action)
User
ClientEnv
botUser :: User
botClientEnv :: ClientEnv
botActionsQueue :: TQueue (Maybe Update, action)
botModelVar :: TVar model
botUser :: forall model action. BotEnv model action -> User
botClientEnv :: forall model action. BotEnv model action -> ClientEnv
botActionsQueue :: forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botModelVar :: forall model action. BotEnv model action -> TVar model
..} model -> Eff action model
task = do
[BotM (Maybe action)]
effects <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
model
model <- forall a. TVar a -> STM a
readTVar TVar model
botModelVar
case forall action model.
Eff action model -> (model, [BotM (Maybe action)])
runEff (model -> Eff action model
task model
model) of
(model
newModel, [BotM (Maybe action)]
effects) -> do
forall a. TVar a -> a -> STM ()
writeTVar TVar model
botModelVar model
newModel
forall (m :: * -> *) a. Monad m => a -> m a
return [BotM (Maybe action)]
effects
Either ClientError ()
res <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientEnv
botClientEnv forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall model action.
BotEnv model action -> Maybe Update -> Maybe action -> IO ()
issueAction BotEnv model action
botEnv forall a. Maybe a
Nothing) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. BotContext -> BotM a -> ClientM a
runBotM (User -> Maybe Update -> BotContext
BotContext User
botUser forall a. Maybe a
Nothing)) [BotM (Maybe action)]
effects
case Either ClientError ()
res of
Left ClientError
err -> forall a. Show a => a -> IO ()
print ClientError
err
Right ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
scheduleBotJob :: BotEnv model action -> BotJob model action -> IO [ThreadId]
scheduleBotJob :: forall model action.
BotEnv model action -> BotJob model action -> IO [ThreadId]
scheduleBotJob BotEnv model action
botEnv BotJob{Text
model -> Eff action model
botJobTask :: model -> Eff action model
botJobSchedule :: Text
botJobTask :: forall model action.
BotJob model action -> model -> Eff action model
botJobSchedule :: forall model action. BotJob model action -> Text
..} = Schedule () -> IO [ThreadId]
Cron.execSchedule forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). MonadSchedule m => IO () -> Text -> m ()
Cron.addJob (forall model action.
BotEnv model action -> (model -> Eff action model) -> IO ()
runJobTask BotEnv model action
botEnv model -> Eff action model
botJobTask) Text
botJobSchedule
scheduleBotJobs :: BotEnv model action -> [BotJob model action] -> IO [ThreadId]
scheduleBotJobs :: forall model action.
BotEnv model action -> [BotJob model action] -> IO [ThreadId]
scheduleBotJobs BotEnv model action
botEnv [BotJob model action]
jobs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall model action.
BotEnv model action -> BotJob model action -> IO [ThreadId]
scheduleBotJob BotEnv model action
botEnv) [BotJob model action]
jobs
defaultBotEnv :: BotApp model action -> ClientEnv -> IO (BotEnv model action)
defaultBotEnv :: forall model action.
BotApp model action -> ClientEnv -> IO (BotEnv model action)
defaultBotEnv BotApp{model
[BotJob model action]
action -> model -> Eff action model
Update -> model -> Maybe action
botJobs :: [BotJob model action]
botHandler :: action -> model -> Eff action model
botAction :: Update -> model -> Maybe action
botInitialModel :: model
botJobs :: forall model action. BotApp model action -> [BotJob model action]
botHandler :: forall model action.
BotApp model action -> action -> model -> Eff action model
botAction :: forall model action.
BotApp model action -> Update -> model -> Maybe action
botInitialModel :: forall model action. BotApp model action -> model
..} ClientEnv
env = forall model action.
TVar model
-> TQueue (Maybe Update, action)
-> ClientEnv
-> User
-> BotEnv model action
BotEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO (TVar a)
newTVarIO model
botInitialModel
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (TQueue a)
newTQueueIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientEnv
env
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall a. Response a -> a
Telegram.responseResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM (Response User)
Telegram.getMe ClientEnv
env)
issueAction :: BotEnv model action -> Maybe Telegram.Update -> Maybe action -> IO ()
issueAction :: forall model action.
BotEnv model action -> Maybe Update -> Maybe action -> IO ()
issueAction BotEnv{TVar model
TQueue (Maybe Update, action)
User
ClientEnv
botUser :: User
botClientEnv :: ClientEnv
botActionsQueue :: TQueue (Maybe Update, action)
botModelVar :: TVar model
botUser :: forall model action. BotEnv model action -> User
botClientEnv :: forall model action. BotEnv model action -> ClientEnv
botActionsQueue :: forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botModelVar :: forall model action. BotEnv model action -> TVar model
..} Maybe Update
update (Just action
action) = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Update, action)
botActionsQueue (Maybe Update
update, action
action)
issueAction BotEnv model action
_ Maybe Update
_ Maybe action
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
processAction
:: BotApp model action
-> BotEnv model action
-> Maybe Telegram.Update
-> action
-> ClientM ()
processAction :: forall model action.
BotApp model action
-> BotEnv model action -> Maybe Update -> action -> ClientM ()
processAction BotApp{model
[BotJob model action]
action -> model -> Eff action model
Update -> model -> Maybe action
botJobs :: [BotJob model action]
botHandler :: action -> model -> Eff action model
botAction :: Update -> model -> Maybe action
botInitialModel :: model
botJobs :: forall model action. BotApp model action -> [BotJob model action]
botHandler :: forall model action.
BotApp model action -> action -> model -> Eff action model
botAction :: forall model action.
BotApp model action -> Update -> model -> Maybe action
botInitialModel :: forall model action. BotApp model action -> model
..} botEnv :: BotEnv model action
botEnv@BotEnv{TVar model
TQueue (Maybe Update, action)
User
ClientEnv
botUser :: User
botClientEnv :: ClientEnv
botActionsQueue :: TQueue (Maybe Update, action)
botModelVar :: TVar model
botUser :: forall model action. BotEnv model action -> User
botClientEnv :: forall model action. BotEnv model action -> ClientEnv
botActionsQueue :: forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botModelVar :: forall model action. BotEnv model action -> TVar model
..} Maybe Update
update action
action = do
[BotM (Maybe action)]
effects <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
model
model <- forall a. TVar a -> STM a
readTVar TVar model
botModelVar
case forall action model.
Eff action model -> (model, [BotM (Maybe action)])
runEff (action -> model -> Eff action model
botHandler action
action model
model) of
(model
newModel, [BotM (Maybe action)]
effects) -> do
forall a. TVar a -> a -> STM ()
writeTVar TVar model
botModelVar model
newModel
forall (m :: * -> *) a. Monad m => a -> m a
return [BotM (Maybe action)]
effects
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall model action.
BotEnv model action -> Maybe Update -> Maybe action -> IO ()
issueAction BotEnv model action
botEnv Maybe Update
update) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. BotContext -> BotM a -> ClientM a
runBotM (User -> Maybe Update -> BotContext
BotContext User
botUser Maybe Update
update)) [BotM (Maybe action)]
effects
processActionJob :: BotApp model action -> BotEnv model action -> ClientM ()
processActionJob :: forall model action.
BotApp model action -> BotEnv model action -> ClientM ()
processActionJob BotApp model action
botApp botEnv :: BotEnv model action
botEnv@BotEnv{TVar model
TQueue (Maybe Update, action)
User
ClientEnv
botUser :: User
botClientEnv :: ClientEnv
botActionsQueue :: TQueue (Maybe Update, action)
botModelVar :: TVar model
botUser :: forall model action. BotEnv model action -> User
botClientEnv :: forall model action. BotEnv model action -> ClientEnv
botActionsQueue :: forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botModelVar :: forall model action. BotEnv model action -> TVar model
..} = do
(Maybe Update
update, action
action) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TQueue a -> STM a
readTQueue TQueue (Maybe Update, action)
botActionsQueue
forall model action.
BotApp model action
-> BotEnv model action -> Maybe Update -> action -> ClientM ()
processAction BotApp model action
botApp BotEnv model action
botEnv Maybe Update
update action
action
processActionsIndefinitely
:: BotApp model action -> BotEnv model action -> IO ThreadId
processActionsIndefinitely :: forall model action.
BotApp model action -> BotEnv model action -> IO ThreadId
processActionsIndefinitely BotApp model action
botApp BotEnv model action
botEnv = IO () -> IO ThreadId
forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM (forall model action.
BotApp model action -> BotEnv model action -> ClientM ()
processActionJob BotApp model action
botApp BotEnv model action
botEnv) (forall model action. BotEnv model action -> ClientEnv
botClientEnv BotEnv model action
botEnv)
startBotPolling :: BotApp model action -> BotEnv model action -> ClientM ()
startBotPolling :: forall model action.
BotApp model action -> BotEnv model action -> ClientM ()
startBotPolling BotApp{model
[BotJob model action]
action -> model -> Eff action model
Update -> model -> Maybe action
botJobs :: [BotJob model action]
botHandler :: action -> model -> Eff action model
botAction :: Update -> model -> Maybe action
botInitialModel :: model
botJobs :: forall model action. BotApp model action -> [BotJob model action]
botHandler :: forall model action.
BotApp model action -> action -> model -> Eff action model
botAction :: forall model action.
BotApp model action -> Update -> model -> Maybe action
botInitialModel :: forall model action. BotApp model action -> model
..} botEnv :: BotEnv model action
botEnv@BotEnv{TVar model
TQueue (Maybe Update, action)
User
ClientEnv
botUser :: User
botClientEnv :: ClientEnv
botActionsQueue :: TQueue (Maybe Update, action)
botModelVar :: TVar model
botUser :: forall model action. BotEnv model action -> User
botClientEnv :: forall model action. BotEnv model action -> ClientEnv
botActionsQueue :: forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botModelVar :: forall model action. BotEnv model action -> TVar model
..} = forall a. (Update -> ClientM a) -> ClientM a
startPolling forall {m :: * -> *}. MonadIO m => Update -> m ()
handleUpdate
where
handleUpdate :: Update -> m ()
handleUpdate Update
update = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
Maybe action
maction <- Update -> model -> Maybe action
botAction Update
update forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar model
botModelVar
case Maybe action
maction of
Maybe action
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just action
action -> forall model action.
BotEnv model action -> Maybe Update -> Maybe action -> IO ()
issueAction BotEnv model action
botEnv (forall a. a -> Maybe a
Just Update
update) (forall a. a -> Maybe a
Just action
action)
startPolling :: (Telegram.Update -> ClientM a) -> ClientM a
startPolling :: forall a. (Update -> ClientM a) -> ClientM a
startPolling Update -> ClientM a
handleUpdate = forall {b}. Maybe UpdateId -> ClientM b
go forall a. Maybe a
Nothing
where
go :: Maybe UpdateId -> ClientM b
go Maybe UpdateId
lastUpdateId = do
let inc :: UpdateId -> UpdateId
inc (Telegram.UpdateId Int
n) = Int -> UpdateId
Telegram.UpdateId (Int
n forall a. Num a => a -> a -> a
+ Int
1)
offset :: Maybe UpdateId
offset = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UpdateId -> UpdateId
inc Maybe UpdateId
lastUpdateId
Either ClientError (Response [Update])
res <-
(forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetUpdatesRequest -> ClientM (Response [Update])
Telegram.getUpdates
(Maybe UpdateId
-> Maybe Int
-> Maybe Seconds
-> Maybe [UpdateType]
-> GetUpdatesRequest
Telegram.GetUpdatesRequest Maybe UpdateId
offset forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing))
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
Maybe UpdateId
nextUpdateId <- case Either ClientError (Response [Update])
res of
Left ClientError
servantErr -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. Show a => a -> IO ()
print ClientError
servantErr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UpdateId
lastUpdateId
Right Response [Update]
result -> do
let updates :: [Update]
updates = forall a. Response a -> a
Telegram.responseResult Response [Update]
result
updateIds :: [UpdateId]
updateIds = forall a b. (a -> b) -> [a] -> [b]
map Update -> UpdateId
Telegram.updateUpdateId [Update]
updates
maxUpdateId :: Maybe UpdateId
maxUpdateId = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [UpdateId]
updateIds)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Update -> ClientM a
handleUpdate [Update]
updates
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe UpdateId
maxUpdateId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
Maybe UpdateId -> ClientM b
go Maybe UpdateId
nextUpdateId