diff --git a/.gitignore b/.gitignore index 65f150b..db49dc9 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ cabal.sandbox.config *.iml dist dist-newstyle +stack.yaml.lock diff --git a/src/Servant/Client/MultipartFormData.hs b/src/Servant/Client/MultipartFormData.hs index ce2efb8..9660715 100644 --- a/src/Servant/Client/MultipartFormData.hs +++ b/src/Servant/Client/MultipartFormData.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} @@ -20,9 +21,9 @@ import Control.Monad.IO.Class import Control.Monad.Reader.Class import Data.Bifunctor (bimap) import Data.Binary.Builder (toLazyByteString) -import Data.ByteString.Lazy hiding (pack, any) -import Data.Proxy +import Data.ByteString.Lazy hiding (any, pack) import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy import qualified Data.Sequence as Sequence import Data.Text (pack) import Data.Typeable (Typeable) @@ -34,10 +35,15 @@ import Network.HTTP.Types import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API -import Servant.Client +import Servant.Client (BaseUrl, + ClientError (DecodeFailure, FailureResponse, InvalidContentTypeHeader, UnsupportedContentType), + ClientM, HasClient, + baseUrl, + makeClientRequest, + manager) import qualified Servant.Client.Core as Core -import Servant.Client.Internal.HttpClient (catchConnectionError, clientResponseToResponse, - requestToClientRequest) +import Servant.Client.Internal.HttpClient (catchConnectionError, + clientResponseToResponse) -- | A type that can be converted to a multipart/form-data value. class ToMultipartFormData a where @@ -50,12 +56,21 @@ data MultipartFormDataReqBody a instance (Core.RunClient m, ToMultipartFormData b, MimeUnrender ct a, cts' ~ (ct ': cts) ) => HasClient m (MultipartFormDataReqBody b :> Post cts' a) where - type Client m (MultipartFormDataReqBody b :> Post cts' a) = b-> ClientM a - clientWithRoute _pm Proxy req reqData = + + type Client m (MultipartFormDataReqBody b :> Post cts' a) = b -> ClientM a + + clientWithRoute _pm Proxy req reqData = do + clientEnv <- ask let requestToClientRequest' req' baseurl' = do - let requestWithoutBody = requestToClientRequest baseurl' req' + requestWithoutBody <- + #if ! MIN_VERSION_servant_client(0,20,0) + pure $ + #endif + makeClientRequest clientEnv baseurl' req' formDataBody (toMultipartFormData reqData) requestWithoutBody - in snd <$> performRequestCT' requestToClientRequest' (Proxy :: Proxy ct) H.methodPost req + snd <$> performRequestCT' requestToClientRequest' (Proxy :: Proxy ct) H.methodPost req + + hoistClientMonad _ _ _ _ = error "unreachable" -- copied `performRequest` from servant-0.11, then modified so it takes a variant of `requestToClientRequest` -- as an argument. @@ -104,5 +119,5 @@ performRequestCT' requestToClientRequest' ct reqMethod req = do let coreResponse = clientResponseToResponse id _response unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT coreResponse case mimeUnrender ct respBody of - Left err -> throwError $ DecodeFailure (pack err) coreResponse + Left err -> throwError $ DecodeFailure (pack err) coreResponse Right val -> return (hdrs, val) diff --git a/src/Web/Telegram/API/Bot/API.hs b/src/Web/Telegram/API/Bot/API.hs index 125c71c..d3691c4 100644 --- a/src/Web/Telegram/API/Bot/API.hs +++ b/src/Web/Telegram/API/Bot/API.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API diff --git a/src/Web/Telegram/API/Bot/API/Chats.hs b/src/Web/Telegram/API/Bot/API/Chats.hs index b9dd487..5d52912 100644 --- a/src/Web/Telegram/API/Bot/API/Chats.hs +++ b/src/Web/Telegram/API/Bot/API/Chats.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Chats diff --git a/src/Web/Telegram/API/Bot/API/Core.hs b/src/Web/Telegram/API/Bot/API/Core.hs index 963c295..46927ef 100644 --- a/src/Web/Telegram/API/Bot/API/Core.hs +++ b/src/Web/Telegram/API/Bot/API/Core.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Core ( -- * Types @@ -24,7 +23,10 @@ import Control.Monad.Trans.Reader import Data.Text (Text) import Network.HTTP.Client (Manager) import Servant.API -import Servant.Client +import Servant.Client (BaseUrl (BaseUrl), ClientEnv, + ClientError, ClientM, + Scheme (Https), mkClientEnv, + runClientM) -- | Telegram Bot's Token newtype Token = Token Text @@ -44,7 +46,7 @@ runClient' tcm token = runClientM (runReaderT tcm token) -- | Runs 'TelegramClient' runClient :: TelegramClient a -> Token -> Manager -> IO (Either ClientError a) -runClient tcm token manager = runClient' tcm token (ClientEnv manager telegramBaseUrl Nothing) +runClient tcm token manager = runClient' tcm token (mkClientEnv manager telegramBaseUrl) -- | Runs 'TelegramClient' runTelegramClient :: Token -> Manager -> TelegramClient a -> IO (Either ClientError a) @@ -54,7 +56,7 @@ asking :: Monad m => (t -> m b) -> ReaderT t m b asking op = ask >>= \t -> lift $ op t run :: BaseUrl -> (Token -> a -> ClientM b) -> Token -> a -> Manager -> IO (Either ClientError b) -run b e t r m = runClientM (e t r) (ClientEnv m b Nothing) +run b e t r m = runClientM (e t r) (mkClientEnv m b) run_ :: Monad m => (a -> b -> m c) -> b -> ReaderT a m c run_ act request = asking $ flip act request diff --git a/src/Web/Telegram/API/Bot/API/Edit.hs b/src/Web/Telegram/API/Bot/API/Edit.hs index 41f3b22..0820342 100644 --- a/src/Web/Telegram/API/Bot/API/Edit.hs +++ b/src/Web/Telegram/API/Bot/API/Edit.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Edit diff --git a/src/Web/Telegram/API/Bot/API/Get.hs b/src/Web/Telegram/API/Bot/API/Get.hs index bbc1dae..af98f8c 100644 --- a/src/Web/Telegram/API/Bot/API/Get.hs +++ b/src/Web/Telegram/API/Bot/API/Get.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Get diff --git a/src/Web/Telegram/API/Bot/API/Messages.hs b/src/Web/Telegram/API/Bot/API/Messages.hs index 32e4f50..4630e3e 100644 --- a/src/Web/Telegram/API/Bot/API/Messages.hs +++ b/src/Web/Telegram/API/Bot/API/Messages.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Messages diff --git a/src/Web/Telegram/API/Bot/API/Payments.hs b/src/Web/Telegram/API/Bot/API/Payments.hs index 0911234..b92ce22 100644 --- a/src/Web/Telegram/API/Bot/API/Payments.hs +++ b/src/Web/Telegram/API/Bot/API/Payments.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Payments diff --git a/src/Web/Telegram/API/Bot/API/Queries.hs b/src/Web/Telegram/API/Bot/API/Queries.hs index d080e77..e1e3f40 100644 --- a/src/Web/Telegram/API/Bot/API/Queries.hs +++ b/src/Web/Telegram/API/Bot/API/Queries.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Queries diff --git a/src/Web/Telegram/API/Bot/API/Updates.hs b/src/Web/Telegram/API/Bot/API/Updates.hs index c5054ad..e4ec0de 100644 --- a/src/Web/Telegram/API/Bot/API/Updates.hs +++ b/src/Web/Telegram/API/Bot/API/Updates.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Updates diff --git a/src/Web/Telegram/API/Bot/Data.hs b/src/Web/Telegram/API/Bot/Data.hs index ff58954..794270d 100644 --- a/src/Web/Telegram/API/Bot/Data.hs +++ b/src/Web/Telegram/API/Bot/Data.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} -- | This module contains objects which represent data of Telegram Bot API responses @@ -32,6 +34,8 @@ module Web.Telegram.API.Bot.Data , InlineQueryResult (..) , InlineKeyboardMarkup (..) , InlineKeyboardButton (..) + , WebAppInfo (..) + , LoginUrl (..) , CallbackGame (..) , CallbackQuery (..) , ChatType (..) @@ -77,6 +81,7 @@ module Web.Telegram.API.Bot.Data , inlineQueryResultCachedVoice , inputMediaPhoto , inputMediaVideo + , loginUrl ) where import Prelude hiding (id) @@ -84,7 +89,7 @@ import Prelude hiding (id) import Data.Aeson import qualified Data.Char as Char import Data.Int (Int64) -import Data.List +import Data.List (isPrefixOf) import Data.Text (Text) import GHC.Generics @@ -732,7 +737,7 @@ inlineQueryResultCachedVoice id fileId title = InlineQueryResultCachedVoice id f inlineQueryResultCachedAudio :: Text -> Text -> InlineQueryResult inlineQueryResultCachedAudio id fileId = InlineQueryResultCachedAudio id fileId Nothing Nothing Nothing -data InlineKeyboardMarkup = InlineKeyboardMarkup +newtype InlineKeyboardMarkup = InlineKeyboardMarkup { inline_keyboard :: [[InlineKeyboardButton]] } deriving (FromJSON, ToJSON, Show, Generic) @@ -740,11 +745,17 @@ data InlineKeyboardMarkup = InlineKeyboardMarkup data InlineKeyboardButton = InlineKeyboardButton { ikb_text :: Text -- ^ Label text on the button - , ikb_url :: Maybe Text -- ^ HTTP url to be opened when button is pressed + , ikb_url :: Maybe Text -- ^ HTTP or tg:// URL to be opened when the button is pressed. Links @tg://user?id=@ can be used to mention a user by their ID without using a username, if this is allowed by their privacy settings. , ikb_callback_data :: Maybe Text -- ^ Data to be sent in a callback query to the bot when button is pressed, 1-64 bytes + , ikb_web_app :: Maybe WebAppInfo -- ^ Description of the Web App that will be launched when the user presses the button. The Web App will be able to send an arbitrary message on behalf of the user using the method 'answerWebAppQuery'. Available only in private chats between a user and the bot. + , ikb_login_url :: Maybe LoginUrl -- ^ An HTTPS URL used to automatically authorize the user. Can be used as a replacement for the Telegram Login Widget. , ikb_switch_inline_query :: Maybe Text -- ^ If set, pressing the button will prompt the user to select one of their chats, open that chat and insert the bot‘s username and the specified inline query in the input field. Can be empty, in which case just the bot’s username will be inserted. + -- + -- Note: This offers an easy way for users to start using your bot in inline mode when they are currently in a private chat with it. Especially useful when combined with switch_pm… actions - in this case the user will be automatically returned to the chat they switched from, skipping the chat selection screen. + , ikb_switch_inline_query_current_chat :: Maybe Text -- ^ If set, pressing the button will insert the bot's username and the specified inline query in the current chat's input field. May be empty, in which case only the bot's username will be inserted. + -- + -- This offers a quick way for the user to open your bot in inline mode in the same chat - good for selecting something from multiple options. , ikb_callback_game :: Maybe CallbackGame -- ^ Description of the game that will be launched when the user presses the button. NOTE: This type of button must always be the first button in the first row. - , ikb_switch_inline_query_current_chat :: Maybe Text -- ^ If set, pressing the button will insert the bot‘s username and the specified inline query in the current chat's input field. Can be empty, in which case only the bot’s username will be inserted. , ikb_pay :: Maybe Bool -- ^ Specify True, to send a Pay button. NOTE: This type of button must always be the first button in the first row. } deriving (Show, Generic) @@ -756,7 +767,43 @@ instance FromJSON InlineKeyboardButton where inlineKeyboardButton :: Text -> InlineKeyboardButton inlineKeyboardButton buttonText = - InlineKeyboardButton buttonText Nothing Nothing Nothing Nothing Nothing Nothing + InlineKeyboardButton buttonText Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | Describes a Web App. +newtype WebAppInfo = WebAppInfo + { + wai_url :: Text -- ^ An HTTPS URL of a Web App to be opened with additional data as specified in Initializing Web Apps + } deriving (Show, Generic) + +instance ToJSON WebAppInfo where + toJSON = toJsonDrop 4 + +instance FromJSON WebAppInfo where + parseJSON = parseJsonDrop 4 + +-- | This object represents a parameter of the inline keyboard button used to automatically authorize a user. Serves as a great replacement for the Telegram Login Widget when the user is coming from Telegram. All the user needs to do is tap/click a button and confirm that they want to log in: +-- +-- Telegram apps support these buttons as of version 5.7. +-- +-- Sample bot: @discussbot +data LoginUrl = LoginUrl + { + lu_url :: Text -- ^ An HTTPS URL to be opened with user authorization data added to the query string when the button is pressed. If the user refuses to provide authorization data, the original URL without information about the user will be opened. The data added is the same as described in Receiving authorization data. + -- + -- NOTE: You must always check the hash of the received data to verify the authentication and the integrity of the data as described in Checking authorization. + , lu_forward_text :: Maybe Text -- ^ New text of the button in forwarded messages. + , lu_bot_username :: Maybe Text -- ^ Username of a bot, which will be used for user authorization. See Setting up a bot for more details. If not specified, the current bot's username will be assumed. The url's domain must be the same as the domain linked with the bot. See Linking your domain to the bot for more details. + , lu_request_write_access :: Maybe Bool -- ^ Pass True to request the permission for your bot to send messages to the user. + } deriving (Show, Generic) + +instance ToJSON LoginUrl where + toJSON = toJsonDrop 3 + +instance FromJSON LoginUrl where + parseJSON = parseJsonDrop 3 + +loginUrl :: Text -> LoginUrl +loginUrl url = LoginUrl url Nothing Nothing Nothing data CallbackGame = CallbackGame { @@ -785,6 +832,28 @@ instance ToJSON CallbackQuery where instance FromJSON CallbackQuery where parseJSON = parseJsonDrop 3 +type BusinessConnection = Value + +type BusinessMessagesDeleted = Value + +type MessageReactionCountUpdated = Value + +type MessageReactionUpdated = Value + +type PaidMediaPurchased = Value + +type Poll = Value + +type PollAnswer = Value + +type ChatMemberUpdated = Value + +type ChatJoinRequest = Value + +type ChatBoostUpdated = Value + +type ChatBoostRemoved = Value + -- | This object represents an incoming update. -- Only one of the optional parameters can be present in any given update. data Update = Update @@ -794,11 +863,25 @@ data Update = Update , edited_message :: Maybe Message -- ^ New version of a message that is known to the bot and was edited , channel_post :: Maybe Message -- ^ New incoming channel post of any kind — text, photo, sticker, etc. , edited_channel_post :: Maybe Message -- ^ New version of a channel post that is known to the bot and was edited + , business_connection :: Maybe BusinessConnection -- ^ The bot was connected to or disconnected from a business account, or a user edited an existing connection with the bot + , business_message :: Maybe Message -- ^ New message from a connected business account + , edited_business_message :: Maybe Message -- ^ New version of a message from a connected business account + , deleted_business_messages :: Maybe BusinessMessagesDeleted -- ^ Messages were deleted from a connected business account + , message_reaction :: Maybe MessageReactionUpdated -- ^ A reaction to a message was changed by a user. The bot must be an administrator in the chat and must explicitly specify "message_reaction" in the list of allowed_updates to receive these updates. The update isn't received for reactions set by bots. + , message_reaction_count :: MessageReactionCountUpdated -- ^ Reactions to a message with anonymous reactions were changed. The bot must be an administrator in the chat and must explicitly specify "message_reaction_count" in the list of allowed_updates to receive these updates. The updates are grouped and can be sent with delay up to a few minutes. , inline_query :: Maybe InlineQuery -- ^ New incoming inline query , chosen_inline_result :: Maybe ChosenInlineResult -- ^ The result of a inline query that was chosen by a user and sent to their chat partner , callback_query :: Maybe CallbackQuery -- ^ This object represents an incoming callback query from a callback button in an inline keyboard. If the button that originated the query was attached to a message sent by the bot, the field message will be presented. If the button was attached to a message sent via the bot (in inline mode), the field inline_message_id will be presented. , shipping_query :: Maybe ShippingQuery -- ^ New incoming shipping query. Only for invoices with flexible price , pre_checkout_query :: Maybe PreCheckoutQuery -- ^ New incoming pre-checkout query. Contains full information about checkout + , purchased_paid_media :: Maybe PaidMediaPurchased -- ^ A user purchased paid media with a non-empty payload sent by the bot in a non-channel chat + , poll :: Maybe Poll -- ^ New poll state. Bots receive only updates about manually stopped polls and polls, which are sent by the bot + , poll_answer :: Maybe PollAnswer -- ^ A user changed their answer in a non-anonymous poll. Bots receive new votes only in polls that were sent by the bot itself. + , my_chat_member :: Maybe ChatMemberUpdated -- ^ The bot's chat member status was updated in a chat. For private chats, this update is received only when the bot is blocked or unblocked by the user. + , chat_member :: Maybe ChatMemberUpdated -- ^ A chat member's status was updated in a chat. The bot must be an administrator in the chat and must explicitly specify "chat_member" in the list of allowed_updates to receive these updates. + , chat_join_request :: Maybe ChatJoinRequest -- ^ A request to join the chat has been sent. The bot must have the can_invite_users administrator right in the chat to receive these updates. + , chat_boost :: Maybe ChatBoostUpdated -- ^ A chat boost was added or changed. The bot must be an administrator in the chat to receive these updates. + , removed_chat_boost :: Maybe ChatBoostRemoved -- ^ A boost was removed from a chat. The bot must be an administrator in the chat to receive these updates. } deriving (FromJSON, ToJSON, Show, Generic) -- | This object represents a point on the map. @@ -865,38 +948,97 @@ instance ToJSON ChatPhoto where instance FromJSON ChatPhoto where parseJSON = parseJsonDrop 11 +data True = STrue + deriving (Show) + +instance ToJSON True where + toJSON STrue = Bool True + +instance FromJSON True where + parseJSON = + withBool "True" \b -> if b then pure STrue else fail "Expected true" + +type MessageOrigin = Value +type ExternalReplyInfo = Value +type TextQuote = Value +type Story = Value +type LinkPreviewOptions = Value +type PaidMediaInfo = Value +type Dice = Value +type MessageAutoDeleteTimerChanged = Value +type RefundedPayment = Value +type UsersShared = Value +type ChatShared = Value +type WriteAccessAllowed = Value +type PassportData = Value +type ProximityAlertTriggered = Value +type ChatBoostAdded = Value +type ChatBackground = Value +type ForumTopicCreated = Value +type ForumTopicEdited = Value +type ForumTopicClosed = Value +type ForumTopicReopened = Value +type GeneralForumTopicHidden = Value +type GeneralForumTopicUnhidden = Value +type Giveaway = Value +type GiveawayCreated = Value +type GiveawayWinners = Value +type GiveawayCompleted = Value +type VideoChatScheduled = Value +type VideoChatStarted = Value +type VideoChatEnded = Value +type VideoChatParticipantsInvited = Value +type WebAppData = Value + -- | This object represents a message. data Message = Message { message_id :: Int -- ^ Unique message identifier + , message_thread_id :: Maybe Int -- ^ Unique identifier of a message thread to which the message belongs; for supergroups only , from :: Maybe User -- ^ Sender, can be empty for messages sent to channels + , sender_chat :: Maybe Chat -- ^ Sender of the message when sent on behalf of a chat. For example, the supergroup itself for messages sent by its anonymous administrators or a linked channel for messages automatically forwarded to the channel's discussion group. For backward compatibility, if the message was sent on behalf of a chat, the field from contains a fake sender user in non-channel chats. + , sender_boost_count :: Maybe Integer -- ^ If the sender of the message boosted the chat, the number of boosts added by the user + , sender_business_bot :: Maybe User -- ^ The bot that actually sent the message on behalf of the business account. Available only for outgoing messages sent on behalf of the connected business account. , date :: Int -- ^ Date the message was sent in Unix time + , business_connection_id :: Maybe Text -- ^ Unique identifier of the business connection from which the message was received. If non-empty, the message belongs to a chat of the corresponding business account that is independent from any potential bot chat which might share the same identifier. , chat :: Chat -- ^ Conversation the message belongs to - , forward_from :: Maybe User -- ^ For forwarded messages, sender of the original message - , forward_from_chat :: Maybe Chat -- ^ For messages forwarded from a channel, information about the original channel - , forward_from_message_id :: Maybe Int -- ^ For forwarded channel posts, identifier of the original message in the channel - , forward_signature :: Maybe Text -- ^ For messages forwarded from channels, signature of the post author if present - , forward_date :: Maybe Int -- ^ For forwarded messages, date the original message was sent in Unix time + , forward_origin :: Maybe MessageOrigin -- ^ Information about the original message for forwarded messages + , is_topic_message :: Maybe True -- ^ True, if the message is sent to a forum topic + , is_automatic_forward :: Maybe True -- ^ True, if the message is a channel post that was automatically forwarded to the connected discussion group , reply_to_message :: Maybe Message -- ^ For replies, the original message. Note that the 'Message' object in this field will not contain further 'reply_to_message' fields even if it itself is a reply. + , external_reply :: Maybe ExternalReplyInfo -- ^ Information about the message that is being replied to, which may come from another chat or forum topic + , quote :: Maybe TextQuote -- ^ For replies that quote part of the original message, the quoted part of the message + , reply_to_story :: Maybe Story -- ^ For replies to a story, the original story + , via_bot :: Maybe User -- ^ Bot through which the message was sent , edit_date :: Maybe Int -- ^ Date the message was last edited in Unix time + , has_protected_content :: Maybe True -- ^ True, if the message can't be forwarded + , is_from_offline :: Maybe True -- ^ True, if the message was sent by an implicit action, for example, as an away or a greeting business message, or as a scheduled message , media_group_id :: Maybe Text -- ^ The unique identifier of a media message group this message belongs to , author_signature :: Maybe Text -- ^ Signature of the post author for messages in channels , text :: Maybe Text -- ^ For text messages, the actual UTF-8 text of the message , entities :: Maybe [MessageEntity] -- ^ For text messages, special entities like usernames, URLs, bot commands, etc. that appear in the text - , caption_entities :: Maybe [MessageEntity] -- ^ or messages with a caption, special entities like usernames, URLs, bot commands, etc. that appear in the caption + , link_preview_options :: Maybe LinkPreviewOptions -- ^ Options used for link preview generation for the message, if it is a text message and link preview options were changed + , effect_id :: Maybe Text -- ^ Unique identifier of the message effect added to the message + , animation :: Maybe Animation -- ^ Message is an animation, information about the animation. For backward compatibility, when this field is set, the document field will also be set , audio :: Maybe Audio -- ^ Message is an audio file, information about the file , document :: Maybe Document -- ^ Message is a general file, information about the file - , game :: Maybe Game -- ^ Message is a game, information about the game + , paid_media :: Maybe PaidMediaInfo -- ^ Message contains paid media; information about the paid media , photo :: Maybe [PhotoSize] -- ^ Message is a photo, available sizes of the photo , sticker :: Maybe Sticker -- ^ Message is a sticker, information about the sticker + , story :: Maybe Story -- ^ Message is a forwarded story , video :: Maybe Video -- ^ Message is a video, information about the video - , voice :: Maybe Voice -- ^ Message is a voice message, information about the file , video_note :: Maybe VideoNote -- ^ Message is a video note, information about the video message + , voice :: Maybe Voice -- ^ Message is a voice message, information about the file , caption :: Maybe Text -- ^ Caption for the photo or video + , caption_entities :: Maybe [MessageEntity] -- ^ or messages with a caption, special entities like usernames, URLs, bot commands, etc. that appear in the caption + , show_caption_above_media :: Maybe True -- ^ True, if the caption must be shown above the message media + , has_media_spoiler :: Maybe True -- ^ True, if the message media is covered by a spoiler animation , contact :: Maybe Contact -- ^ Message is a shared contact, information about the contact - , location :: Maybe Location -- ^ Message is a shared location, information about the location + , dice :: Maybe Dice -- ^ Message is a dice with random value + , game :: Maybe Game -- ^ Message is a game, information about the game + , poll :: Maybe Poll -- ^ Message is a native poll, information about the poll , venue :: Maybe Venue -- ^ Message is a venue, information about the venue - , new_chat_member :: Maybe User -- ^ A new member was added to the group, information about them (this member may be the bot itself) + , location :: Maybe Location -- ^ Message is a shared location, information about the location , new_chat_members :: Maybe [User] -- ^ New members that were added to the group or supergroup and information about them (the bot itself may be one of these members) , left_chat_member :: Maybe User -- ^ A member was removed from the group, information about them (this member may be the bot itself) , new_chat_title :: Maybe Text -- ^ A chat title was changed to this value @@ -905,11 +1047,37 @@ data Message = Message , group_chat_created :: Maybe Bool -- ^ Service message: the group has been created , supergroup_chat_created :: Maybe Bool -- ^ Service message: the supergroup has been created , channel_chat_created :: Maybe Bool -- ^ Service message: the channel has been created + , message_auto_delete_timer_changed :: Maybe MessageAutoDeleteTimerChanged -- ^ Service message: auto-delete timer settings changed in the chat , migrate_to_chat_id :: Maybe Int64 -- ^ The group has been migrated to a supergroup with the specified identifier, not exceeding 1e13 by absolute value , migrate_from_chat_id :: Maybe Int64 -- ^ The supergroup has been migrated from a group with the specified identifier, not exceeding 1e13 by absolute value , pinned_message :: Maybe Message -- ^ Specified message was pinned. Note that the Message object in this field will not contain further reply_to_message fields even if it is itself a reply. , invoice :: Maybe Invoice -- ^ Message is an invoice for a payment, information about the invoice. , successful_payment :: Maybe SuccessfulPayment -- ^ Message is a service message about a successful payment, information about the payment. + , refunded_payment :: Maybe RefundedPayment -- ^ Message is a service message about a refunded payment, information about the payment. More about payments » + , users_shared :: Maybe UsersShared -- ^ Service message: users were shared with the bot + , chat_shared :: Maybe ChatShared -- ^ Service message: a chat was shared with the bot + , connected_website :: Maybe String -- ^ The domain name of the website on which the user has logged in. More about Telegram Login » + , write_access_allowed :: Maybe WriteAccessAllowed -- ^ Service message: the user allowed the bot to write messages after adding it to the attachment or side menu, launching a Web App from a link, or accepting an explicit request from a Web App sent by the method requestWriteAccess + , passport_data :: Maybe PassportData -- ^ Telegram Passport data + , proximity_alert_triggered :: Maybe ProximityAlertTriggered -- ^ Service message. A user in the chat triggered another user's proximity alert while sharing Live Location. + , boost_added :: Maybe ChatBoostAdded -- ^ Service message: user boosted the chat + , chat_background_set :: Maybe ChatBackground -- ^ Service message: chat background set + , forum_topic_created :: Maybe ForumTopicCreated -- ^ Service message: forum topic created + , forum_topic_edited :: Maybe ForumTopicEdited -- ^ Service message: forum topic edited + , forum_topic_closed :: Maybe ForumTopicClosed -- ^ Service message: forum topic closed + , forum_topic_reopened :: Maybe ForumTopicReopened -- ^ Service message: forum topic reopened + , general_forum_topic_hidden :: Maybe GeneralForumTopicHidden -- ^ Service message: the 'General' forum topic hidden + , general_forum_topic_unhidden :: Maybe GeneralForumTopicUnhidden -- ^ Service message: the 'General' forum topic unhidden + , giveaway_created :: Maybe GiveawayCreated -- ^ Service message: a scheduled giveaway was created + , giveaway :: Maybe Giveaway -- ^ The message is a scheduled giveaway message + , giveaway_winners :: Maybe GiveawayWinners -- ^ A giveaway with public winners was completed + , giveaway_completed :: Maybe GiveawayCompleted -- ^ Service message: a giveaway without public winners was completed + , video_chat_scheduled :: Maybe VideoChatScheduled -- ^ Service message: video chat scheduled + , video_chat_started :: Maybe VideoChatStarted -- ^ Service message: video chat started + , video_chat_ended :: Maybe VideoChatEnded -- ^ Service message: video chat ended + , video_chat_participants_invited :: Maybe VideoChatParticipantsInvited -- ^ Service message: new participants invited to a video chat + , web_app_data :: Maybe WebAppData -- ^ Service message: data sent by a Web App + , reply_markup :: Maybe InlineKeyboardMarkup -- ^ Inline keyboard attached to the message. login_url buttons are represented as ordinary url buttons. } deriving (FromJSON, ToJSON, Show, Generic) -- | This object represents one special entity in a text message. For example, hashtags, usernames, URLs, etc. @@ -1141,7 +1309,7 @@ instance FromJSON MaskPositionPoint where parseJSON "eyes" = pure Eyes parseJSON "mouth" = pure Mouth parseJSON "chin" = pure Chin - parseJSON _ = fail $ "Failed to parse MaskPositionPoint" + parseJSON _ = fail "Failed to parse MaskPositionPoint" data MaskPosition = MaskPosition { diff --git a/src/Web/Telegram/API/Bot/Requests.hs b/src/Web/Telegram/API/Bot/Requests.hs index 5531bc9..2e6ca4f 100644 --- a/src/Web/Telegram/API/Bot/Requests.hs +++ b/src/Web/Telegram/API/Bot/Requests.hs @@ -255,7 +255,7 @@ instance FromJSON ForwardMessageRequest where parseJSON = parseJsonDrop 8 forwardMessageRequest :: ChatId -> ChatId -> Int -> ForwardMessageRequest -forwardMessageRequest chatId fromChatId forwardMessageId = ForwardMessageRequest chatId fromChatId Nothing forwardMessageId +forwardMessageRequest chatId fromChatId = ForwardMessageRequest chatId fromChatId Nothing -- | This object represents request for 'sendPhoto' data SendPhotoRequest payload = SendPhotoRequest @@ -810,10 +810,10 @@ instance FromJSON EditMessageReplyMarkupRequest where parseJSON = parseJsonDrop 5 editMessageReplyMarkupRequest :: ChatId -> Int -> Maybe InlineKeyboardMarkup -> EditMessageReplyMarkupRequest -editMessageReplyMarkupRequest chatId messageId keyboard = EditMessageReplyMarkupRequest (Just chatId) (Just messageId) Nothing keyboard +editMessageReplyMarkupRequest chatId messageId = EditMessageReplyMarkupRequest (Just chatId) (Just messageId) Nothing editInlineMessageReplyMarkupRequest :: Text -> Maybe InlineKeyboardMarkup -> EditMessageReplyMarkupRequest -editInlineMessageReplyMarkupRequest inlineMessageId keyboard = EditMessageReplyMarkupRequest Nothing Nothing (Just inlineMessageId) keyboard +editInlineMessageReplyMarkupRequest inlineMessageId = EditMessageReplyMarkupRequest Nothing Nothing (Just inlineMessageId) data SendInvoiceRequest = SendInvoiceRequest { diff --git a/src/Web/Telegram/API/Bot/Responses.hs b/src/Web/Telegram/API/Bot/Responses.hs index 14efa27..309fee2 100644 --- a/src/Web/Telegram/API/Bot/Responses.hs +++ b/src/Web/Telegram/API/Bot/Responses.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -- | This module contains responses from Telegram Bot API module Web.Telegram.API.Bot.Responses diff --git a/stack.yaml b/stack.yaml index 60bc6d2..8b43abd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,34 +1,5 @@ -# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md +resolver: lts-22.0 -# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-14.0 - -# Local packages, usually specified by relative directory name -packages: -- '.' - -# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: -- hjson-1.3.2 - hjpath-3.0.1 - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 1.0.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] +- hjson-1.3.2 diff --git a/telegram-api.cabal b/telegram-api.cabal index 3b4228b..c4c1836 100644 --- a/telegram-api.cabal +++ b/telegram-api.cabal @@ -1,5 +1,5 @@ name: telegram-api -version: 0.7.1.0 +version: 0.7.2.0 synopsis: Telegram Bot API bindings description: High-level bindings to the Telegram Bot API homepage: http://github.com/klappvisor/haskell-telegram-api#readme @@ -48,10 +48,9 @@ library build-depends: base >= 4.7 && < 5 , aeson , containers - , http-api-data , http-client , servant - , servant-client == 0.16 + , servant-client >= 0.16 && < 0.21 , servant-client-core , mtl , text @@ -60,7 +59,6 @@ library , http-types , mime-types , bytestring - , string-conversions , binary default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-binds @@ -76,26 +74,25 @@ test-suite telegram-api-test , UpdatesSpec , StickersSpec , TestCore + , Paths_telegram_api build-depends: base , aeson , hjpath - , ansi-wl-pprint + , prettyprinter + , prettyprinter-ansi-terminal , http-client , http-client-tls , http-types , hspec , optparse-applicative - , servant , servant-client , servant-client-core , telegram-api , http-types , filepath , text - , transformers , utf8-string , random - , binary ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-name-shadowing default-language: Haskell2010 diff --git a/test/InlineSpec.hs b/test/InlineSpec.hs index f99f504..86bc3eb 100644 --- a/test/InlineSpec.hs +++ b/test/InlineSpec.hs @@ -2,14 +2,15 @@ module InlineSpec (spec) where -import Data.Text (Text) +import Prelude hiding (id) + import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Test.Hspec import Web.Telegram.API.Bot -spec :: Token -> Text -> Spec -spec token chatId = do +spec :: Token -> Spec +spec token = do let inline_query_id = "" manager <- runIO $ newManager tlsManagerSettings -- Create the tls connection manager @@ -42,12 +43,22 @@ spec token chatId = do Update { inline_query = Just (InlineQuery { query_id = id } ) } <- pure (last updates) e <- answerInlineQuery token (answerInlineQueryRequest id [inline_video]) manager - putStrLn (show e) + print e +message_content :: InputMessageContent message_content = InputTextMessageContent "test message content" Nothing Nothing +inline_article :: InlineQueryResult inline_article = InlineQueryResultArticle "2131341" (Just "text article content") (Just message_content) Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +inline_photo :: InlineQueryResult inline_photo = InlineQueryResultPhoto "1430810" "http://vignette3.wikia.nocookie.net/victorious/images/f/f8/NyanCat.jpg" (Just "http://vignette3.wikia.nocookie.net/victorious/images/f/f8/NyanCat.jpg") Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +inline_gif :: InlineQueryResult inline_gif = InlineQueryResultGif "131231234" "https://media.giphy.com/media/zEO5eq3ZsEwbS/giphy.gif" Nothing Nothing (Just "https://media.giphy.com/media/zEO5eq3ZsEwbS/100.gif") Nothing Nothing Nothing Nothing Nothing + +inline_mpeg :: InlineQueryResult inline_mpeg = InlineQueryResultMpeg4Gif "131251234" "https://media.giphy.com/media/zEO5eq3ZsEwbS/giphy.gif" Nothing Nothing (Just "https://media.giphy.com/media/zEO5eq3ZsEwbS/100.gif") Nothing Nothing Nothing Nothing Nothing + +inline_video :: InlineQueryResult inline_video = InlineQueryResultVideo "123413542" "https://www.youtube.com/embed/TBKN7_vx2xo" "text/html" (Just "https://i.ytimg.com/vi_webp/TBKN7_vx2xo/mqdefault.webp") (Just "Enjoykin — Nyash Myash") Nothing Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/test/MainSpec.hs b/test/MainSpec.hs index ba82ecf..ac24bd9 100644 --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} module MainSpec (spec) where +import Prelude hiding (id) + import Control.Concurrent import Control.Monad import Data.Text (Text) @@ -12,7 +14,7 @@ import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status import Paths_telegram_api -import Servant.Client hiding (Response) +import Servant.Client (ClientError (FailureResponse)) import qualified Servant.Client.Core as Core import System.FilePath import Test.Hspec @@ -20,7 +22,7 @@ import TestCore import Web.Telegram.API.Bot spec :: Token -> ChatId -> Text -> Spec -spec token chatId botName = do +spec token chatId@(ChatId userId) botName = do manager <- runIO $ newManager tlsManagerSettings dataDir <- runIO getDataDir let testFile name = dataDir "test-data" name @@ -32,205 +34,201 @@ spec token chatId botName = do describe "/sendMessage" $ do it "should send message" $ do - res <- sendMessage token (sendMessageRequest chatId "test message") manager + res@(Right Response { result = m }) <- + sendMessage token (sendMessageRequest chatId "test message") manager success res - let Right Response { result = m } = res text m `shouldBe` Just "test message" it "should return error message" $ do - res <- sendMessage token (sendMessageRequest (ChatChannel "") "test message") manager + res@(Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } })) <- + sendMessage token (sendMessageRequest (ChatChannel "") "test message") manager nosuccess res - let Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } }) = res msg `shouldBe` "Bad Request" it "should send message markdown" $ do let request = (sendMessageRequest chatId "text *bold* _italic_ [github](github.com/klappvisor/telegram-api)") { message_parse_mode = Just Markdown } - res <- sendMessage token request manager + res@(Right Response { result = m }) <- sendMessage token request manager success res - let Right Response { result = m } = res text m `shouldBe` Just "text bold italic github" it "should set keyboard" $ do let kbA = keyboardButton "A" kbB = keyboardButton "B" kbC = keyboardButton "C" - let message = (sendMessageRequest chatId "set keyboard") { + let msg = (sendMessageRequest chatId "set keyboard") { message_reply_markup = Just $ replyKeyboardMarkup [[kbA, kbB, kbC]] } - res <- sendMessage token message manager + res@(Right Response { result = m }) <- sendMessage token msg manager success res - let Right Response { result = m } = res text m `shouldBe` Just "set keyboard" it "should remove keyboard" $ do - let message = (sendMessageRequest chatId "remove keyboard") { + let msg = (sendMessageRequest chatId "remove keyboard") { message_reply_markup = Just replyKeyboardHide } - res <- sendMessage token message manager + res@(Right Response { result = m }) <- sendMessage token msg manager success res - let Right Response { result = m } = res text m `shouldBe` Just "remove keyboard" it "should send message with inline keyboard" $ do let kbA = (inlineKeyboardButton "A") { ikb_callback_data = Just "A" } kbB = (inlineKeyboardButton "B") { ikb_callback_data = Just "B" } kbC = (inlineKeyboardButton "C") { ikb_callback_data = Just "C" } - let message = (sendMessageRequest chatId "set inline keyboard") { + let msg = (sendMessageRequest chatId "set inline keyboard") { message_reply_markup = Just $ inlineKeyboardMarkup [[kbA, kbB, kbC]] } - res <- sendMessage token message manager + res@(Right Response { result = m }) <- sendMessage token msg manager success res - let Right Response { result = m } = res text m `shouldBe` Just "set inline keyboard" it "should force reply" $ do - let message = (sendMessageRequest chatId "force reply") { + let msg = (sendMessageRequest chatId "force reply") { message_reply_markup = Just forceReply } - res <- sendMessage token message manager + res@(Right Response { result = m }) <- sendMessage token msg manager success res - let Right Response { result = m } = res text m `shouldBe` Just "force reply" describe "/forwardMessage" $ it "should forward message" $ do - res <- forwardMessage token (forwardMessageRequest chatId chatId 123000) manager + res@(Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } })) <- + forwardMessage token (forwardMessageRequest chatId chatId 123000) manager nosuccess res - let Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } }) = res msg `shouldBe` "Bad Request" describe "/sendPhoto" $ do it "should return error message" $ do - let photo = (sendPhotoRequest (ChatChannel "") "photo_id") { + let photoReq = (sendPhotoRequest (ChatChannel "") "photo_id") { photo_caption = Just "photo caption" } - Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- sendPhoto token photo manager + Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- sendPhoto token photoReq manager msg `shouldBe` "Bad Request" it "should upload photo and resend it by id" $ do let fileUpload = localFileUpload $ testFile "christmas-cat.jpg" let upload = (uploadPhotoRequest chatId fileUpload) { photo_caption = Just "uploaded photo" } - Right Response { result = Message { caption = Just cpt, photo = Just photos } } <- + Right Response { result = Message { caption = Just cpt, photo = Just photos' } } <- uploadPhoto token upload manager cpt `shouldBe` "uploaded photo" -- resend by id - let id = (photo_file_id . last) photos - let photo = (sendPhotoRequest chatId id) { + let id = (photo_file_id . last) photos' + let photoReq = (sendPhotoRequest chatId id) { photo_caption = Just "photo caption" } - Right Response { result = Message { caption = Just cpt } } <- - sendPhoto token photo manager - cpt `shouldBe` "photo caption" + Right Response { result = Message { caption = Just capt } } <- + sendPhoto token photoReq manager + capt `shouldBe` "photo caption" describe "/sendAudio" $ do it "should return error message" $ do - let audio = (sendAudioRequest (ChatChannel "") "audio_id") { + let audioReq = (sendAudioRequest (ChatChannel "") "audio_id") { _audio_performer = Just "performer" , _audio_title = Just "title" } Left (FailureResponse _ Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- - sendAudio token audio manager + sendAudio token audioReq manager msg `shouldBe` "Bad Request" it "should upload audio and resend it by id" $ do let fileUpload = localFileUpload $ testFile "concerto-for-2-trumpets-in-c-major.mp3" audioTitle = "Concerto for 2 Trumpets in C major, RV. 537 (Rondeau arr.) All." audioPerformer = "Michel Rondeau" - audio = (uploadAudioRequest chatId fileUpload) { + audio1 = (uploadAudioRequest chatId fileUpload) { _audio_performer = Just audioPerformer, _audio_title = Just audioTitle } - res <- uploadAudio token audio manager - let Right Response { + res@(Right Response { result = Message { audio = Just Audio { - audio_file_id = file_id, audio_title = Just title, audio_performer = Just performer + audio_file_id = fileId, audio_title = Just title, audio_performer = Just performer } } - } = res + }) <- + uploadAudio token audio1 manager + success res title `shouldBe` audioTitle performer `shouldBe` audioPerformer - let audio = sendAudioRequest chatId file_id + let audio2 = sendAudioRequest chatId fileId Right Response { result = Message { audio = Just Audio { audio_title = Just title' } } } <- - sendAudio token audio manager + sendAudio token audio2 manager title' `shouldBe` audioTitle describe "/sendSticker" $ do it "should send sticker" $ do - let sticker = sendStickerRequest chatId "BQADAgADGgADkWgMAAGXlYGBiM_d2wI" - Right Response { result = Message { sticker = Just sticker } } <- - sendSticker token sticker manager - sticker_file_id sticker `shouldBe` "CAADAgADGgADkWgMAAFNFIZh3zoKbRYE" --"BQADAgADGgADkWgMAAGXlYGBiM_d2wI" + let stickerReq = sendStickerRequest chatId "BQADAgADGgADkWgMAAGXlYGBiM_d2wI" + Right Response { result = Message { sticker = Just stickerFileId } } <- + sendSticker token stickerReq manager + sticker_file_id stickerFileId `shouldBe` "CAADAgADGgADkWgMAAFNFIZh3zoKbRYE" --"BQADAgADGgADkWgMAAGXlYGBiM_d2wI" it "should upload sticker" $ do let fileUpload = localFileUpload $ testFile "haskell-logo.webp" stickerReq = uploadStickerRequest chatId fileUpload - res <- uploadSticker token stickerReq manager + res@(Right Response { result = Message { sticker = Just stickerFile } }) <- + uploadSticker token stickerReq manager success res - let Right Response { result = Message { sticker = Just sticker } } = res - sticker_height sticker `shouldBe` 128 + sticker_height stickerFile `shouldBe` 128 describe "/sendVoice" $ it "should upload voice" $ do -- audio source: https://commons.wikimedia.org/wiki/File:Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg let fileUpload = localFileUpload $ testFile "Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg" voiceReq = (uploadVoiceRequest chatId fileUpload) { _voice_duration = Just 10 } - res <- uploadVoice token voiceReq manager + res@(Right Response { result = Message { voice = Just voiceFile } }) <- + uploadVoice token voiceReq manager success res - let Right Response { result = Message { voice = Just voice } } = res - voice_duration voice `shouldBe` 10 + voice_duration voiceFile `shouldBe` 10 describe "/sendVideoNote" $ it "should upload video note" $ do let fileUpload = localFileUpload $ testFile "lego-square.mp4" videoNoteReq = (uploadVideoNoteRequest chatId fileUpload) { _vid_note_length = Just 320 } - res <- uploadVideoNote token videoNoteReq manager + res@(Right Response { result = Message { video_note = Just videoFile } }) <- + uploadVideoNote token videoNoteReq manager success res - let Right Response { result = Message { video_note = Just video } } = res - vid_note_duration video `shouldBe` 6 + vid_note_duration videoFile `shouldBe` 6 describe "/sendVideo" $ it "should upload video" $ do -- video source: http://techslides.com/sample-webm-ogg-and-mp4-video-files-for-html5 let fileUpload = localFileUpload $ testFile "lego-video.mp4" videoReq = uploadVideoRequest chatId fileUpload - res <- uploadVideo token videoReq manager + res@(Right Response { result = Message { video = Just videoFile } }) <- + uploadVideo token videoReq manager success res - let Right Response { result = Message { video = Just video } } = res - video_width video `shouldBe` 560 + video_width videoFile `shouldBe` 560 describe "/sendDocument" $ it "should upload document" $ do let fileUpload = localFileUpload $ testFile "wikipedia-telegram.txt" documentReq = uploadDocumentRequest chatId fileUpload - Right Response { result = Message { document = Just document } } <- + Right Response { result = Message { document = Just file } } <- uploadDocument token documentReq manager - doc_mime_type document `shouldBe` Just "text/plain" - doc_file_name document `shouldBe` Just "wikipedia-telegram.txt" + doc_mime_type file `shouldBe` Just "text/plain" + doc_file_name file `shouldBe` Just "wikipedia-telegram.txt" describe "/sendLocation" $ it "should send location" $ do - let location = sendLocationRequest chatId 52.38 4.9 + let locationReq = sendLocationRequest chatId 52.38 4.9 Right Response { result = Message { location = Just loc } } <- - sendLocation token location manager + sendLocation token locationReq manager latitude loc `shouldSatisfy` liftM2 (&&) (> 52) (< 52.4) longitude loc `shouldSatisfy` liftM2 (&&) (> 4.89) (< 5) describe "/sendVenue" $ it "should send a venue" $ do - let venue = sendVenueRequest chatId 52.38 4.9 "Amsterdam Centraal" "Amsterdam" + let venueReq = sendVenueRequest chatId 52.38 4.9 "Amsterdam Centraal" "Amsterdam" Right Response { result = Message { location = Just loc } } <- - sendVenue token venue manager + sendVenue token venueReq manager latitude loc `shouldSatisfy` liftM2 (&&) (> 52) (< 52.4) longitude loc `shouldSatisfy` liftM2 (&&) (> 4.89) (< 5) describe "/sendContact" $ it "should send a contact" $ do - let contact = sendContactRequest chatId "06-18035176" "Hilbert" + let contactReq = sendContactRequest chatId "06-18035176" "Hilbert" Right Response { result = Message { contact = Just con } } <- - sendContact token contact manager + sendContact token contactReq manager -- Telegram seems to remove any non numeric characters from the sent phone number (at least it removed my '-') contact_phone_number con `shouldBe` "0618035176" contact_first_name con `shouldBe` "Hilbert" @@ -268,19 +266,18 @@ spec token chatId botName = do msg `shouldBe` "Bad Request" describe "/getUserProfilePhotos" $ - it "should get user profile photos" $ do - Right Response { result = photos } <- do - let ChatId userId = chatId - getUserProfilePhotos token (fromIntegral userId) Nothing Nothing manager - total_count photos `shouldSatisfy` (>= 0) + it "should get user profile photos" $ do + Right Response { result = profilePhotos } <- + getUserProfilePhotos token (fromIntegral userId) Nothing Nothing manager + total_count profilePhotos `shouldSatisfy` (>= 0) describe "/setWebhook and /getWebhookInfo" $ do it "should set webhook with certificate" $ do let cert = localFileUpload $ testFile "cert.pem" req = setWebhookRequest "https://example.com/secret_token" cert - res <- setWebhookWithCertificate token req manager + res@(Right Response { result = val }) <- + setWebhookWithCertificate token req manager success res - let Right Response { result = val } = res val `shouldBe` True it "should set webhook" $ do @@ -301,9 +298,8 @@ spec token chatId botName = do it "should remove webhood with deleteWebhook" $ do threadDelay $ 2 * 1000 * 1000 _ <- setWebhook token (Just "https://example.com/secret_token") manager - res <- deleteWebhook token manager + res@(Right Response { result = val }) <- deleteWebhook token manager success res - let Right Response { result = val } = res val `shouldBe` True describe "/editTextMessage" $ do @@ -337,9 +333,11 @@ spec token chatId botName = do input_media_caption = Just "Lenses" } request = sendMediaGroupRequest chatId [ photo1, photo2 ] - res <- runTelegramClient token manager $ sendMediaGroupM request + res@(Right Response { result = messages }) <- + runTelegramClient token manager $ sendMediaGroupM request success res - let Right Response { result = messages } = res length messages `shouldBe` 2 -- it "should edit caption" $ do ... after inline query tests are on place + +spec _ (ChatChannel _) _ = error "not implemented" diff --git a/test/PaymentsSpec.hs b/test/PaymentsSpec.hs index b63bb81..e4d74c8 100644 --- a/test/PaymentsSpec.hs +++ b/test/PaymentsSpec.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} module PaymentsSpec (spec) where @@ -12,10 +10,9 @@ import Test.Hspec import TestCore import Web.Telegram.API.Bot -spec :: Token -> ChatId -> Text -> Text -> Spec -spec token chatId' _ paymentToken = do +spec :: Token -> ChatId -> Text -> Spec +spec token (ChatId chatId) paymentToken = do manager <- runIO $ newManager tlsManagerSettings - let ChatId chatId = chatId' describe "/sendInvoice" $ do it "should send invoice" $ do let description = "The best portal cannon in known universe" @@ -29,8 +26,9 @@ spec token chatId' _ paymentToken = do { snd_inv_photo_url = Just "http://farm4.staticflickr.com/3560/3576111171_66c1fc2462_z.jpg" , snd_inv_is_flexible = Just True } - res <- runClient (sendInvoiceM invoiceRequest) token manager + res@(Right Response { result = m }) <- + runClient (sendInvoiceM invoiceRequest) token manager success res - let Right Response { result = m } = res - inv_title <$> (invoice m) `shouldBe` Just "Portal cannon" + inv_title <$> invoice m `shouldBe` Just "Portal cannon" +spec _ (ChatChannel _) _ = error "not implemented" diff --git a/test/Spec.hs b/test/Spec.hs index 172db43..410c508 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,12 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Main (main) where -import Data.Char (isDigit) import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import qualified JsonSpec @@ -16,7 +14,8 @@ import qualified PaymentsSpec import qualified StickersSpec import System.Environment (lookupEnv, withArgs) import Test.Hspec -import qualified Text.PrettyPrint.ANSI.Leijen as PP +import qualified Prettyprinter as PP +import qualified Prettyprinter.Render.Terminal as PP import Text.Read (readMaybe) import qualified UpdatesSpec import Web.Telegram.API.Bot @@ -76,18 +75,25 @@ runSpec' integration token chatId botName paymentToken = do runIntegrationSpec :: Maybe Token -> Maybe ChatId -> Maybe Text -> Maybe Text -> SpecWith () runIntegrationSpec (Just token) (Just chatId) (Just botName) (Just paymentToken) = do describe "Main integration tests" $ MainSpec.spec token chatId botName - describe "Payments integration tests" $ PaymentsSpec.spec token chatId botName paymentToken + describe "Payments integration tests" $ PaymentsSpec.spec token chatId paymentToken describe "Updates API spec" $ UpdatesSpec.spec token botName - describe "Stickers API spec" $ StickersSpec.spec token chatId botName + describe "Stickers API spec" $ StickersSpec.spec token chatId --describe "Inline integration tests" $ InlineSpec.spec token chatId botName runIntegrationSpec _ _ _ _ = describe "Integration tests" $ - fail "Missing required arguments for integration tests. Run stack test --test-arguments \"--help\" for more info" + error "Missing required arguments for integration tests. Run stack test --test-arguments \"--help\" for more info" -description :: Maybe PP.Doc -description = Just $ - (PP.text "Run the haskell-telegram-api tests") - PP.<$> ((PP.text "Running with stack: ") PP.<> (PP.text "stack test --test-arguments=\"--integration -c 1235122 -b MyTeleBot -- -m send\"")) - PP.<$> ((PP.red . PP.text $ "WARNING: ") PP.<> (PP.text "the HSPEC_ARGS are optional but if present MUST be at the end and seperated from the other options with a -- ")) +description :: Maybe (PP.Doc PP.AnsiStyle) +description = + Just $ + mconcat + [ "Run the haskell-telegram-api tests" + , PP.line + , "Running with stack: " + , "stack test --test-arguments=\"--integration -c 1235122 -b MyTeleBot -- -m send\"" + , PP.line + , PP.annotate (PP.color PP.Red) "WARNING: " + , "the HSPEC_ARGS are optional but if present MUST be at the end and seperated from the other options with a -- " + ] readChatId :: String -> ChatId readChatId s@('@':_) = ChatChannel $ T.pack s diff --git a/test/StickersSpec.hs b/test/StickersSpec.hs index e148959..c43250d 100644 --- a/test/StickersSpec.hs +++ b/test/StickersSpec.hs @@ -1,14 +1,10 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} module StickersSpec (spec) where import Data.Maybe -import Data.Monoid -import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -19,16 +15,19 @@ import Test.Hspec import TestCore import Web.Telegram.API.Bot -spec :: Token -> ChatId -> Text -> Spec -spec token chatId _ = do +spec :: Token -> ChatId -> Spec +spec token chatId@(ChatId chatId') = do manager <- runIO $ newManager tlsManagerSettings dataDir <- runIO getDataDir - res <- runIO $ runTelegramClient token manager getMeM + meRes <- + runIO $ do + Right Response { result = meRes } <- + runTelegramClient token manager getMeM + pure meRes + let testFile name = dataDir "test-data" name - Right Response { result = meRes } = res botUsername = fromMaybe "???" $ user_username meRes - ChatId chatId' = chatId userId :: Int = fromIntegral chatId' stickerFile1 = localFileUpload $ testFile "sticker_1.png" stickerFile2 = localFileUpload $ testFile "sticker_2.png" @@ -36,25 +35,25 @@ spec token chatId _ = do describe "/getStickerSet" $ do it "should get sticker set" $ do let stickerName = "non_existing_test_set_by_" <> botUsername - res <- runTelegramClient token manager $ getStickerSetM stickerName - nosuccess res + res' <- runTelegramClient token manager $ getStickerSetM stickerName + nosuccess res' describe "/uploadStickerFile" $ do it "should upload sticker PNG" $ do let uploadRequest = UploadStickerFileRequest userId stickerFile1 - Right res <- runTelegramClient token manager $ uploadStickerFileM uploadRequest - (T.null . file_id . result) res `shouldBe` False + Right res' <- runTelegramClient token manager $ uploadStickerFileM uploadRequest + (T.null . file_id . result) res' `shouldBe` False describe "/createNewStickerSet" $ do it "should create sticker set" $ do rnd :: Integer <- randomRIO (10000, 99999) - let stickerSetName = "set_" <> (showText rnd) <> "_by_" <> botUsername + let stickerSetName = "set_" <> showText rnd <> "_by_" <> botUsername request = CreateNewStickerSetRequest userId stickerSetName "Haskell Bot API Test Set" stickerFile1 "😃" (Just True) Nothing - res <- runTelegramClient token manager $ do - _ <- createNewStickerSetM' request - getStickerSetM stickerSetName - success res - let Right Response { result = set } = res + res'@(Right Response { result = set }) <- + runTelegramClient token manager $ do + _ <- createNewStickerSetM' request + getStickerSetM stickerSetName + success res' stcr_set_name set `shouldBe` stickerSetName describe "StickerSet CRUD" $ do @@ -83,5 +82,4 @@ spec token chatId _ = do stickerCount set `shouldBe` 2 stickerCount setAfter `shouldBe` 1 - - +spec _ (ChatChannel _) = error "not implemented" diff --git a/test/TestCore.hs b/test/TestCore.hs index 1407134..eaa3a0a 100644 --- a/test/TestCore.hs +++ b/test/TestCore.hs @@ -1,7 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} module TestCore (success, nosuccess, showText) where diff --git a/test/UpdatesSpec.hs b/test/UpdatesSpec.hs index 8e3e07c..24bce83 100644 --- a/test/UpdatesSpec.hs +++ b/test/UpdatesSpec.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} module UpdatesSpec (spec) where @@ -12,6 +11,7 @@ import qualified Data.Text as T import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Test.Hspec +import TestCore import Web.Telegram.API.Bot spec :: Token -> Text -> Spec @@ -19,45 +19,53 @@ spec token botName = do manager <- runIO $ newManager tlsManagerSettings describe "/getMe and /getWebhookInfo work together" $ it "responds with correct bot's name and empty webhook" $ do - res <- runTelegramClient token manager $ do + res@(Right (Response {result = me}, Response {result = whi})) <- + runTelegramClient token manager $ do b <- getMeM info <- getWebhookInfoM return (b, info) - let Right (Response {result = me}, Response {result = whi}) = res + success res user_first_name me `shouldBe` botName whi_url whi `shouldBe` "" describe "webhook operations" $ do let url = "https://example.com/bot" it "able to get and set webhook" $ do - res <- runTelegramClient token manager $ do - info <- getWebhookInfoM - liftIO $ (whi_url . result) info `shouldBe` "" + res@(Right Response { result = whi }) <- + runTelegramClient token manager $ do + info1 <- getWebhookInfoM + liftIO $ (whi_url . result) info1 `shouldBe` "" liftIO $ threadDelay $ 2 * 1000 * 1000 -- to avoid Too many request error set <- setWebhookM $ setWebhookRequest' url liftIO $ result set `shouldBe` True - info <- getWebhookInfoM - liftIO $ (whi_url . result) info `shouldBe` url + info2 <- getWebhookInfoM + liftIO $ (whi_url . result) info2 `shouldBe` url liftIO $ threadDelay $ 2 * 1000 * 1000 -- to avoid Too many request error del <- deleteWebhookM liftIO $ result del `shouldBe` True getWebhookInfoM - let Right Response { result = whi } = res + success res whi_url whi `shouldBe` "" it "should set allowed updates" $ do let allowedUpdates = map T.pack ["message", "callback_query"] - res <- runTelegramClient token manager $ do - let request = (setWebhookRequest' url) { - webhook_allowed_updates = Just allowedUpdates - } + res@(Right Response { result = whi }) <- + runTelegramClient token manager $ do + let request = + case setWebhookRequest' url of + SetWebhookWithoutCertRequest {..} -> + SetWebhookWithoutCertRequest { + webhook_allowed_updates = Just allowedUpdates, .. + } + r -> r set <- setWebhookM request liftIO $ result set `shouldBe` True getWebhookInfoM - let Right Response { result = whi } = res + success res whi_allowed_updates whi `shouldBe` Just allowedUpdates it "should set max connections" $ do - res <- runTelegramClient token manager $ do + res@(Right Response { result = whi }) <- + runTelegramClient token manager $ do let request = (setWebhookRequest' url) { webhook_max_connections = Just 5 } @@ -65,7 +73,7 @@ spec token botName = do set <- setWebhookM request liftIO $ result set `shouldBe` True getWebhookInfoM - let Right Response { result = whi } = res + success res whi_max_connections whi `shouldBe` Just 5