Add bot jobs support

package.yaml

@@ -24,6 +24,7 @@ dependencies:
 - aeson
 - aeson-pretty
 - bytestring
+- cron
 - hashable
 - http-api-data
 - http-client

src/Telegram/Bot/Simple/BotApp.hs

@@ -1,16 +1,20 @@
+{-# LANGUAGE DeriveFunctor       #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Telegram.Bot.Simple.BotApp where
 
-import           Control.Concurrent          (forkIO, threadDelay)
+import           Control.Concurrent          (ThreadId, forkIO, threadDelay)
 import           Control.Concurrent.STM
 import           Control.Monad               (void)
 import           Control.Monad.Except        (catchError)
 import           Control.Monad.Trans         (liftIO)
 import           Control.Monad.Trans.Control (liftBaseDiscard)
+import           Data.Bifunctor              (first)
 import           Data.String                 (fromString)
+import           Data.Text                   (Text)
 import           Servant.Client              (ClientEnv, ClientM, ServantError,
                                               runClientM)
+import qualified System.Cron                 as Cron
 import           System.Environment          (getEnv)
 
 import qualified Telegram.Bot.API            as Telegram
@@ -24,13 +28,39 @@ data BotApp model action = BotApp
   }
 
 data BotJob model action = BotJob
-  { botJobSchedule :: Int
-  , botJobTask     :: model -> ClientM model
+  { botJobSchedule :: Text                       -- ^ Cron schedule for the job.
+  , botJobTask     :: model -> Eff action model  -- ^ Job function.
   }
 
+instance Functor (BotJob model) where
+  fmap f BotJob{..} = BotJob{ botJobTask = first f . botJobTask, .. }
+
+runJobTask :: TVar model -> ClientEnv -> (model -> Eff action model) -> IO ()
+runJobTask modelVar env task = do
+  actions <- liftIO $ atomically $ do
+    model <- readTVar modelVar
+    case runEff (task model) of
+      (newModel, actions) -> do
+        writeTVar modelVar newModel
+        return actions
+  res <- flip runClientM env $
+    mapM_ (runBotM Nothing) actions -- TODO: handle issued actions
+  case res of
+    Left err     -> print err
+    Right result -> return ()
+
+scheduleBotJob :: TVar model -> ClientEnv -> BotJob model action -> IO [ThreadId]
+scheduleBotJob modelVar env BotJob{..} = Cron.execSchedule $ do
+  Cron.addJob (runJobTask modelVar env botJobTask) botJobSchedule
+
+scheduleBotJobs :: TVar model -> ClientEnv -> [BotJob model action] -> IO [ThreadId]
+scheduleBotJobs modelVar env jobs = concat
+  <$> traverse (scheduleBotJob modelVar env) jobs
+
 startBotAsync :: BotApp model action -> ClientEnv -> IO (action -> IO ())
 startBotAsync bot env = do
   modelVar <- newTVarIO (botInitialModel bot)
+  jobThreadIds <- scheduleBotJobs modelVar env (botJobs bot)
   fork_ $ startBotPolling bot modelVar
   return undefined
   where
@@ -42,6 +72,7 @@ startBotAsync_ bot env = void (startBotAsync bot env)
 startBot :: BotApp model action -> ClientEnv -> IO (Either ServantError ())
 startBot bot env = do
   modelVar <- newTVarIO (botInitialModel bot)
+  jobThreadIds <- scheduleBotJobs modelVar env (botJobs bot)
   runClientM (startBotPolling bot modelVar) env
 
 startBot_ :: BotApp model action -> ClientEnv -> IO ()

src/Telegram/Bot/Simple/Conversation.hs

@@ -15,7 +15,7 @@ conversationBot
   :: (Eq conversation, Hashable conversation)
   => (Update -> Maybe conversation)
   -> BotApp model action
-  -> BotApp (HashMap conversation model) (conversation, action)
+  -> BotApp (HashMap (Maybe conversation) model) (Maybe conversation, action)
 conversationBot toConversation BotApp{..} = BotApp
   { botInitialModel = conversationInitialModel
   , botAction       = conversationAction
@@ -27,8 +27,8 @@ conversationBot toConversation BotApp{..} = BotApp
 
     conversationAction update conversations = do
       conversation <- toConversation update
-      let model = fromMaybe botInitialModel (HashMap.lookup conversation conversations)
-      (conversation,) <$> botAction update model
+      let model = fromMaybe botInitialModel (HashMap.lookup (Just conversation) conversations)
+      (Just conversation,) <$> botAction update model
 
     conversationHandler (conversation, action) conversations =
       bimap (conversation,) (\m -> HashMap.insert conversation m conversations) $
@@ -40,6 +40,6 @@ conversationBot toConversation BotApp{..} = BotApp
 
     toConversationJob BotJob{..} = BotJob
       { botJobSchedule = botJobSchedule
-      , botJobTask = traverse botJobTask
+      , botJobTask = first (Nothing,) <$> traverse botJobTask
       }
 

src/Telegram/Bot/Simple/Reply.hs

@@ -45,16 +45,19 @@ replyMessageToSendMessageRequest someChatId ReplyMessage{..} = SendMessageReques
   , sendMessageReplyMarkup = replyMessageReplyMarkup
   }
 
+-- | Reply in a chat with a given 'SomeChatId'.
+replyTo :: SomeChatId -> ReplyMessage -> BotM ()
+replyTo someChatId rmsg = do
+  let msg = replyMessageToSendMessageRequest someChatId rmsg
+  void $ liftClientM $ sendMessage msg
+
 -- | Reply in the current chat (if possible).
 reply :: ReplyMessage -> BotM ()
 reply rmsg = do
   mchatId <- currentChatId
   case mchatId of
-    Just chatId -> do
-      let msg = replyMessageToSendMessageRequest (SomeChatId chatId) rmsg
-      void $ liftClientM $ sendMessage msg
-    Nothing -> do
-      liftIO $ putStrLn "No chat to reply to"
+    Just chatId -> replyTo (SomeChatId chatId) rmsg
+    Nothing     -> liftIO $ putStrLn "No chat to reply to"
 
 -- | Reply with a text.
 replyText :: Text -> BotM ()

telegram-bot-simple.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 4f2c1b80f5351f2590eeea8c2dc55bf2cc16442fd9da17e54e1467081d5bdcc5
+-- hash: b421e66b7872c5848ac588e02214821a7795e703e12e6939017579d9ebed711d
 
 name:           telegram-bot-simple
 version:        0.1.0
@@ -57,6 +57,7 @@ library
     , aeson-pretty
     , base
     , bytestring
+    , cron
     , hashable
     , http-api-data
     , http-client
@@ -86,6 +87,7 @@ executable example-echo-bot
     , aeson-pretty
     , base
     , bytestring
+    , cron
     , hashable
     , http-api-data
     , http-client
@@ -116,6 +118,7 @@ executable example-todo-bot
     , aeson-pretty
     , base
     , bytestring
+    , cron
     , hashable
     , http-api-data
     , http-client