module Web.Bot.Platform.Telegram (Telegram) where
import Crypto.Hash (hash, Digest, Keccak_256)
import qualified Web.Telegram.API.Bot as API
import Control.Monad.IO.Class (liftIO)
import Data.Text.Encoding (encodeUtf8)
import Control.Exception (throwIO)
import qualified Data.Text as T
import Data.Monoid ((<>))
import Data.Text (Text)
import Web.Bot.Platform
import Web.Bot.Message
import Web.Bot.User
import Web.Bot.Log
data Telegram
instance Platform Telegram where
trySelf = _trySelf
sendMessage = _sendMessage
messageHandler = _messageHandler
platformName = const "Telegram Bot API 2.0"
_trySelf :: APIToken a => Bot a ()
_trySelf = do
token <- apiToken
manager <- getManager
self <- liftIO (API.getMe (API.Token token) manager)
name <- fmap platformName returnPlatform
$logInfoS "Telegram" ("Platform: " <> name)
case self of
Left e -> do $logErrorS "Telegram" ("Init failure: " <> T.pack (show e))
liftIO (throwIO e)
Right (API.Response u) ->
$logInfoS "Telegram" ("Init success, bot name: " <> API.user_first_name u)
where returnPlatform :: Bot a a
returnPlatform = return undefined
pullTimeout :: Num a => a
pullTimeout = 10
_messageHandler :: APIToken a
=> (User -> Message -> Bot a b)
-> Bot a c
_messageHandler handler = go 0
where updates o t = API.getUpdates t (Just o) Nothing . Just
go offset = do
manager <- getManager
token <- apiToken
upd <- liftIO (updates offset (API.Token token) pullTimeout manager)
case API.result <$> upd of
Left e -> do $logDebugS "Telegram"
("Pull updates failure: " <> T.pack (show e))
go offset
Right [] -> go offset
Right xs -> do
mapM_ (withUpdate handler) xs
go (maximum (API.update_id <$> xs) + 1)
sha3 :: Text -> Text
sha3 x = T.pack (show digest)
where digest :: Digest Keccak_256
digest = hash (encodeUtf8 x)
withUpdate :: APIToken a
=> (User -> Message -> Bot a b)
-> API.Update
-> Bot a ()
withUpdate f update = case go of
Just (user, msg) -> f user msg >> return ()
Nothing -> return ()
where
go = (,) <$> mkUser <*> mkMessage
formatUserName u = API.user_first_name u <>
case API.user_last_name u of
Just last_name -> " " <> last_name
Nothing -> ""
formatUserHash u = sha3 ("telegram-" <> T.pack (show $ API.user_id u))
mkUser = User <$> (fmap (API.chat_id . API.chat) $ API.message update)
<*> (fmap formatUserName (API.message update >>= API.from))
<*> (fmap formatUserHash (API.message update >>= API.from))
mkMessage = MsgText <$> (API.message update >>= API.text)
_sendMessage :: (ToMessage msg, APIToken a) => User -> msg -> Bot a ()
_sendMessage user msg = do
manager <- getManager
token <- apiToken
res <- liftIO (send (API.Token token) manager $ toMessage msg)
case res of
Right _ -> return ()
Left e -> do $logErrorS "Telegram" ("Failure send to " <> userName user
<> " with " <> T.pack (show e))
_sendMessage user msg
where cid = T.pack $ show $ userChat user
send tok mgr MsgTyping =
let r = API.sendChatActionRequest cid API.Typing
in API.sendChatAction tok r mgr >>= return . fmap (const ())
send tok mgr (MsgText t) =
let r = (API.sendMessageRequest cid t)
{ API.message_reply_markup = Just API.replyKeyboardHide
, API.message_parse_mode = Just API.Markdown }
in API.sendMessage tok r mgr >>= return . fmap (const ())
send tok mgr (MsgKeyboard txt btnTexts) =
let btns = fmap API.keyboardButton <$> btnTexts
keyboard = API.replyKeyboardMarkup btns
r = (API.sendMessageRequest cid txt)
{ API.message_reply_markup = Just keyboard
, API.message_parse_mode = Just API.Markdown }
in API.sendMessage tok r mgr >>= return . fmap (const ())