{-# 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

-- | A bot application.
data BotApp model action = BotApp
  { forall model action. BotApp model action -> model
botInitialModel :: model
    -- ^ Initial bot state.
  , forall model action.
BotApp model action -> Update -> model -> Maybe action
botAction       :: Telegram.Update -> model -> Maybe action
    -- ^ How to convert incoming 'Telegram.Update's into @action@s.
    -- See "Telegram.Bot.Simple.UpdateParser" for some helpers.
  , forall model action.
BotApp model action -> action -> model -> Eff action model
botHandler      :: action -> model -> Eff action model
    -- ^ How to handle @action@s.
  , forall model action. BotApp model action -> [BotJob model action]
botJobs         :: [BotJob model action]
    -- ^ Background bot jobs.
  }

-- | A background bot job.
data BotJob model action = BotJob
  { forall model action. BotJob model action -> Text
botJobSchedule :: Text
    -- ^ Cron schedule for the job.
  , forall model action.
BotJob model action -> model -> Eff action model
botJobTask     :: model -> Eff action model
    -- ^ Job function.
  }

-- | An environment actual bot runs in.
data BotEnv model action = BotEnv
  { forall model action. BotEnv model action -> TVar model
botModelVar     :: TVar model
    -- ^ A transactional variable with bot's current state.
  , forall model action.
BotEnv model action -> TQueue (Maybe Update, action)
botActionsQueue :: TQueue (Maybe Telegram.Update, action)
    -- ^ A queue of @action@s to process (with associated 'Telegram.Update's).
  , forall model action. BotEnv model action -> ClientEnv
botClientEnv    :: ClientEnv
    -- ^ HTTP client environment (where and how exactly to make requests to Telegram Bot API).
    -- This includes 'Telegram.Token'.
  , forall model action. BotEnv model action -> User
botUser         :: Telegram.User
    -- ^ Information about the bot in the form of '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
.. }

-- | Run bot job task once.
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 ()

-- | Schedule a cron-like bot job.
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

-- | Schedule all bot jobs.
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

-- | Construct a default @'BotEnv' model action@ for a bot.
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)

-- | Issue a new action for the bot to process.
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 ()

-- | Process one action.
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

-- | A job to wait for the next action and process it.
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

-- | Process incoming actions indefinitely.
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)

-- | Start 'Telegram.Update' polling for a bot.
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)

-- | Start 'Telegram.Update' polling with a given update handler.
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