telegram-bot-simple 0.11.1 → 0.12
raw patch · 8 files changed
+236/−89 lines, 8 files
Files
- CHANGELOG.md +14/−0
- README.md +1/−0
- examples/EchoBot.hs +7/−2
- examples/EchoBotWebhook.hs +7/−2
- examples/GameBot.hs +200/−82
- src/Telegram/Bot/Simple/RunTG.hs +5/−2
- src/Telegram/Bot/Simple/UpdateParser.hs +1/−0
- telegram-bot-simple.cabal +1/−1
CHANGELOG.md view
@@ -1,3 +1,17 @@+0.12 -- 2023-04-29+---++- Add support for testing WebApps (see [#148](https://github.com/fizruk/telegram-bot-simple/pull/148));+- Add nix flake (see [#149](https://github.com/fizruk/telegram-bot-simple/pull/149));+- Improve documentation for `callbackQueryDataRead` (see [#153](https://github.com/fizruk/telegram-bot-simple/pull/153));+- Support `telegram-bot-api == 0.7` (breaking changes included).++- **Migration guide**:++ 1. Provide `InlineQueryResultGeneric` (see `defInlineQueryResultGeneric`).+ 2. Provide `InlineQueryResultGenericThumbnail` (see `defInlineQueryResultGenericThumbnail`).+ 3. Specify your own `InlineQueryResult` (see helpers for each data constructor).+ 0.11.1 ---
README.md view
@@ -29,5 +29,6 @@ | ------------- | ------------- | | 0.10 | 6.5 | | 0.11.1 | 6.5.1 |+| 0.12 | 6.7 | _Nick_
examples/EchoBot.hs view
@@ -44,8 +44,13 @@ handleAction :: Action -> Model -> Eff Action Model handleAction action model = case action of InlineEcho queryId msg -> model <# do- let result = InlineQueryResult InlineQueryResultArticle (InlineQueryResultId msg) (Just msg) (Just (defaultInputTextMessageContent msg)) Nothing- answerInlineQueryRequest = defAnswerInlineQuery queryId [result]+ let result = (defInlineQueryResultGeneric (InlineQueryResultId msg))+ { inlineQueryResultTitle = Just msg+ , inlineQueryResultInputMessageContent = Just (defaultInputTextMessageContent msg)+ }+ thumbnail = defInlineQueryResultGenericThumbnail result+ article = defInlineQueryResultArticle thumbnail+ answerInlineQueryRequest = defAnswerInlineQuery queryId [article] _ <- runTG answerInlineQueryRequest return () StickerEcho file chat -> model <# do
examples/EchoBotWebhook.hs view
@@ -52,8 +52,13 @@ handleAction :: Action -> Model -> Eff Action Model handleAction action model = case action of InlineEcho queryId msg -> model <# do- let result = InlineQueryResult InlineQueryResultArticle (InlineQueryResultId msg) (Just msg) (Just (defaultInputTextMessageContent msg)) Nothing- answerInlineQueryRequest = defAnswerInlineQuery queryId [result]+ let result = (defInlineQueryResultGeneric (InlineQueryResultId msg))+ { inlineQueryResultTitle = Just msg+ , inlineQueryResultInputMessageContent = Just (defaultInputTextMessageContent msg)+ }+ thumbnail = defInlineQueryResultGenericThumbnail result+ article = defInlineQueryResultArticle thumbnail+ answerInlineQueryRequest = defAnswerInlineQuery queryId [article] _ <- runTG answerInlineQueryRequest return () StickerEcho file chat -> model <# do
examples/GameBot.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE RecordWildCards #-} module Main where +import Control.Concurrent (threadDelay) import Control.Concurrent.STM import Control.Monad (void, forM_) import Control.Monad.IO.Class (liftIO)@@ -43,7 +44,6 @@ import qualified Data.Text.IO as Text import qualified Data.UUID as UUID import qualified Options.Applicative as Optparse (command)--- import qualified System.Posix.Signals as Sig import qualified System.Signal as Sig import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A@@ -96,25 +96,26 @@ let shouldNotify = Just True targetChatId = SomeChatId (ChatId (fromIntegral supportChatId)) fwdMsgRequest = ForwardMessageRequest targetChatId Nothing sourceChatId shouldNotify Nothing msgId- _ <- runTG fwdMsgRequest+ waitAndRetry fwdMsgRequest return () AInlineGame queryId msg -> model <# do- let inlineQueryResult =- InlineQueryResult- InlineQueryResultGame- (InlineQueryResultId msg)- (Just msg)- (Just gameMsg)- Nothing+ let genericResult = (defInlineQueryResultGeneric (InlineQueryResultId msg))+ { inlineQueryResultTitle = Just msg+ , inlineQueryResultInputMessageContent = Just gameMsg+ } gameMsg = (defaultInputTextMessageContent gameMessageText) { inputMessageContentParseMode = Just "HTML" }+ inlineQueryResult = InlineQueryResultGame+ { inlineQueryResultGameGeneric = genericResult+ , inlineQueryResultGameGameShortName = gameName+ } answerInlineQueryRequest = defAnswerInlineQuery queryId [inlineQueryResult] _ <- runTG answerInlineQueryRequest return ()- AGame targetChatId msg -> model <# do+ AGame targetChatId _msg -> model <# do let sendGameRequest = defSendGame (coerce targetChatId) gameId- _ <- runTG sendGameRequest+ waitAndRetry sendGameRequest return () ACallback callback -> model <# do let queryId = coerce (callbackQueryId callback)@@ -123,13 +124,26 @@ { answerCallbackQueryText = queryData , answerCallbackQueryUrl = Just gameUrl }- _ <- runTG answerCallbackQueryRequest+ waitAndRetry answerCallbackQueryRequest return () where gameMessageText = "<a href=\"" <> gameUrl <> "\">" <> gameName <> "</a>"+ data Command = CmdBot | CmdServer +waitAndRetry :: RunTG a (Response b) => a -> BotM ()+waitAndRetry request = do+ result <- runTG request+ if responseOk result+ then pure ()+ else case responseParameters result >>= responseParametersRetryAfter of+ Nothing -> pure ()+ Just sec -> do+ liftIO . threadDelay $ coerce sec * 1000000+ _ <- runTG request+ return ()+ -- * Main main :: IO ()@@ -185,6 +199,14 @@ port = fromIntegral (serverPort serverSettings) runSettings warpSettings (serverApp env) +data PictureSettings = PictureSettings+ { theGood :: Text+ , theBad :: Text+ , theUgly :: Text+ , goodScore :: Double+ , badScore :: Double+ } deriving (Generic, FromDhall)+ data ServerSettings = ServerSettings { serverPort :: Natural , serverUrlPrefix :: Text@@ -194,6 +216,10 @@ , analyticsPath :: Text , pageStyle :: Text , quizDescription :: Text+ , quizFooterBegin :: Text+ , quizFooterCode :: Text+ , quizFooterEnd :: Text+ , quizPicture :: Maybe PictureSettings } deriving (Generic, FromDhall) serverSettingsPath :: Text@@ -429,11 +455,13 @@ -- *** Handlers withUser- :: Maybe Text+ :: ServerSettings+ -> Maybe Text -> (GameUserId -> Handler (WithCookie Html)) -> Handler (WithCookie Html)-withUser Nothing _action = redirectToRoot-withUser (Just cookie) action = maybe redirectToRoot action (parseUser cookie)+withUser settings Nothing _action = redirectToRoot settings+withUser settings (Just cookie) action+ = maybe (redirectToRoot settings) action (parseUser cookie) startHandler :: Env -> Maybe Text -> Handler (WithCookie Html) startHandler Env{..} mCookie = do@@ -443,7 +471,7 @@ $ renderStartPage settings firstQuestionHandler :: Env -> Maybe Text -> Handler (WithCookie Html)-firstQuestionHandler env mCookie = withUser mCookie (firstQuestionForUser env)+firstQuestionHandler env mCookie = withUser (settings env) mCookie (firstQuestionForUser env) where ServerSettings{..} = settings env limit = fromIntegral questionsPerGame@@ -459,14 +487,14 @@ Just userData -> modifyTVar' userState $! HashMap.insert user userData pure newUserData case mNewUserData of- Nothing -> redirectToRoot+ Nothing -> redirectToRoot settings Just newUserData -> pure $ addHeader @"Set-Cookie" (userToSetCookie user) $ renderQuestionPage settings newUserData nextQuestionHandler :: Env -> Maybe Text -> AnswerInt -> Handler (WithCookie Html) nextQuestionHandler env mCookie (AnswerInt answer)- = withUser mCookie (nextQuestionForUser env answer)+ = withUser (settings env) mCookie (nextQuestionForUser env answer) where nextQuestionForUser Env{..} numAnswer user = do newGameState <- liftIO $ atomically $ do@@ -482,7 +510,7 @@ writeTVar userState $! HashMap.insert user newUserData oldUserState pure newUserState case newGameState of- GameNotFound -> redirectToStart user+ GameNotFound -> redirectToStart settings user GameOver oldUserData -> pure $ addHeader @"Set-Cookie" (userToSetCookie user) $ renderUserScore settings oldUserData@@ -492,13 +520,15 @@ -- *** Redirects -redirectToRoot :: Handler (WithCookie Html)-redirectToRoot = noHeader @"Set-Cookie" <$> throwError (err301WithLoc "/")+redirectToRoot :: ServerSettings -> Handler (WithCookie Html)+redirectToRoot settings+ = noHeader @"Set-Cookie"+ <$> throwError (err301WithLoc $ encodeUtf8 $ makeAbsoluteUrl settings "/") -redirectToStart :: GameUserId -> Handler (WithCookie Html)-redirectToStart user+redirectToStart :: ServerSettings -> GameUserId -> Handler (WithCookie Html)+redirectToStart settings user = addHeader @"Set-Cookie" (userToSetCookie user)- <$> throwError (err301WithLoc "/game")+ <$> throwError (err301WithLoc $ encodeUtf8 $ makeAbsoluteUrl settings "/game/") err301WithLoc :: ByteString -> ServerError err301WithLoc loc = err301 { errHeaders = [(hLocation, loc)] }@@ -512,111 +542,199 @@ makeAbsoluteRootUrl = flip makeAbsoluteUrl "/" makeAbsoluteGameUrl :: ServerSettings -> Text-makeAbsoluteGameUrl = flip makeAbsoluteUrl "/game"+makeAbsoluteGameUrl = flip makeAbsoluteUrl "/game/" withGameTemplate :: ServerSettings -> Html -> Html-withGameTemplate ServerSettings{..} content = toHtml $ H.html $ do+withGameTemplate s@ServerSettings{..} content = toHtml $ H.html $ do H.head $ do H.title $ "Game" H.meta ! A.name "viewport" ! A.content "width=device-width, initial-scale=1"+ H.link+ ! A.href (toValue $ makeAbsoluteUrl s "/fonts/HalvarBreitschriftDEMO-Regular.woff")+ ! A.rel "stylesheet"+ H.link+ ! A.href (toValue $ makeAbsoluteUrl s "/fonts/HalvarBreitschriftDEMO-Bold.woff")+ ! A.rel "stylesheet" H.style $ toMarkup pageStyle H.body $ content -renderText :: Text -> Html-renderText txt =- H.div ! A.class_ "qbox pad" $ do- H.div ! A.class_ "qel" $ do- H.div ! A.class_ "text" $ toMarkup txt+-- **** Home page -renderExplanation :: Bool -> Text -> Html-renderExplanation True txt = renderText txt-renderExplanation False txt =+renderTextLogo1 :: Text -> Html+renderTextLogo1 txt = H.div ! A.class_ "qbox pad" $ do- H.div ! A.class_ "wel" $ do- H.div ! A.class_ "text" $ toMarkup txt+ H.div ! A.class_ "text-logo-line1 position-logo-line1" $ toMarkup txt -renderButton :: Text -> Html-renderButton txt =+renderTextLogo2 :: Text -> Html+renderTextLogo2 txt = H.div ! A.class_ "qbox pad" $ do- H.button ! A.class_ "qel text button" ! A.type_ "submit" ! A.value "submit" $ toMarkup txt+ H.div ! A.class_ "text-logo-line2 position-logo-line2" $ toMarkup txt -renderLink :: ServerSettings -> Text -> Html-renderLink settings txt = do- H.a ! A.href (toValue $ makeAbsoluteGameUrl settings) $ do- H.div ! A.class_ "qbox pad" $ do- H.div ! A.class_ "qel button" $ do- H.div ! A.class_ "text"- $ toMarkup txt+renderDescription :: Text -> Html+renderDescription txt= do+ H.div ! A.class_ "qbox pad" $ do+ H.div ! A.class_ "text-description position-text" $ toMarkup txt -renderAnswer :: Bool -> Int -> Text -> Html-renderAnswer ch num txt =+renderFooterText :: Text -> Html+renderFooterText txt= do H.div ! A.class_ "qbox pad" $ do- H.div ! A.class_ "qel" $ do- H.label ! A.class_ "container" ! A.for (toValue num) $ do- H.input- ! A.id (toValue num)- ! A.type_ "radio"- ! A.name "q"- !? (ch, A.checked "")- ! A.value (toValue num)- H.div ! A.class_ "checkmark" $ ""- H.div ! A.class_ "ctext text typing" $ toMarkup txt+ H.div ! A.class_ "text-footer position-text" $ toMarkup txt -renderProgress :: Text -> Html-renderProgress txt =+renderFooterCode :: Text -> Html+renderFooterCode txt= do H.div ! A.class_ "qbox pad" $ do- H.div $ do- H.div ! A.class_ "text" $ toMarkup txt+ H.div ! A.class_ "text-footer-code position-text" $ toMarkup txt renderStartPage :: ServerSettings -> Html renderStartPage settings = withGameTemplate settings $ do- renderText "Haskell Quiz Game"- renderText (quizDescription settings)+ renderTextLogo1 "Haskell"+ renderTextLogo2 "Quiz Game"+ renderDescription (quizDescription settings) renderLink settings "Play"+ renderFooterText (quizFooterBegin settings)+ renderFooterCode (quizFooterCode settings)+ renderFooterText (quizFooterEnd settings) +-- **** Question page++renderProgress :: Bool -> Int -> Integer -> Html+renderProgress isResult current total =+ H.div ! A.class_ "qbox pad" $ do+ let currentClass = if isResult then "text-current-result" else "text-current-number"+ positionClass = if isResult then "position-progress-result" else "position-progress"+ H.div ! A.class_ positionClass $ do+ H.span ! A.class_ currentClass $ toMarkup (show current)+ H.span ! A.class_ "text-total-number" $ toMarkup $ "/ " <> show total++renderQuestionText :: Bool -> Text -> Html+renderQuestionText forExplanation txt =+ H.div ! A.class_ "qbox pad" $ do+ let positionStyle = if forExplanation then "position-explanation" else "position-question"+ questionStyle = "text-question " <> positionStyle :: Text+ H.div ! A.class_ (toValue questionStyle) $ toMarkup txt++renderAnswer :: Bool -> Int -> Text -> Html+renderAnswer ch num txt =+ H.div ! A.class_ "qbox position-answer" $ do+ H.label ! A.class_ "container" ! A.for (toValue num) $ do+ H.input+ ! A.id (toValue num)+ ! A.type_ "radio"+ ! A.name "q"+ !? (ch, A.checked "")+ ! A.value (toValue num)+ H.div ! A.class_ "checkmark" $ ""+ H.div ! A.class_ "text-answer position-text-answer" $ toMarkup txt+ renderQuestionPage :: ServerSettings -> UserData -> Html renderQuestionPage settings UserData{..} = withGameTemplate settings $ do- let progress = show (length userDataAnswers + 1) <> "/" <> show userDataTotalQuestions case userDataCurrentQuestion of Nothing -> do- renderText "No more questions left."- renderLink settings "Play again"+ renderQuestionText False "No more questions left."+ renderAgainLink settings "Play again" Just QuestionBool{..} -> do- renderText questionBoolText+ renderProgress False (length userDataAnswers + 1) userDataTotalQuestions+ renderQuestionText False questionBoolText H.form ! A.action (toValue $ makeAbsoluteGameUrl settings) ! A.method "post" $ do renderAnswer True 1 "True" renderAnswer False 0 "False"- renderButton "Next question"- renderProgress $ Text.pack progress+ renderButton "Next" Just QuestionChoice{..} -> do- renderText questionChoiceText+ renderProgress False (length userDataAnswers + 1) userDataTotalQuestions+ renderQuestionText False questionChoiceText H.form ! A.action (toValue $ makeAbsoluteGameUrl settings) ! A.method "post" $ do forM_ questionChoiceChoices $ \Choice{..} -> renderAnswer (if choiceNumber == 1 then True else False) (fromIntegral choiceNumber) choiceText- renderButton "Next question"- renderProgress $ Text.pack progress+ renderButton "Next" +-- **** Score page++renderExplanation :: Bool -> Text -> Html+renderExplanation True txt = renderQuestionText True txt+renderExplanation False txt =+ H.div ! A.class_ "qbox pad" $ do+ H.div ! A.class_ "text-wrong-answer position-explanation" $ toMarkup txt++chooseScorePicture :: PictureSettings -> Double -> Text+chooseScorePicture PictureSettings{..} userScore =+ if goodScore < userScore+ then theGood+ else if badScore < userScore+ then theBad+ else theUgly++renderPicture :: ServerSettings -> Int -> Integer -> Html+renderPicture ServerSettings{..} score total = case quizPicture of+ Nothing -> return ()+ Just ps@PictureSettings{..} -> case goodScore < badScore of+ -- invalid settings+ True -> return ()+ False -> do+ let userScore :: Double+ userScore = fromIntegral score / fromIntegral total++ pictureUrl = chooseScorePicture ps userScore+ H.div ! A.class_ "qbox pad" $ do+ H.img ! A.src (toValue pictureUrl) ! A.class_ "score-img"++renderBrightLine, renderDarkLine :: Html+renderBrightLine = H.div ! A.class_ "qbox pad" $ do+ H.hr ! A.class_ "bright-line"+renderDarkLine = H.div ! A.class_ "qbox pad" $ do+ H.hr ! A.class_ "dark-line"+ renderUserScore :: ServerSettings -> UserData -> Html renderUserScore settings UserData{..} = withGameTemplate settings $ do case userDataAnswers of [] -> do- renderText "Sorry. Looks like no answers available at the moment. Try again maybe?"- renderLink settings "Play again"+ renderDescription+ "Sorry. Looks like no answers available at the moment. Try again maybe?"+ renderAgainLink settings "Play again" _ -> do- let total = show userDataTotalQuestions- current = show (length $ filter answerIsRight userDataAnswers)- score = Text.pack (current <> "/" <> total)- H.b $ do- renderText $ "Your score is: " <> score+ let score = length $ filter answerIsRight userDataAnswers+ renderTextLogo1 "Your"+ renderTextLogo2 "Score is"+ renderProgress True score userDataTotalQuestions+ renderPicture settings score userDataTotalQuestions+ renderBrightLine H.div $ do forM_ userDataAnswers $ \Answer{..} -> H.tr $ do- H.div $ renderText (questionText answerQuestion)+ H.div $ renderQuestionText True (questionText answerQuestion) H.div $ if answerIsRight then renderExplanation True "OK" else renderExplanation False $ explainError answerQuestion- renderLink settings "Play again"+ renderDarkLine+ renderAgainLink settings "Play again"++-- **** Helpers++renderButton :: Text -> Html+renderButton txt =+ H.div ! A.class_ "qbox pad" $ do+ H.div ! A.class_ "position-button" $ do+ H.input+ ! A.class_ "qel-button text-button"+ ! A.type_ "submit"+ ! A.value (toValue txt)++renderLink :: ServerSettings -> Text -> Html+renderLink settings txt = do+ H.a ! A.href (toValue $ makeAbsoluteGameUrl settings) $ do+ H.div ! A.class_ "qbox pad" $ do+ H.div ! A.class_ "position-link" $ do+ H.div ! A.class_ "qel-button text-button text-play-button"+ $ toMarkup txt++renderAgainLink :: ServerSettings -> Text -> Html+renderAgainLink settings txt = do+ H.a ! A.href (toValue $ makeAbsoluteGameUrl settings) $ do+ H.div ! A.class_ "qbox pad" $ do+ H.div ! A.class_ "position-link" $ do+ H.div ! A.class_ "qel-button text-button text-again-button"+ $ toMarkup txt+
src/Telegram/Bot/Simple/RunTG.hs view
@@ -76,8 +76,8 @@ runTG = runTG . addStickerToSet -- | Wrapper around 'SetStickerSetThumbRequest' request type for 'setStickerSetThumb' method.-instance RunTG SetStickerSetThumbRequest (Response Bool) where- runTG = runTG . setStickerSetThumb+instance RunTG SetStickerSetThumbnailRequest (Response Bool) where+ runTG = runTG . setStickerSetThumbnail -- | Wrapper around 'EditMessageTextRequest' request type for 'editMessageText' method. instance RunTG EditMessageTextRequest (Response EditMessageResponse) where@@ -190,6 +190,9 @@ -- | Wrapper around 'SetMyCommandsRequest' request type for 'setMyCommands' method. instance RunTG SetMyCommandsRequest (Response Bool) where runTG = runTG . setMyCommands++instance RunTG SetCustomEmojiStickerSetThumbnailRequest (Response Bool) where+ runTG = runTG . setCustomEmojiStickerSetThumbnail -- | Wrapper around 'CopyMessageRequest' request type for 'copyMessage' method. instance RunTG CopyMessageRequest (Response CopyMessageId) where
src/Telegram/Bot/Simple/UpdateParser.hs view
@@ -75,6 +75,7 @@ then pure $ Text.stripStart rest else fail "not that command" +-- | Obtain 'CallbackQuery' @data@ associated with the callback button in an inline keyboard if present in 'Update' message. callbackQueryDataRead :: Read a => UpdateParser a callbackQueryDataRead = mkParser $ \update -> do query <- updateCallbackQuery update
telegram-bot-simple.cabal view
@@ -1,7 +1,7 @@ cabal-version: 1.12 name: telegram-bot-simple-version: 0.11.1+version: 0.12 synopsis: Easy to use library for building Telegram bots. description: Please see the README on Github at <https://github.com/fizruk/telegram-bot-simple#readme> category: Web