diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ +0.6 +--- + +- Fix newlines unexpected removing in `UpdateParser` module (see [#124](https://github.com/fizruk/telegram-bot-simple/pull/124)); +- Add WebHooks support (see [#127](https://github.com/fizruk/telegram-bot-simple/pull/127)); +- Fix `parse_mode` encoding in `sendPhoto`, `sendDocument`, `sendVideo` and `sendAnimation` methods (see [#123](https://github.com/fizruk/telegram-bot-simple/pull/123) and [5ee5289](https://github.com/fizruk/telegram-bot-simple/commit/5ee5289f711381a1f1e0daf540bc6c041e3cb275)); +- Make package complaint with Telegram Bot API 6.2 (breaking changes included) (see [fab1aee](https://github.com/fizruk/telegram-bot-simple/commit/fab1aee308afc59663013a796ebff7a3f99c8201)): + + - Added `createInvoiceLink` method; + - Added `getCustomEmojiStickers` method; + - `User` extended with `is_premium` and `added_to_attachment_menu`; + - `Chat` extended with `has_restricted_voice_and_video_messages`, `join_to_send_messages`, `join_by_request`; + - `MessageEntityType` extended with `custom_emoji`; + `file_size` field for `Animation`, `Audio`, `Document`, `Video`, `VideoNote` `Voice`, `File` changed from `Int` to `Integer`; + - `SticketSet` modified: `contains_masks` is optional now and becoming a subject of further deprecation in a future, `type` added; + - Added `StickerSetType`: could be `regular`, `mask` and `custom_emoji`. + 0.5.2 --- diff --git a/examples/EchoBotWebhook.hs b/examples/EchoBotWebhook.hs new file mode 100644 --- /dev/null +++ b/examples/EchoBotWebhook.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text + +import Telegram.Bot.API +import Telegram.Bot.API.InlineMode.InlineQueryResult +import Telegram.Bot.API.InlineMode.InputMessageContent (defaultInputTextMessageContent) +import Telegram.Bot.API.Webhook +import Telegram.Bot.Simple +import Telegram.Bot.Simple.BotApp (WebhookConfig (WebhookConfig)) +import Telegram.Bot.Simple.UpdateParser (updateMessageSticker, + updateMessageText) + +import Network.Wai.Handler.Warp (Port, + defaultSettings, + setPort) +import Network.Wai.Handler.WarpTLS (OnInsecure (AllowInsecure), + TLSSettings (onInsecure), + tlsSettings) + +type Model = () + +data Action + = InlineEcho InlineQueryId Text + | StickerEcho InputFile ChatId + | Echo Text + +echoBot :: BotApp Model Action +echoBot = BotApp + { botInitialModel = () + , botAction = updateToAction + , botHandler = handleAction + , botJobs = [] + } + +updateToAction :: Update -> Model -> Maybe Action +updateToAction update _ + | isJust $ updateInlineQuery update = do + query <- updateInlineQuery update + let queryId = inlineQueryId query + let msg = inlineQueryQuery query + Just $ InlineEcho queryId msg + | isJust $ updateMessageSticker update = do + fileId <- stickerFileId <$> updateMessageSticker update + chatId <- updateChatId update + pure $ StickerEcho (InputFileId fileId) chatId + | otherwise = case updateMessageText update of + Just text -> Just (Echo text) + Nothing -> Nothing + +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 = AnswerInlineQueryRequest + { answerInlineQueryRequestInlineQueryId = queryId + , answerInlineQueryRequestResults = [result] + , answerInlineQueryCacheTime = Nothing + , answerInlineQueryIsPersonal = Nothing + , answerInlineQueryNextOffset = Nothing + , answerInlineQuerySwitchPmText = Nothing + , answerInlineQuerySwitchPmParameter = Nothing + } + _ <- liftClientM (answerInlineQuery answerInlineQueryRequest) + return () + StickerEcho file chat -> model <# do + _ <- liftClientM + (sendSticker + (SendStickerRequest + (SomeChatId chat) + file + Nothing + Nothing + Nothing + Nothing + Nothing)) + return () + Echo msg -> model <# do + pure msg -- or replyText msg + +run :: Token -> FilePath -> FilePath -> Port -> String -> IO () +run token certPath keyPath port ip = do + env <- defaultTelegramClientEnv token + res <- startBotWebhook bot config env + print res + where + bot = conversationBot updateChatId echoBot + tlsOpts = (tlsSettings certPath keyPath) {onInsecure = AllowInsecure} + warpOpts = setPort port defaultSettings + certFile = Just $ InputFile certPath "application/x-pem-file" + url = "https://" ++ ip ++ ":" ++ show port + config = WebhookConfig + { webhookConfigTlsSettings = tlsOpts, + webhookConfigTlsWarpSettings = warpOpts, + webhookConfigSetWebhookRequest = requestData + } + requestData = + SetWebhookRequest + { setWebhookUrl = url, + setWebhookCertificate = certFile, + setWebhookIpAddress = Nothing, + setWebhookMaxConnections = Nothing, + setWebhookAllowedUpdates = Just ["message"], + setWebhookDropPendingUpdates = Nothing, + setWebhookSecretToken = Nothing + } + +main :: IO () +main = do + putStrLn "Please, enter Telegram bot's API token:" + token <- Token . Text.pack <$> getLine + putStrLn "Please, enter a path to certificate:" + cert <- getLine + putStrLn "Please, enter a path to key:" + key <- getLine + putStrLn "Please, enter port(80, 88, 443, 8443):" + port <- read <$> getLine + putStrLn "Please, enter ip:" + ip <- getLine + run token cert key port ip diff --git a/src/Telegram/Bot/API/Methods.hs b/src/Telegram/Bot/API/Methods.hs --- a/src/Telegram/Bot/API/Methods.hs +++ b/src/Telegram/Bot/API/Methods.hs @@ -287,7 +287,7 @@ ] <> ( (maybe id (\_ -> ((Input "thumb" "attach://thumb"):)) sendPhotoThumb) $ (maybe id (\t -> ((Input "caption" t):)) sendPhotoCaption) - $ (maybe id (\t -> ((Input "parse_mode" (TL.toStrict $ encodeToLazyText t)):)) sendPhotoParseMode) + $ (maybe id (\t -> ((Input "parse_mode" (TL.toStrict . TL.replace "\"" "" $ encodeToLazyText t)):)) sendPhotoParseMode) $ (maybe id (\t -> ((Input "caption_entities" (TL.toStrict $ encodeToLazyText t)):)) sendPhotoCaptionEntities) $ (maybe id (\t -> ((Input "disable_notification" (bool "false" "true" t)):)) sendPhotoDisableNotification) $ (maybe id (\t -> ((Input "reply_to_message_id" (TL.toStrict $ encodeToLazyText t)):)) sendPhotoReplyToMessageId) @@ -364,7 +364,7 @@ [ sendAudioCaption <&> \t -> Input "caption" t , sendAudioParseMode <&> - \t -> Input "parse_mode" (TL.toStrict $ encodeToLazyText t) + \t -> Input "parse_mode" (TL.toStrict . TL.replace "\"" "" $ encodeToLazyText t) , sendAudioCaptionEntities <&> \t -> Input "caption_entities" (TL.toStrict $ encodeToLazyText t) , sendAudioDuration <&> @@ -449,7 +449,7 @@ [ sendVideoCaption <&> \t -> Input "caption" t , sendVideoParseMode <&> - \t -> Input "parse_mode" (TL.toStrict $ encodeToLazyText t) + \t -> Input "parse_mode" (TL.toStrict . TL.replace "\"" "" $ encodeToLazyText t) , sendVideoCaptionEntities <&> \t -> Input "caption_entities" (TL.toStrict $ encodeToLazyText t) , sendVideoDuration <&> @@ -532,7 +532,7 @@ [ sendAnimationCaption <&> \t -> Input "caption" t , sendAnimationParseMode <&> - \t -> Input "parse_mode" (TL.toStrict $ encodeToLazyText t) + \t -> Input "parse_mode" (TL.toStrict . TL.replace "\"" "" $ encodeToLazyText t) , sendAnimationCaptionEntities <&> \t -> Input "caption_entities" (TL.toStrict $ encodeToLazyText t) , sendAnimationDuration <&> @@ -608,7 +608,7 @@ [ sendVoiceCaption <&> \t -> Input "caption" t , sendVoiceParseMode <&> - \t -> Input "parse_mode" (TL.toStrict $ encodeToLazyText t) + \t -> Input "parse_mode" (TL.toStrict . TL.replace "\"" "" $ encodeToLazyText t) , sendVoiceCaptionEntities <&> \t -> Input "caption_entities" (TL.toStrict $ encodeToLazyText t) , sendVoiceDuration <&> diff --git a/src/Telegram/Bot/API/Payments.hs b/src/Telegram/Bot/API/Payments.hs --- a/src/Telegram/Bot/API/Payments.hs +++ b/src/Telegram/Bot/API/Payments.hs @@ -62,6 +62,44 @@ sendInvoice :: SendInvoiceRequest -> ClientM (Response Message) sendInvoice = client (Proxy @SendInvoice) +-- ** 'createInvoiceLink' + +data CreateInvoiceLinkRequest = CreateInvoiceLinkRequest + { createInvoiceLinkRequestTitle :: Text -- ^ Product name, 1-32 characters. + , createInvoiceLinkRequestDescription :: Text -- ^ Product description, 1-255 characters. + , createInvoiceLinkRequestPayload :: Text -- ^ Bot-defined invoice payload, 1-128 bytes. This will not be displayed to the user, use for your internal processes. + , createInvoiceLinkRequestProviderToken :: Text -- ^ Payment provider token, obtained via BotFather. + , createInvoiceLinkRequestCurrency :: Text -- ^ Three-letter ISO 4217 currency code, see more on currencies. + , createInvoiceLinkRequestPrices :: [LabeledPrice] -- ^ Price breakdown, a JSON-serialized list of components (e.g. product price, tax, discount, delivery cost, delivery tax, bonus, etc.). + , createInvoiceLinkRequestMaxTipAmount :: Maybe Integer -- ^ The maximum accepted amount for tips in the smallest units of the currency (integer, not float\/double). For example, for a maximum tip of US$ 1.45 pass max_tip_amount = 145. See the exp parameter in currencies.json, it shows the number of digits past the decimal point for each currency (2 for the majority of currencies). Defaults to 0. + , createInvoiceLinkRequestSuggestedTipAmounts :: Maybe [Integer] -- ^ A JSON-serialized array of suggested amounts of tips in the smallest units of the currency (integer, not float\/double). At most 4 suggested tip amounts can be specified. The suggested tip amounts must be positive, passed in a strictly increased order and must not exceed @max_tip_amount@. + , createInvoiceLinkRequestProviderData :: Maybe Text -- ^ JSON-serialized data about the invoice, which will be shared with the payment provider. A detailed description of required fields should be provided by the payment provider. + , createInvoiceLinkRequestPhotoUrl :: Maybe Text -- ^ URL of the product photo for the invoice. Can be a photo of the goods or a marketing image for a service. + , createInvoiceLinkRequestPhotoSize :: Maybe Int -- ^ Photo size in bytes. + , createInvoiceLinkRequestPhotoWidth :: Maybe Int -- ^ Photo width. + , createInvoiceLinkRequestPhotoHeight :: Maybe Int -- ^ Photo height + , createInvoiceLinkRequestNeedName :: Maybe Bool -- ^ Pass 'True' if you require the user's full name to complete the order. + , createInvoiceLinkRequestNeedPhoneNumber :: Maybe Bool -- ^ Pass 'True' if you require the user's phone number to complete the order. + , createInvoiceLinkRequestNeedEmail :: Maybe Bool -- ^ Pass 'True' if you require the user's email address to complete the order. + , createInvoiceLinkRequestNeedShippingAddress :: Maybe Bool -- ^ Pass 'True' if you require the user's shipping address to complete the order. + , createInvoiceLinkRequestSendPhoneNumberToProvider :: Maybe Bool -- ^ Pass 'True' if the user's phone number should be sent to the provider. + , createInvoiceLinkRequestSendEmailToProvider :: Maybe Bool -- ^ Pass 'True' if the user's email address should be sent to the provider. + , createInvoiceLinkRequestIsFlexible :: Maybe Bool -- ^ Pass 'True' if the final price depends on the shipping method. + } + deriving (Generic, Show) + +instance ToJSON CreateInvoiceLinkRequest where toJSON = gtoJSON +instance FromJSON CreateInvoiceLinkRequest where parseJSON = gparseJSON + +type CreateInvoiceLink + = "createInvoiceLink" + :> ReqBody '[JSON] CreateInvoiceLinkRequest + :> Post '[JSON] (Response Text) + +-- | Use this method to create a link for an invoice. Returns the created invoice link as 'Text' on success. +createInvoiceLink :: CreateInvoiceLinkRequest -> ClientM (Response Text) +createInvoiceLink = client (Proxy @CreateInvoiceLink) + -- ** 'answerShippingQuery' data AnswerShippingQueryRequest = AnswerShippingQueryRequest diff --git a/src/Telegram/Bot/API/Stickers.hs b/src/Telegram/Bot/API/Stickers.hs --- a/src/Telegram/Bot/API/Stickers.hs +++ b/src/Telegram/Bot/API/Stickers.hs @@ -17,6 +17,7 @@ #endif import Data.Aeson.Text import Data.Bool +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Proxy @@ -48,6 +49,8 @@ -- | Sticker file with static/animated label. data StickerFile = StickerFile {stickerFileSticker :: InputFile, stickerFileLabel :: StickerType} +-- ** 'sendSticker' + -- | Request parameters for 'sendSticker'. data SendStickerRequest = SendStickerRequest { sendStickerChatId :: SomeChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) @@ -100,7 +103,23 @@ client (Proxy @SendStickerContent) (boundary, r) _ -> client (Proxy @SendStickerLink) r +-- ** 'getCustomEmojiStickers' +-- | Request parameters for 'getCustomEmojiStickers'. +data GetCustomEmojiStickersRequest = GetCustomEmojiStickersRequest + { getCustomEmojiStickersRequestCustomEmojiIds :: [Text] -- ^ List of custom emoji identifiers. At most 200 custom emoji identifiers can be specified. + } + deriving Generic + +instance ToJSON GetCustomEmojiStickersRequest where toJSON = gtoJSON + +type GetCustomEmojiStickers + = "getCustomEmojiStickers" + :> ReqBody '[JSON] GetCustomEmojiStickersRequest + :> Post '[JSON] (Response [Sticker]) + +-- ** 'uploadStickerFile' + -- | Request parameters for 'uploadStickerFile'. data UploadStickerFileRequest = UploadStickerFileRequest { uploadStickerFileUserId :: UserId -- ^ User identifier of sticker file owner @@ -137,6 +156,8 @@ _ -> client (Proxy @UploadStickerFileLink) r +-- ** 'createNewStickerSet' + -- | Request parameters for 'createNewStickerSet'. data CreateNewStickerSetRequest = CreateNewStickerSetRequest { createNewStickerSetUserId :: UserId -- ^ User identifier of created sticker set owner @@ -204,6 +225,8 @@ client (Proxy @CreateNewStickerSetContent) (boundary, r) _ -> client (Proxy @CreateNewStickerSetLink) r +-- ** 'addStickerToSet' + -- | Request parameters for 'addStickerToSet'. data AddStickerToSetRequest = AddStickerToSetRequest { addStickerToSetUserId :: UserId -- ^ User identifier of sticker set owner @@ -267,6 +290,8 @@ _ -> client (Proxy @AddStickerToSetLink) r +-- ** 'getStickerSet' + type GetStickerSet = "getStickerSet" :> RequiredQueryParam "name" T.Text @@ -277,6 +302,8 @@ -> ClientM (Response StickerSet) getStickerSet = client (Proxy @GetStickerSet) +-- ** 'setStickerPositionInSet' + type SetStickerPositionInSet = "setStickerPositionInSet" :> RequiredQueryParam "sticker" T.Text @@ -291,6 +318,8 @@ setStickerPositionInSet = client (Proxy @SetStickerPositionInSet) +-- ** 'deleteStickerFromSet' + type DeleteStickerFromSet = "deleteStickerFromSet" :> RequiredQueryParam "sticker" T.Text @@ -301,6 +330,8 @@ deleteStickerFromSet :: T.Text -- ^ File identifier of the sticker -> ClientM (Response Bool) deleteStickerFromSet = client (Proxy @DeleteStickerFromSet) + +-- ** 'setStickerSetThumb' -- | Request parameters for 'setStickerSetThumb'. data SetStickerSetThumbRequest = SetStickerSetThumbRequest diff --git a/src/Telegram/Bot/API/Types.hs b/src/Telegram/Bot/API/Types.hs --- a/src/Telegram/Bot/API/Types.hs +++ b/src/Telegram/Bot/API/Types.hs @@ -52,6 +52,8 @@ , userLastName :: Maybe Text -- ^ User‘s or bot’s last name. , userUsername :: Maybe Text -- ^ User‘s or bot’s username. , userLanguageCode :: Maybe Text -- ^ IETF language tag of the user's language. + , userIsPremium :: Maybe Bool -- ^ 'True', if this user is a Telegram Premium user. + , userAddedToAttachmentMenu :: Maybe Bool -- ^ 'True', if this user added the bot to the attachment menu. , userCanJoinGroups :: Maybe Bool -- ^ 'True', if the bot can be invited to groups. Returned only in `getMe`. , userCanReadAllGroupMessages :: Maybe Bool -- ^ 'True', if privacy mode is disabled for the bot. Returned only in `getMe`. , userSupportsInlineQueries :: Maybe Bool -- ^ 'True', if the bot supports inline queries. Returned only in `getMe`. @@ -80,6 +82,9 @@ , chatPhoto :: Maybe ChatPhoto -- ^ Chat photo. Returned only in getChat. , chatBio :: Maybe Text -- ^ Bio of the other party in a private chat. Returned only in `getChat`. , chatHasPrivateForwards :: Maybe Bool -- ^ 'True', if privacy settings of the other party in the private chat allows to use `tg://user?id=` links only in chats with the user. Returned only in getChat. + , chatHasRestrictedVoiceAndVideoMessages :: Maybe Bool -- ^ 'True', if the privacy settings of the other party restrict sending voice and video note messages in the private chat. Returned only in 'getChat'. + , chatJoinToSendMessages :: Maybe Bool -- ^ 'True', if users need to join the supergroup before they can send messages. Returned only in 'getChat'. + , chatJoinByRequest :: Maybe Bool -- ^ 'True', if all users directly joining the supergroup need to be approved by supergroup administrators. Returned only in 'getChat'. , chatDescription :: Maybe Text -- ^ Description, for supergroups and channel chats. Returned only in getChat. , chatInviteLink :: Maybe Text -- ^ Chat invite link, for supergroups and channel chats. Returned only in getChat. , chatPinnedMessage :: Maybe Message -- ^ Pinned message, for supergroups. Returned only in getChat. @@ -201,6 +206,7 @@ , messageEntityUrl :: Maybe Text -- ^ For “text_link” only, url that will be opened after user taps on the text , messageEntityUser :: Maybe User -- ^ For “text_mention” only, the mentioned user , messageEntityLanguage :: Maybe Text -- ^ For “pre” only, the programming language of the entity text. + , messageEntityCustomEmojiId :: Maybe Text -- ^ For “custom_emoji” only, unique identifier of the custom emoji. Use @getCustomEmojiStickers@ to get full information about the sticker. } deriving (Generic, Show) @@ -222,6 +228,7 @@ | MessageEntityCashtag -- ^ See . | MessageEntityPhoneNumber -- ^ See . | MessageEntitySpoiler + | MessageEntityCustomEmoji deriving (Eq, Show, Generic) -- ** 'PhotoSize' @@ -255,7 +262,7 @@ , animationThumb :: Maybe PhotoSize -- ^ Animation thumbnail as defined by sender. , animationFileName :: Maybe Text -- ^ Original animation filename as defined by sender. , animationMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender. - , animationFileSize :: Maybe Int -- ^ File size in bytes. + , animationFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -270,7 +277,7 @@ , audioTitle :: Maybe Text -- ^ Title of the audio as defined by sender or by audio tags. , audioFileName :: Maybe Text -- ^ Original filename as defined by sender. , audioMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender. - , audioFileSize :: Maybe Int -- ^ File size in bytes. + , audioFileSize :: Maybe Integer -- ^ File size in bytes. , audioThumb :: Maybe PhotoSize -- ^ Thumbnail of the album cover to which the music file belongs. } deriving (Generic, Show) @@ -284,7 +291,7 @@ , documentThumb :: Maybe PhotoSize -- ^ Document thumbnail as defined by sender. , documentFileName :: Maybe Text -- ^ Original filename as defined by sender. , documentMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender. - , documentFileSize :: Maybe Int -- ^ File size in bytes. + , documentFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -300,7 +307,7 @@ , videoThumb :: Maybe PhotoSize -- ^ Video thumbnail. , videoFileName :: Maybe Text -- ^ Original filename as defined by sender. , videoMimeType :: Maybe Text -- ^ Mime type of a file as defined by sender. - , videoFileSize :: Maybe Int -- ^ File size in bytes. + , videoFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -313,7 +320,7 @@ , videoNoteLength :: Int -- ^ Video width and height as defined by sender. , videoNoteDuration :: Seconds -- ^ Duration of the video in seconds as defined by sender. , videoNoteThumb :: Maybe PhotoSize -- ^ Video thumbnail. - , videoNoteFileSize :: Maybe Int -- ^ File size in bytes. + , videoNoteFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -325,7 +332,7 @@ , voiceFileUniqueId :: FileId -- ^ Unique identifier for this file, which is supposed to be the same over time and for different bots. Can't be used to download or reuse the file. , voiceDuration :: Seconds -- ^ Duration of the audio in seconds as defined by sender. , voiceMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender. - , voiceFileSize :: Maybe Int -- ^ File size in bytes. + , voiceFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -491,7 +498,7 @@ data File = File { fileFileId :: FileId -- ^ Unique identifier for this file. , fileFileUniqueId :: FileId -- ^ Unique identifier for this file, which is supposed to be the same over time and for different bots. Can't be used to download or reuse the file. - , fileFileSize :: Maybe Int -- ^ File size in bytes, if known. + , fileFileSize :: Maybe Integer -- ^ File size in bytes, if known. , fileFilePath :: Maybe Text -- ^ File path. Use https://api.telegram.org/file/bot/ to get the file. } deriving (Generic, Show) @@ -829,7 +836,9 @@ , stickerThumb :: Maybe PhotoSize -- ^ Sticker thumbnail in the .WEBP or .JPG format. , stickerEmoji :: Maybe Text -- ^ Emoji associated with the sticker. , stickerSetName :: Maybe Text -- ^ Name of the sticker set to which the sticker belongs. + , stickerPremiumAnimation :: Maybe File -- ^ For premium regular stickers, premium animation for the sticker. , stickerMaskPosition :: Maybe MaskPosition -- ^ For mask stickers, the position where the mask should be placed. + , stickerCustomEmojiId :: Maybe Text -- ^ For custom emoji stickers, unique identifier of the custom emoji. , stickerFileSize :: Maybe Integer -- ^ File size in bytes. } deriving (Generic, Show) @@ -840,14 +849,22 @@ data StickerSet = StickerSet { stickerSetName :: Text -- ^ Sticker set name. , stickerSetTitle :: Text -- ^ Sticker set title. + , stickerSetType :: StickerSetType -- ^ Type of stickers in the set, currently one of “regular”, “mask”, “custom_emoji”. , stickerSetIsAnimated :: Bool -- ^ 'True', if the sticker set contains animated stickers. , stickerSetIsVideo :: Bool -- ^ 'True', if the sticker is a video sticker. - , stickerSetContainsMasks :: Bool -- ^ True, if the sticker set contains masks. + , stickerSetContainsMasks :: Maybe Bool -- ^ True, if the sticker set contains masks. , stickerSetStickers :: [Sticker] -- ^ List of all set stickers. , stickerSetThumb :: Maybe PhotoSize -- ^ Sticker set thumbnail in the .WEBP or .TGS format. } deriving (Generic, Show) +-- | Type of stickers in the set, currently one of “regular”, “mask”, “custom_emoji”. +data StickerSetType + = StickerSetTypeRegular + | StickerSetTypeMask + | StickerSetTypeCustomEmoji + deriving (Eq, Show, Generic) + -- ** 'MaskPosition' -- | This object describes the position on faces where a mask should be placed by default. @@ -1217,6 +1234,7 @@ , ''PhotoSize , ''Audio , ''Document + , ''StickerSetType , ''Sticker , ''Video , ''Voice diff --git a/src/Telegram/Bot/API/Webhook.hs b/src/Telegram/Bot/API/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Webhook.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Telegram.Bot.API.Webhook + ( setUpWebhook, + webhookApp, + deleteWebhook, + SetWebhookRequest (..), + ) +where + +import Control.Concurrent (forkIO) +import Control.Concurrent.STM +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson (ToJSON (toJSON)) +import Data.Bool (bool) +import Data.Functor (void, (<&>)) +import Data.Maybe (catMaybes, fromJust, + isJust) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Servant +import Servant.Client (ClientEnv, ClientError, + client, runClientM) +import Servant.Multipart.API +import Servant.Multipart.Client (genBoundary) +import Telegram.Bot.API.GettingUpdates (Update) +import Telegram.Bot.API.Internal.Utils (gtoJSON) +import Telegram.Bot.API.MakingRequests (Response) +import Telegram.Bot.API.Types (InputFile, makeFile) +import Telegram.Bot.Simple.BotApp.Internal + +type WebhookAPI = ReqBody '[JSON] Update :> Post '[JSON] () + +server :: BotApp model action -> BotEnv model action -> Server WebhookAPI +server BotApp {..} botEnv@BotEnv {..} = + updateHandler + where + updateHandler :: Update -> Handler () + updateHandler update = liftIO $ handleUpdate update + handleUpdate update = liftIO . void . forkIO $ do + maction <- botAction update <$> readTVarIO botModelVar + case maction of + Nothing -> return () + Just action -> issueAction botEnv (Just update) (Just action) + +webhookAPI :: Proxy WebhookAPI +webhookAPI = Proxy + +app :: BotApp model action -> BotEnv model action -> Application +app botApp botEnv = serve webhookAPI $ server botApp botEnv + +data SetWebhookRequest = SetWebhookRequest + { setWebhookUrl :: String, + setWebhookCertificate :: Maybe InputFile, + setWebhookIpAddress :: Maybe String, + setWebhookMaxConnections :: Maybe Int, + setWebhookAllowedUpdates :: Maybe [String], + setWebhookDropPendingUpdates :: Maybe Bool, + setWebhookSecretToken :: Maybe String + } + deriving (Generic) + +instance ToJSON SetWebhookRequest where toJSON = gtoJSON + +newtype DeleteWebhookRequest = DeleteWebhookRequest + { deleteWebhookDropPendingUpdates :: Maybe Bool + } + deriving (Generic) + +instance ToJSON DeleteWebhookRequest where toJSON = gtoJSON + +instance ToMultipart Tmp SetWebhookRequest where + toMultipart SetWebhookRequest {..} = + makeFile "certificate" (fromJust setWebhookCertificate) (MultipartData fields []) + where + fields = + [Input "url" $ Text.pack setWebhookUrl] + <> catMaybes + [ setWebhookSecretToken <&> \t -> Input "secret_token" $ Text.pack t, + setWebhookIpAddress <&> \t -> Input "ip_address" $ Text.pack t, + setWebhookMaxConnections <&> \t -> Input "max_connections" $ Text.pack $ show t, + setWebhookDropPendingUpdates <&> \t -> Input "drop_pending_updates" (bool "false" "true" t), + setWebhookAllowedUpdates <&> \t -> Input "allowed_updates" (arrToJson t) + ] + arrToJson arr = Text.intercalate "" ["[", Text.intercalate "," (map (\s -> Text.pack $ "\"" ++ s ++ "\"") arr), "]"] + +type SetWebhookForm = + "setWebhook" :> MultipartForm Tmp SetWebhookRequest :> Get '[JSON] (Response Bool) + +type SetWebhookJson = + "setWebhook" :> ReqBody '[JSON] SetWebhookRequest :> Get '[JSON] (Response Bool) + +type DeleteWebhook = + "deleteWebhook" :> ReqBody '[JSON] DeleteWebhookRequest :> Get '[JSON] (Response Bool) + +setUpWebhook :: SetWebhookRequest -> ClientEnv -> IO (Either ClientError ()) +setUpWebhook requestData = (void <$>) <$> runClientM setUpWebhookRequest + where + setUpWebhookRequest = + if isJust $ setWebhookCertificate requestData + then do + boundary <- liftIO genBoundary + client (Proxy @SetWebhookForm) (boundary, requestData) + else client (Proxy @SetWebhookJson) requestData + +deleteWebhook :: ClientEnv -> IO (Either ClientError ()) +deleteWebhook = (void <$>) <$> runClientM deleteWebhookRequest + where + requestData = DeleteWebhookRequest {deleteWebhookDropPendingUpdates = Nothing} + deleteWebhookRequest = client (Proxy @DeleteWebhook) requestData + +webhookApp :: BotApp model action -> BotEnv model action -> Application +webhookApp = app diff --git a/src/Telegram/Bot/Simple/BotApp.hs b/src/Telegram/Bot/Simple/BotApp.hs --- a/src/Telegram/Bot/Simple/BotApp.hs +++ b/src/Telegram/Bot/Simple/BotApp.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE RecordWildCards #-} module Telegram.Bot.Simple.BotApp ( BotApp(..), BotJob(..), + WebhookConfig(..), startBot, startBot_, @@ -8,6 +10,9 @@ startBotAsync, startBotAsync_, + startBotWebhook, + startBotWebhook_, + getEnvToken, ) where @@ -17,7 +22,14 @@ import Servant.Client import System.Environment (getEnv) +import Control.Exception (finally) +import Data.Either (isLeft) +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS import qualified Telegram.Bot.API as Telegram +import Telegram.Bot.API.Webhook (SetWebhookRequest, + deleteWebhook, + setUpWebhook, webhookApp) import Telegram.Bot.Simple.BotApp.Internal -- | Start bot with asynchronous polling. @@ -44,6 +56,30 @@ -- | Like 'startBot', but ignores result. startBot_ :: BotApp model action -> ClientEnv -> IO () startBot_ bot = void . startBot bot + +data WebhookConfig = WebhookConfig + { webhookConfigTlsSettings :: TLSSettings, + webhookConfigTlsWarpSettings :: Settings, + webhookConfigSetWebhookRequest :: SetWebhookRequest + } + +-- | Start bot with webhook on update in the main thread. +-- Port must be one of 443, 80, 88, 8443 +-- certPath must be provided if using self signed certificate. +startBotWebhook :: BotApp model action -> WebhookConfig -> ClientEnv -> IO (Either ClientError ()) +startBotWebhook bot (WebhookConfig{..}) env = do + botEnv <- startBotEnv bot env + res <- setUpWebhook webhookConfigSetWebhookRequest env + if isLeft res + then return res + else Right <$> runTLS webhookConfigTlsSettings webhookConfigTlsWarpSettings (webhookApp bot botEnv) + `finally` + deleteWebhook env + + +-- | Like 'startBotWebhook', but ignores result. +startBotWebhook_ :: BotApp model action -> WebhookConfig -> ClientEnv -> IO () +startBotWebhook_ bot webhookConfig = void . startBotWebhook bot webhookConfig -- | Get a 'Telegram.Token' from environment variable. -- diff --git a/src/Telegram/Bot/Simple/UpdateParser.hs b/src/Telegram/Bot/Simple/UpdateParser.hs --- a/src/Telegram/Bot/Simple/UpdateParser.hs +++ b/src/Telegram/Bot/Simple/UpdateParser.hs @@ -11,12 +11,14 @@ import Data.Monoid ((<>)) #endif #endif +import qualified Data.Char as Char import Data.Text (Text) import qualified Data.Text as Text import Text.Read (readMaybe) import Telegram.Bot.API + newtype UpdateParser a = UpdateParser { runUpdateParser :: Update -> Maybe a } deriving (Functor) @@ -60,18 +62,18 @@ command :: Text -> UpdateParser Text command name = do t <- text - case Text.words t of - (w:ws) | w == "/" <> name - -> pure (Text.unwords ws) - _ -> fail "not that command" + let (cmd, rest) = Text.break Char.isSpace t + if cmd == "/" <> name + then pure $ Text.stripStart rest + else fail "not that command" commandWithBotName :: Text -> Text -> UpdateParser Text commandWithBotName botname commandname = do t <- text - case Text.words t of - (w:ws)| w `elem` ["/" <> commandname <> "@" <> botname, "/" <> commandname] - -> pure (Text.unwords ws) - _ -> fail "not that command" + let (cmd, rest) = Text.break Char.isSpace t + if cmd `elem` ["/" <> commandname <> "@" <> botname, "/" <> commandname] + then pure $ Text.stripStart rest + else fail "not that command" callbackQueryDataRead :: Read a => UpdateParser a callbackQueryDataRead = mkParser $ \update -> do diff --git a/telegram-bot-simple.cabal b/telegram-bot-simple.cabal --- a/telegram-bot-simple.cabal +++ b/telegram-bot-simple.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: telegram-bot-simple -version: 0.5.2 +version: 0.6 synopsis: Easy to use library for building Telegram bots. description: Please see the README on Github at category: Web @@ -48,6 +48,7 @@ Telegram.Bot.API.Types Telegram.Bot.API.UpdatingMessages Telegram.Bot.API.WebApps + Telegram.Bot.API.Webhook Telegram.Bot.Simple Telegram.Bot.Simple.BotApp Telegram.Bot.Simple.BotApp.Internal @@ -82,6 +83,7 @@ , servant-client , servant-multipart-api , servant-multipart-client + , servant-server , split , stm , template-haskell @@ -89,6 +91,8 @@ , time , transformers , unordered-containers + , warp + , warp-tls default-language: Haskell2010 executable example-echo-bot @@ -115,6 +119,7 @@ , servant-client , servant-multipart-api , servant-multipart-client + , servant-server , split , stm , template-haskell @@ -122,6 +127,8 @@ , time , transformers , unordered-containers + , warp + , warp-tls if flag(examples) build-depends: telegram-bot-simple @@ -129,6 +136,47 @@ buildable: False default-language: Haskell2010 +executable example-echo-bot-webhook + main-is: examples/EchoBotWebhook.hs + other-modules: + Paths_telegram_bot_simple + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-pretty + , base >=4.9 && <5 + , bytestring + , cron >=0.7.0 + , filepath + , hashable + , http-api-data + , http-client + , http-client-tls + , monad-control + , mtl + , pretty-show + , profunctors + , servant + , servant-client + , servant-multipart-api + , servant-multipart-client + , servant-server + , split + , stm + , template-haskell + , text + , time + , transformers + , unordered-containers + , warp + , warp-tls + if flag(examples) + build-depends: + telegram-bot-simple + else + buildable: False + default-language: Haskell2010 + executable example-game-bot main-is: examples/GameBot.hs other-modules: @@ -153,6 +201,7 @@ , servant-client , servant-multipart-api , servant-multipart-client + , servant-server , split , stm , template-haskell @@ -160,6 +209,8 @@ , time , transformers , unordered-containers + , warp + , warp-tls if flag(examples) build-depends: QuickCheck @@ -204,6 +255,7 @@ , servant-client , servant-multipart-api , servant-multipart-client + , servant-server , split , stm , template-haskell @@ -211,6 +263,8 @@ , time , transformers , unordered-containers + , warp + , warp-tls if flag(examples) build-depends: telegram-bot-simple