module Web.Telegram.Bot.Internal (runBot, storyBot, sendMessageBot, forkBot) where
import Control.Concurrent (forkIO, forkFinally, killThread, ThreadId)
import Control.Monad.Trans.Reader (runReaderT, ask)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Client (newManager, Manager)
import Control.Exception (throwIO)
import Data.IntMap.Strict as I
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Monad (forever)
import Web.Telegram.Bot.Story
import Web.Telegram.Bot.Types
import Data.Text (Text, pack)
import Data.Map.Strict as M
import Web.Telegram.API.Bot
import Pipes
trySelf :: Token -> Manager -> IO ()
trySelf tok mgr = do
me <- getMe tok mgr
case me of
Left e -> throwIO e
Right (Response u) ->
putStrLn $ "Hello! I'm " ++ show (user_first_name u)
updateLoop :: BotConfig a
=> (Update -> Bot a ())
-> Bot a ()
updateLoop handler = go 0
where updates o t = getUpdates t (Just o) Nothing . Just
go offset = do
(manager, config) <- ask
upd <- liftIO $
updates offset (authToken config) (pollTimeout config) manager
case result <$> upd of
Left e -> liftIO (throwIO e)
Right [] -> go offset
Right xs -> do
mapM_ handler xs
go (maximum (update_id <$> xs) + 1)
fromChan :: MonadIO m => Chan a -> Producer a m ()
fromChan c = forever $ liftIO (readChan c) >>= yield
toSender :: MonadIO m => (BotMessage -> m ()) -> Consumer BotMessage m ()
toSender sender = forever $ await >>= lift . sender
storyHandler :: BotConfig a
=> MVar (IntMap (Chan Message, ThreadId))
-> Map Text (Story a)
-> BotMessage
-> Update
-> Bot a ()
storyHandler chats stories help = go
where go (Update{message =
Just msg@(Message {from = Just user})}) = do
let cid = chat_id (chat msg)
newStory item = modifyMVar_ chats (return . I.insert cid item)
deleteStory = modifyMVar_ chats (return . I.delete cid)
chatMap <- liftIO (readMVar chats)
case I.lookup cid chatMap of
Just (chan, tid) -> do
case text msg of
Just "/cancel" -> do
liftIO (killThread tid)
sendMessageBot (chat msg) help
_ -> liftIO (writeChan chan msg)
Nothing ->
case text msg >>= flip M.lookup stories of
Nothing -> sendMessageBot (chat msg) help
Just story -> do
chan <- liftIO newChan
let pipeline = fromChan chan
>-> (story (user, chat msg) >>= yield)
>-> toSender (sendMessageBot (chat msg))
(manager, config) <- ask
let runStory = runReaderT (runEffect pipeline)
(manager, config)
tid <- liftIO $ forkFinally runStory
(const deleteStory)
liftIO (newStory (chan, tid))
go _ = return ()
sendMessageBot :: BotConfig a => Chat -> BotMessage -> Bot a ()
sendMessageBot c msg = do
(manager, config) <- ask
liftIO $ send (textChatId c) (authToken config) manager msg
where textChatId = pack . show . chat_id
send cid tok mgr BotTyping =
let r = sendChatActionRequest cid Typing
in sendChatAction tok r mgr >> return ()
send cid tok mgr (BotText t) =
let r = (sendMessageRequest cid t)
{ message_reply_markup = Just replyKeyboardHide
, message_parse_mode = Just Markdown }
in sendMessage tok r mgr >> return ()
send cid tok mgr (BotKeyboard txt btnTexts) =
let btns = fmap keyboardButton <$> btnTexts
keyboard = replyKeyboardMarkup btns
r = (sendMessageRequest cid txt)
{ message_reply_markup = Just keyboard
, message_parse_mode = Just Markdown }
in sendMessage tok r mgr >> return ()
storyBot :: (BotConfig a, ToBotMessage help) => help -> Map Text (Story a) -> Bot a ()
storyBot help stories = do
chats <- liftIO (newMVar I.empty)
updateLoop (storyHandler chats stories $ toMessage help)
runBot :: BotConfig a => a -> Bot a b -> IO b
runBot config bot = do
manager <- newManager tlsManagerSettings
trySelf (authToken config) manager
runReaderT bot (manager, config)
forkBot :: BotConfig a => Bot a () -> Bot a ThreadId
forkBot bot = ask >>= liftIO . forkIO . runReaderT bot