diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## 0.7.1.0 + +* Added support up to Bot API v3.5: sticker sets, chats administration, live location, etc +* Added `runTelegramClient` with different than in `runClient` order of arguments. Now possible to write `runTelegramClient token manager $ do` +* Stop adding request specific responses +* Stop adding IO calls, use functions with `M` suffix, for example `runClient getWebhookInfoM` + +## 0.7.0.0 + +* Upgraded to servant-0.11 + ## 0.6.3.0 * New fields *gif_duration* in `InlineQueryResultGif` and *mpeg4_duration* in `InlineQueryResultMpeg4Gif`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,7 +13,7 @@ Inline mode is supported. Uploading stickers, documents, video, etc is not supported yet, but you can send items which are already uploaded on the Telegram servers. -**Support of [Bot-3.0 API][bot-3.0]** +**Support of [Bot-3.5 API][bot-api]** ## Usage @@ -32,16 +32,17 @@ main = do let token = Token "bot" -- entire Token should be bot123456:ABC-DEF1234ghIkl-zyx57W2v1u123ew11 manager <- newManager tlsManagerSettings - result <- runClient ( do + result <- runTelegramClient token manager $ do info <- getWebhookInfoM let request = setWebhookRequest' "https://example.com/hook" isSet <- setWebhookM request - getMeM) token manager + getMeM print result print "done!" ``` -### Runing IO directly +### Running IO directly (planning to depricate this option) +:warning: This method to interact with a Telegram bot is about to be depricated and all new API calls will only have their `M` versions. You can run them using `runTelegramClient` function, for example `runTelegramClient token manager $ sendMessageM message` or in example below replace `getMe token manager` with `runTelegramClient token manager getMeM` to get the same behavior. `getMe` example @@ -89,7 +90,7 @@ print $ message_id m print $ text m where token = Token "bot" -- entire Token should be bot123456:ABC-DEF1234ghIkl-zyx57W2v1u123ew11 - chatId = " or <@channelusername>" + chatId = ChatId -- use ChatId 10231 or ChatChannel "<@channelusername>" message = "text *bold* _italic_ [github](github.com/klappvisor/haskell-telegram-api)" ``` @@ -100,16 +101,16 @@ With data type constructor: ```haskell -let request = SendMessageRequest "chatId" "text" Nothing (Just True) Nothing Nothing Nothing +let request = SendMessageRequest (ChatId int64_chatId) "text" Nothing (Just True) Nothing Nothing Nothing ``` Using default instance: ```haskell -let request = sendMessageRequest "chatId" "text" -- only with required fields +let request = sendMessageRequest (ChatId int64_chatId) "text" -- only with required fields ``` ```haskell -let request = (sendMessageRequest "chatId" "text") { +let request = (sendMessageRequest ChatId int64_chatId) "text") { message_disable_notification = Just True -- with optional fields } ``` @@ -164,4 +165,4 @@ [telegram-bot-api]: https://core.telegram.org/bots/api [servant]: https://haskell-servant.github.io/ [hspec-args]: https://hspec.github.io/running-specs.html -[bot-3.0]: https://core.telegram.org/bots/api +[bot-api]: https://core.telegram.org/bots/api diff --git a/src/Servant/Client/MultipartFormData.hs b/src/Servant/Client/MultipartFormData.hs --- a/src/Servant/Client/MultipartFormData.hs +++ b/src/Servant/Client/MultipartFormData.hs @@ -1,38 +1,46 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Servant.Client.MultipartFormData ( ToMultipartFormData (..) , MultipartFormDataReqBody ) where -import Control.Exception +--import Control.Exception import Control.Monad -import Control.Monad.Reader.Class -import Control.Monad.IO.Class import Control.Monad.Error.Class -import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) +import Control.Monad.IO.Class +import Control.Monad.Reader.Class +import Data.ByteString.Lazy hiding (any, elem, + filter, map, null, pack) import Data.Proxy -import Data.String.Conversions -import Data.Typeable (Typeable) -import Network.HTTP.Client hiding (Proxy, path) -import qualified Network.HTTP.Client as Client +--import Data.Foldable (toList) +import qualified Data.List.NonEmpty as NonEmpty +--import Data.String.Conversions +import qualified Data.Sequence as Sequence +import Data.Text (pack) +import Data.Typeable (Typeable) +import Network.HTTP.Client hiding (Proxy, path) +import qualified Network.HTTP.Client as Client import Network.HTTP.Client.MultipartFormData import Network.HTTP.Media import Network.HTTP.Types -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types as H +import qualified Network.HTTP.Types.Header as HTTP import Servant.API -import Servant.Common.BaseUrl import Servant.Client -import Servant.Common.Req (Req, catchConnectionError, - reqAccept, reqToRequest) +import qualified Servant.Client.Core as Core +import Servant.Client.Internal.HttpClient (catchConnectionError, + clientResponseToReponse, + requestToClientRequest) + -- | A type that can be converted to a multipart/form-data value. class ToMultipartFormData a where -- | Convert a Haskell value to a multipart/form-data-friendly intermediate type. @@ -42,60 +50,60 @@ data MultipartFormDataReqBody a deriving (Typeable) -instance (ToMultipartFormData b, MimeUnrender ct a, cts' ~ (ct ': cts) - ) => HasClient (MultipartFormDataReqBody b :> Post cts' a) where - type Client (MultipartFormDataReqBody b :> Post cts' a) - = b -> ClientM a - clientWithRoute Proxy req reqData = - let reqToRequest' req' baseurl' = do - requestWithoutBody <- reqToRequest req' baseurl' +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 = + let requestToClientRequest' req' baseurl' = do + let requestWithoutBody = requestToClientRequest baseurl' req' formDataBody (toMultipartFormData reqData) requestWithoutBody - in snd <$> performRequestCT' reqToRequest' (Proxy :: Proxy ct) H.methodPost req + in snd <$> performRequestCT' requestToClientRequest' (Proxy :: Proxy ct) H.methodPost req --- copied `performRequest` from servant-0.7.1, then modified so it takes a variant of `reqToRequest` +-- copied `performRequest` from servant-0.11, then modified so it takes a variant of `requestToClientRequest` -- as an argument. -performRequest' :: (Req -> BaseUrl -> IO Request) - -> Method -> Req -> Manager -> BaseUrl +performRequest' :: (Core.Request -> BaseUrl -> IO Request) + -> Method -> Core.Request -> ClientM ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest' reqToRequest' reqMethod req manager reqHost = do - partialRequest <- liftIO $ reqToRequest' req reqHost + , [HTTP.Header], Client.Response ByteString) +performRequest' requestToClientRequest' reqMethod req = do + m <- asks manager + reqHost <- asks baseUrl + partialRequest <- liftIO $ requestToClientRequest' req reqHost - let request = partialRequest { Client.method = reqMethod - , checkResponse = \ _request _response -> return () - } + let request = partialRequest { Client.method = reqMethod } - eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager + eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m case eResponse of Left err -> - throwError . ConnectionError $ SomeException err + throwError . ConnectionError $ pack $ show err Right response -> do let status = Client.responseStatus response body = Client.responseBody response hdrs = Client.responseHeaders response status_code = statusCode status + coreResponse = clientResponseToReponse response ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" Just t -> case parseAccept t of - Nothing -> throwError $ InvalidContentTypeHeader (cs t) body + Nothing -> throwError $ InvalidContentTypeHeader coreResponse Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ - throwError $ FailureResponse status ct body + throwError $ FailureResponse coreResponse return (status_code, body, ct, hdrs, response) --- copied `performRequestCT` from servant-0.7.1, then modified so it takes a variant of `reqToRequest` +-- copied `performRequestCT` from servant-0.11, then modified so it takes a variant of `requestToClientRequest` -- as an argument. performRequestCT' :: MimeUnrender ct result => - (Req -> BaseUrl -> IO Request) -> - Proxy ct -> Method -> Req + (Core.Request -> BaseUrl -> IO Request) + -> Proxy ct -> Method -> Core.Request -> ClientM ([HTTP.Header], result) -performRequestCT' reqToRequest' ct reqMethod req = do - let acceptCT = contentType ct - ClientEnv manager reqHost <- ask +performRequestCT' requestToClientRequest' ct reqMethod req = do + let acceptCTS = contentTypes ct (_status, respBody, respCT, hdrs, _response) <- - performRequest' reqToRequest' reqMethod (req { reqAccept = [acceptCT] }) manager reqHost - unless (matches respCT acceptCT) $ throwError $ UnsupportedContentType respCT respBody + performRequest' requestToClientRequest' reqMethod (req { Core.requestAccept = Sequence.fromList $ NonEmpty.toList acceptCTS }) + let coreResponse = clientResponseToReponse _response + unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT coreResponse case mimeUnrender ct respBody of - Left err -> throwError $ DecodeFailure err respCT respBody + 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 --- a/src/Web/Telegram/API/Bot/API.hs +++ b/src/Web/Telegram/API/Bot/API.hs @@ -7,6 +7,7 @@ module API , runClient , runClient' + , runTelegramClient -- * API , TelegramBotAPI , api @@ -22,9 +23,10 @@ import Web.Telegram.API.Bot.API.Edit as API import Web.Telegram.API.Bot.API.Get as API import Web.Telegram.API.Bot.API.Messages as API +import Web.Telegram.API.Bot.API.Payments as API import Web.Telegram.API.Bot.API.Queries as API +import Web.Telegram.API.Bot.API.Stickers as API import Web.Telegram.API.Bot.API.Updates as API -import Web.Telegram.API.Bot.API.Payments as API type TelegramBotAPI = TelegramBotMessagesAPI @@ -34,6 +36,7 @@ :<|> TelegramBotQueriesAPI :<|> TelegramBotGetAPI :<|> TelegramBotPaymentsAPI + :<|> TelegramBotStickersAPI -- | Proxy for Thelegram Bot API api :: Proxy TelegramBotAPI diff --git a/src/Web/Telegram/API/Bot/API/Chats.hs b/src/Web/Telegram/API/Bot/API/Chats.hs --- a/src/Web/Telegram/API/Bot/API/Chats.hs +++ b/src/Web/Telegram/API/Bot/API/Chats.hs @@ -1,15 +1,25 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} module Web.Telegram.API.Bot.API.Chats ( -- * Functions kickChatMember , kickChatMemberM + , kickChatMemberUntilM , leaveChat , leaveChatM , unbanChatMember , unbanChatMemberM + , restrictChatMemberM + , promoteChatMemberM + , exportChatInviteLinkM + , setChatPhotoM + , deleteChatPhotoM + , setChatTitleM + , setChatDescriptionM + , pinChatMessageM + , unpinChatMessageM , getChat , getChatM , getChatAdministrators @@ -18,6 +28,8 @@ , getChatMembersCountM , getChatMember , getChatMemberM + , setChatStickerSetM + , deleteChatStickerSetM -- * API , TelegramBotChatsAPI , chatsApi @@ -27,8 +39,10 @@ import Data.Text (Text) import Network.HTTP.Client (Manager) import Servant.API -import Servant.Client +import Servant.Client hiding (Response) +import Servant.Client.MultipartFormData import Web.Telegram.API.Bot.API.Core +import Web.Telegram.API.Bot.Requests import Web.Telegram.API.Bot.Responses -- | Telegram Bot API @@ -36,6 +50,7 @@ TelegramToken :> "kickChatMember" :> QueryParam "chat_id" Text :> QueryParam "user_id" Int + :> QueryParam "until_date" Int :> Post '[JSON] KickChatMemberResponse :<|> TelegramToken :> "leaveChat" :> QueryParam "chat_id" Text @@ -44,6 +59,37 @@ :> QueryParam "chat_id" Text :> QueryParam "user_id" Int :> Post '[JSON] UnbanChatMemberResponse + :<|> TelegramToken :> "restrictChatMember" + :> ReqBody '[JSON] RestrictChatMemberRequest + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "promoteChatMember" + :> ReqBody '[JSON] PromoteChatMemberRequest + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "exportChatInviteLink" + :> QueryParam "chat_id" Text + :> Post '[JSON] (Response Text) + :<|> TelegramToken :> "setChatPhoto" + :> MultipartFormDataReqBody SetChatPhotoRequest + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "deleteChatPhoto" + :> QueryParam "chat_id" Text + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "setChatTitle" + :> QueryParam "chat_id" Text + :> QueryParam "title" Text + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "setChatDescription" + :> QueryParam "chat_id" Text + :> QueryParam "description" Text + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "pinChatMessage" + :> QueryParam "chat_id" Text + :> QueryParam "message_id" Int + :> QueryParam "disable_notification" Bool + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "unpinChatMessage" + :> QueryParam "chat_id" Text + :> Post '[JSON] (Response Bool) :<|> TelegramToken :> "getChat" :> QueryParam "chat_id" Text :> Post '[JSON] GetChatResponse @@ -57,34 +103,73 @@ :> QueryParam "chat_id" Text :> QueryParam "user_id" Int :> Post '[JSON] GetChatMemberResponse + :<|> TelegramToken :> "setChatStickerSet" + :> QueryParam "chat_id" Text + :> QueryParam "sticker_set_name" Text + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "deleteChatStickerSet" + :> QueryParam "chat_id" Text + :> Post '[JSON] (Response Bool) -- | Proxy for Thelegram Bot API to administrate chats chatsApi :: Proxy TelegramBotChatsAPI chatsApi = Proxy -kickChatMember_ :: Token -> Maybe Text -> Maybe Int -> ClientM KickChatMemberResponse +kickChatMember_ :: Token -> Maybe Text -> Maybe Int -> Maybe Int -> ClientM KickChatMemberResponse leaveChat_ :: Token -> Maybe Text -> ClientM LeaveChatResponse unbanChatMember_ :: Token -> Maybe Text -> Maybe Int -> ClientM UnbanChatMemberResponse +restrictChatMember_ :: Token -> RestrictChatMemberRequest -> ClientM (Response Bool) +promoteChatMember_ :: Token -> PromoteChatMemberRequest -> ClientM (Response Bool) +exportChatInviteLink_ :: Token -> Maybe Text -> ClientM (Response Text) +setChatPhoto_ :: Token -> SetChatPhotoRequest -> ClientM (Response Bool) +deleteChatPhoto_ :: Token -> Maybe Text -> ClientM (Response Bool) +setChatTitle_ :: Token -> Maybe Text -> Maybe Text -> ClientM (Response Bool) +setChatDescription_ :: Token -> Maybe Text -> Maybe Text -> ClientM (Response Bool) +pinChatMessage_ :: Token -> Maybe Text -> Maybe Int -> Maybe Bool -> ClientM (Response Bool) +unpinChatMessage_ :: Token -> Maybe Text -> ClientM (Response Bool) getChat_ :: Token -> Maybe Text -> ClientM GetChatResponse getChatAdministrators_ :: Token -> Maybe Text -> ClientM GetChatAdministratorsResponse getChatMembersCount_ :: Token -> Maybe Text -> ClientM GetChatMembersCountResponse getChatMember_ :: Token -> Maybe Text -> Maybe Int -> ClientM GetChatMemberResponse +setChatStickerSet_ :: Token -> Maybe Text -> Maybe Text -> ClientM (Response Bool) +deleteChatStickerSet_ :: Token -> Maybe Text -> ClientM (Response Bool) kickChatMember_ :<|> leaveChat_ :<|> unbanChatMember_ + :<|> restrictChatMember_ + :<|> promoteChatMember_ + :<|> exportChatInviteLink_ + :<|> setChatPhoto_ + :<|> deleteChatPhoto_ + :<|> setChatTitle_ + :<|> setChatDescription_ + :<|> pinChatMessage_ + :<|> unpinChatMessage_ :<|> getChat_ :<|> getChatAdministrators_ :<|> getChatMembersCount_ - :<|> getChatMember_ = client chatsApi + :<|> getChatMember_ + :<|> setChatStickerSet_ + :<|> deleteChatStickerSet_ + = client chatsApi -- | Use this method to kick a user from a group or a supergroup. In the case of supergroups, the user will not be able to return to the group on their own using invite links, etc., unless unbanned first. The bot must be an administrator in the group for this to work. -kickChatMember :: Token -> Text -> Int -> Manager -> IO (Either ServantError KickChatMemberResponse) +kickChatMember :: Token + -> Text -- ^ Unique identifier for the target group or username of the target supergroup or channel (in the format @channelusername) + -> Int -- ^ Unique identifier of the target user + -> Manager -> IO (Either ServantError KickChatMemberResponse) kickChatMember token chatId userId = runClient (kickChatMemberM chatId userId) token -- | See 'kickChatMember' kickChatMemberM :: Text -> Int -> TelegramClient KickChatMemberResponse -kickChatMemberM chatId userId = asking $ \t -> kickChatMember_ t (Just chatId) (Just userId) +kickChatMemberM chatId userId = asking $ \t -> kickChatMember_ t (Just chatId) (Just userId) Nothing +kickChatMemberUntilM :: Text -- ^ Unique identifier for the target group or username of the target supergroup or channel (in the format @channelusername) + -> Int -- ^ Unique identifier of the target user + -> Int -- ^ Date when the user will be unbanned, unix time. If user is banned for more than 366 days or less than 30 seconds from the current time they are considered to be banned forever + -> TelegramClient KickChatMemberResponse +kickChatMemberUntilM chatId userId untilDate = asking $ \t -> kickChatMember_ t (Just chatId) (Just userId) (Just untilDate) + -- | Use this method for your bot to leave a group, supergroup or channel. Returns True on success. leaveChat :: Token -> Text -> Manager -> IO (Either ServantError LeaveChatResponse) leaveChat = runM leaveChatM @@ -101,6 +186,42 @@ unbanChatMemberM :: Text -> Int -> TelegramClient UnbanChatMemberResponse unbanChatMemberM chatId userId = asking $ \t -> unbanChatMember_ t (Just chatId) (Just userId) +-- | Use this method to restrict a user in a supergroup. The bot must be an administrator in the supergroup for this to work and must have the appropriate admin rights. Pass True for all boolean parameters to lift restrictions from a user. Returns True on success. +restrictChatMemberM :: RestrictChatMemberRequest -> TelegramClient (Response Bool) +restrictChatMemberM = run_ restrictChatMember_ + +-- | Use this method to promote or demote a user in a supergroup or a channel. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Pass False for all boolean parameters to demote a user. Returns True on success. +promoteChatMemberM :: PromoteChatMemberRequest -> TelegramClient (Response Bool) +promoteChatMemberM = run_ promoteChatMember_ + +-- | Use this method to export an invite link to a supergroup or a channel. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Returns exported invite link as String on success. +exportChatInviteLinkM :: Text -> TelegramClient (Response Text) +exportChatInviteLinkM chatId = run_ exportChatInviteLink_ (Just chatId) + +-- | Use this method to set a new profile photo for the chat. Photos can't be changed for private chats. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Returns True on success. +setChatPhotoM :: SetChatPhotoRequest -> TelegramClient (Response Bool) +setChatPhotoM = run_ setChatPhoto_ + +-- | Use this method to delete a chat photo. Photos can't be changed for private chats. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Returns True on success. +deleteChatPhotoM :: Text -> TelegramClient (Response Bool) +deleteChatPhotoM chatId = run_ deleteChatPhoto_ (Just chatId) + +-- | Use this method to change the title of a chat. Titles can't be changed for private chats. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Returns True on success. +setChatTitleM :: Text -> Maybe Text -> TelegramClient (Response Bool) +setChatTitleM chatId title = asking $ \t -> setChatTitle_ t (Just chatId) title + +-- | Use this method to change the description of a supergroup or a channel. The bot must be an administrator in the chat for this to work and must have the appropriate admin rights. Returns True on success. +setChatDescriptionM :: Text -> Maybe Text -> TelegramClient (Response Bool) +setChatDescriptionM chatId description = asking $ \t -> setChatDescription_ t (Just chatId) description + +-- | Use this method to pin a message in a supergroup or a channel. The bot must be an administrator in the chat for this to work and must have the 'can_pin_messages' admin right in the supergroup or 'can_edit_messages' admin right in the channel. Returns True on success. +pinChatMessageM :: Text -> Int -> Maybe Bool -> TelegramClient (Response Bool) +pinChatMessageM chatId messageId disableNotifications = asking $ \tkn -> pinChatMessage_ tkn (Just chatId) (Just messageId) disableNotifications + +-- | Use this method to unpin a message in a supergroup or a channel. The bot must be an administrator in the chat for this to work and must have the 'can_pin_messages' admin right in the supergroup or 'can_edit_messages' admin right in the channel. Returns True on success. +unpinChatMessageM :: Text -> TelegramClient (Response Bool) +unpinChatMessageM chatId = run_ unpinChatMessage_ (Just chatId) + -- | Use this method to get up to date information about the chat (current name of the user for one-on-one conversations, current username of a user, group or channel, etc.) getChat :: Token -> Text -> Manager -> IO (Either ServantError GetChatResponse) getChat = runM getChatM @@ -132,3 +253,12 @@ -- | See 'getChatMember' getChatMemberM :: Text -> Int -> TelegramClient GetChatMemberResponse getChatMemberM chatId userId = asking $ \t -> getChatMember_ t (Just chatId) (Just userId) + +setChatStickerSetM :: Text -- ^ Unique identifier for the target chat or username of the target supergroup (in the format @supergroupusername) + -> Text -- ^ Name of the sticker set to be set as the group sticker set + -> TelegramClient (Response Bool) +setChatStickerSetM chatId stickerSetName = asking $ \t -> setChatStickerSet_ t (Just chatId) (Just stickerSetName) + +deleteChatStickerSetM :: Text -- ^ Unique identifier for the target chat or username of the target supergroup (in the format @supergroupusername) + -> TelegramClient (Response Bool) +deleteChatStickerSetM chatId = run_ deleteChatStickerSet_ (Just chatId) diff --git a/src/Web/Telegram/API/Bot/API/Core.hs b/src/Web/Telegram/API/Bot/API/Core.hs --- a/src/Web/Telegram/API/Bot/API/Core.hs +++ b/src/Web/Telegram/API/Bot/API/Core.hs @@ -14,6 +14,7 @@ , asking , runClient , runClient' + , runTelegramClient , telegramBaseUrl ) where @@ -44,6 +45,10 @@ -- | Runs 'TelegramClient' runClient :: TelegramClient a -> Token -> Manager -> IO (Either ServantError a) runClient tcm token manager = runClient' tcm token (ClientEnv manager telegramBaseUrl) + +-- | Runs 'TelegramClient' +runTelegramClient :: Token -> Manager -> TelegramClient a -> IO (Either ServantError a) +runTelegramClient token manager tcm = runClient tcm token manager asking :: Monad m => (t -> m b) -> ReaderT t m b asking op = ask >>= \t -> lift $ op t diff --git a/src/Web/Telegram/API/Bot/API/Edit.hs b/src/Web/Telegram/API/Bot/API/Edit.hs --- a/src/Web/Telegram/API/Bot/API/Edit.hs +++ b/src/Web/Telegram/API/Bot/API/Edit.hs @@ -16,6 +16,8 @@ , editInlineMessageCaptionM , editInlineMessageReplyMarkup , editInlineMessageReplyMarkupM + , editMessageLiveLocationM + , stopMessageLiveLocationM -- * API , TelegramBotEditAPI , editApi @@ -23,9 +25,9 @@ ) where import Data.Proxy -import Network.HTTP.Client (Manager) +import Network.HTTP.Client (Manager) import Servant.API -import Servant.Client +import Servant.Client hiding (Response) import Web.Telegram.API.Bot.API.Core import Web.Telegram.API.Bot.Requests import Web.Telegram.API.Bot.Responses @@ -50,6 +52,12 @@ :<|> TelegramToken :> "editMessageReplyMarkup" :> ReqBody '[JSON] EditMessageReplyMarkupRequest :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "editMessageLiveLocation" + :> ReqBody '[JSON] EditMessageLiveLocationRequest + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "stopMessageLiveLocation" + :> ReqBody '[JSON] StopMessageLiveLocationRequest + :> Post '[JSON] (Response Bool) -- | Proxy for Thelegram Bot API @@ -62,12 +70,16 @@ editMessageText__ :: Token -> EditMessageTextRequest -> ClientM (Response Bool) editMessageCaption__ :: Token -> EditMessageCaptionRequest -> ClientM (Response Bool) editMessageReplyMarkup__ :: Token -> EditMessageReplyMarkupRequest -> ClientM (Response Bool) +editMessageLiveLocation_ :: Token -> EditMessageLiveLocationRequest -> ClientM (Response Bool) +stopMessageLiveLocation_ :: Token -> StopMessageLiveLocationRequest -> ClientM (Response Bool) editMessageText_ :<|> editMessageCaption_ :<|> editMessageReplyMarkup_ :<|> editMessageText__ :<|> editMessageCaption__ :<|> editMessageReplyMarkup__ + :<|> editMessageLiveLocation_ + :<|> stopMessageLiveLocation_ = client editApi -- | Use this method to edit text messages sent by the bot. On success, the edited 'Message' is returned, otherwise True is returned. @@ -116,3 +128,11 @@ -- | See 'editInlineMessageReplyMarkup' editInlineMessageReplyMarkupM :: EditMessageReplyMarkupRequest -> TelegramClient (Response Bool) editInlineMessageReplyMarkupM = run_ editMessageReplyMarkup__ + +-- | Use this method to edit live location messages sent by the bot or via the bot (for inline bots). A location can be edited until its live_period expires or editing is explicitly disabled by a call to 'stopMessageLiveLocationM'. +editMessageLiveLocationM :: EditMessageLiveLocationRequest -> TelegramClient (Response Bool) +editMessageLiveLocationM = run_ editMessageLiveLocation_ + +-- | Use this method to stop updating a live location message sent by the bot or via the bot (for inline bots) before live_period expires. +stopMessageLiveLocationM :: StopMessageLiveLocationRequest -> TelegramClient (Response Bool) +stopMessageLiveLocationM = run_ stopMessageLiveLocation_ diff --git a/src/Web/Telegram/API/Bot/API/Messages.hs b/src/Web/Telegram/API/Bot/API/Messages.hs --- a/src/Web/Telegram/API/Bot/API/Messages.hs +++ b/src/Web/Telegram/API/Bot/API/Messages.hs @@ -36,6 +36,7 @@ , uploadVideoNoteM , sendVideoNote , sendVideoNoteM + , sendMediaGroupM , sendLocation , sendLocationM , sendVenue @@ -56,9 +57,10 @@ import Data.Text (Text) import Network.HTTP.Client (Manager) import Servant.API -import Servant.Client +import Servant.Client hiding (Response) import Servant.Client.MultipartFormData import Web.Telegram.API.Bot.API.Core +import Web.Telegram.API.Bot.Data import Web.Telegram.API.Bot.Requests import Web.Telegram.API.Bot.Responses @@ -112,6 +114,9 @@ :<|> TelegramToken :> "sendVideoNote" :> ReqBody '[JSON] (SendVideoNoteRequest Text) :> Post '[JSON] MessageResponse + :<|> TelegramToken :> "sendMediaGroup" + :> ReqBody '[JSON] SendMediaGroupRequest + :> Post '[JSON] (Response [Message]) :<|> TelegramToken :> "sendLocation" :> ReqBody '[JSON] SendLocationRequest :> Post '[JSON] MessageResponse @@ -148,6 +153,7 @@ sendVoice_ :: Token -> SendVoiceRequest Text -> ClientM MessageResponse uploadVideoNote_ :: Token -> SendVideoNoteRequest FileUpload -> ClientM MessageResponse sendVideoNote_ :: Token -> SendVideoNoteRequest Text -> ClientM MessageResponse +sendMediaGroup_ :: Token -> SendMediaGroupRequest -> ClientM (Response [Message]) sendLocation_ :: Token -> SendLocationRequest -> ClientM MessageResponse sendVenue_ :: Token -> SendVenueRequest-> ClientM MessageResponse sendContact_ :: Token -> SendContactRequest -> ClientM MessageResponse @@ -169,6 +175,7 @@ :<|> sendVoice_ :<|> uploadVideoNote_ :<|> sendVideoNote_ + :<|> sendMediaGroup_ :<|> sendLocation_ :<|> sendVenue_ :<|> sendContact_ @@ -315,6 +322,9 @@ -- | See 'sendLocation' sendLocationM :: SendLocationRequest -> TelegramClient MessageResponse sendLocationM = run_ sendLocation_ + +sendMediaGroupM :: SendMediaGroupRequest -> TelegramClient (Response [Message]) +sendMediaGroupM = run_ sendMediaGroup_ -- | Use this method to send information about a venue. On success, the sent 'Message' is returned. sendVenue :: Token -> SendVenueRequest -> Manager -> IO (Either ServantError MessageResponse) diff --git a/src/Web/Telegram/API/Bot/API/Stickers.hs b/src/Web/Telegram/API/Bot/API/Stickers.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Bot/API/Stickers.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Telegram.API.Bot.API.Stickers + ( -- * Functions + getStickerSetM + , uploadStickerFileM + , createNewStickerSetM + , createNewStickerSetM' + , addStickerToSetM + , uploadStickerToSetM + , setStickerPositionInSetM + , deleteStickerFromSetM + -- * API + , TelegramBotStickersAPI + , stickerApi + -- * Types + ) where + +import Data.Proxy +import Data.Text (Text) +import Servant.API +import Servant.Client hiding (Response) +import Servant.Client.MultipartFormData +import Web.Telegram.API.Bot.API.Core +import Web.Telegram.API.Bot.Data +import Web.Telegram.API.Bot.Requests + +import Web.Telegram.API.Bot.Responses (Response) + +-- | Telegram Bot API +type TelegramBotStickersAPI = + TelegramToken :> "getStickerSet" + :> QueryParam "name" Text + :> Get '[JSON] (Response StickerSet) + :<|> TelegramToken :> "uploadStickerFile" + :> MultipartFormDataReqBody UploadStickerFileRequest + :> Post '[JSON] (Response File) + :<|> TelegramToken :> "createNewStickerSet" + :> ReqBody '[JSON] (CreateNewStickerSetRequest Text) + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "createNewStickerSet" + :> MultipartFormDataReqBody (CreateNewStickerSetRequest FileUpload) + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "addStickerToSet" + :> ReqBody '[JSON] (AddStickerToSetRequest Text) + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "addStickerToSet" + :> MultipartFormDataReqBody (AddStickerToSetRequest FileUpload) + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "setStickerPositionInSet" + :> QueryParam "sticker" Text + :> QueryParam "position" Int + :> Post '[JSON] (Response Bool) + :<|> TelegramToken :> "deleteStickerFromSet" + :> QueryParam "sticker" Text + :> Post '[JSON] (Response Bool) + +-- | Proxy for Thelegram Bot API +stickerApi :: Proxy TelegramBotStickersAPI +stickerApi = Proxy + +getStickerSet_ :: Token -> Maybe Text -> ClientM (Response StickerSet) +uploadStickerFile_ :: Token -> UploadStickerFileRequest -> ClientM (Response File) +createNewStickerSet_ :: Token -> CreateNewStickerSetRequest Text -> ClientM (Response Bool) +createNewStickerSet_' :: Token -> CreateNewStickerSetRequest FileUpload -> ClientM (Response Bool) +addStickerToSet_ :: Token -> AddStickerToSetRequest Text -> ClientM (Response Bool) +addStickerToSet_' :: Token -> AddStickerToSetRequest FileUpload -> ClientM (Response Bool) +setStickerPositionInSet_ :: Token -> Maybe Text -> Maybe Int -> ClientM (Response Bool) +deleteStickerFromSet_ :: Token -> Maybe Text -> ClientM (Response Bool) +getStickerSet_ + :<|> uploadStickerFile_ + :<|> createNewStickerSet_ + :<|> createNewStickerSet_' + :<|> addStickerToSet_ + :<|> addStickerToSet_' + :<|> setStickerPositionInSet_ + :<|> deleteStickerFromSet_ + = client stickerApi + +-- | Use this method to get a sticker set. +getStickerSetM :: Text -- ^ Name of the sticker set + -> TelegramClient (Response StickerSet) +getStickerSetM name = run_ getStickerSet_ $ Just name + +-- | Use this method to upload a .png file with a sticker for later use in 'createNewStickerSet' and 'addStickerToSet' methods (can be used multiple times). +uploadStickerFileM :: UploadStickerFileRequest -> TelegramClient (Response File) +uploadStickerFileM = run_ uploadStickerFile_ + +-- | Use this method to create new sticker set owned by a user. The bot will be able to edit the created sticker set. +createNewStickerSetM :: CreateNewStickerSetRequest Text -> TelegramClient (Response Bool) +createNewStickerSetM = run_ createNewStickerSet_ + +createNewStickerSetM' :: CreateNewStickerSetRequest FileUpload -> TelegramClient (Response Bool) +createNewStickerSetM' = run_ createNewStickerSet_' + +-- | Use this method to add a new sticker to a set created by the bot. +addStickerToSetM :: AddStickerToSetRequest Text -> TelegramClient (Response Bool) +addStickerToSetM = run_ addStickerToSet_ + +uploadStickerToSetM :: AddStickerToSetRequest FileUpload -> TelegramClient (Response Bool) +uploadStickerToSetM = run_ addStickerToSet_' + +-- | Use this method to move a sticker in a set created by the bot to a specific position. +setStickerPositionInSetM :: Text -- ^ File identifier of the sticker + -> Int -- ^ New sticker position in the set, zero-based + -> TelegramClient (Response Bool) +setStickerPositionInSetM fileId position = asking $ \t -> setStickerPositionInSet_ t (Just fileId) (Just position) + +-- | Use this method to delete a sticker from a set created by the bot. +deleteStickerFromSetM :: Text -- ^ File identifier of the sticker + -> TelegramClient (Response Bool) +deleteStickerFromSetM fileId = run_ deleteStickerFromSet_ (Just fileId) diff --git a/src/Web/Telegram/API/Bot/API/Updates.hs b/src/Web/Telegram/API/Bot/API/Updates.hs --- a/src/Web/Telegram/API/Bot/API/Updates.hs +++ b/src/Web/Telegram/API/Bot/API/Updates.hs @@ -25,7 +25,7 @@ import Data.Text (Text, empty) import Network.HTTP.Client (Manager) import Servant.API -import Servant.Client +import Servant.Client hiding (Response) import Servant.Client.MultipartFormData import Web.Telegram.API.Bot.API.Core import Web.Telegram.API.Bot.Requests diff --git a/src/Web/Telegram/API/Bot/Data.hs b/src/Web/Telegram/API/Bot/Data.hs --- a/src/Web/Telegram/API/Bot/Data.hs +++ b/src/Web/Telegram/API/Bot/Data.hs @@ -8,6 +8,7 @@ User (..) , LanguageCode (..) , ChatMember (..) + , ChatPhoto (..) , Chat (..) , Message (..) , MessageEntity (..) @@ -47,6 +48,10 @@ , SuccessfulPayment (..) , ShippingQuery (..) , PreCheckoutQuery (..) + , MaskPositionPoint (..) + , MaskPosition (..) + , StickerSet (..) + , InputMedia (..) -- * Functions , inlineKeyboardButton , keyboardButton @@ -70,7 +75,8 @@ , inlineQueryResultCachedSticker , inlineQueryResultCachedVideo , inlineQueryResultCachedVoice - + , inputMediaPhoto + , inputMediaVideo ) where import Prelude hiding (id) @@ -89,6 +95,7 @@ data User = User { user_id :: Int -- ^ Unique identifier for this user or bot + , user_is_bot :: Bool -- ^ True, if this user is a bot , user_first_name :: Text -- ^ User‘s or bot’s first name , user_last_name :: Maybe Text -- ^ User‘s or bot’s last name , user_username :: Maybe Text -- ^ User‘s or bot’s username @@ -156,6 +163,12 @@ , chat_first_name :: Maybe Text -- ^ First name of the other party in a private chat , chat_last_name :: Maybe Text -- ^ Last name of the other party in a private chat , chat_all_members_are_administrators :: Maybe Bool -- ^ True if a group has ‘All Members Are Admins’ enabled. + , chat_photo :: Maybe ChatPhoto -- ^ Chat photo. Returned only in 'getChat'. + , chat_description :: Maybe Text -- ^ Description, for supergroups and channel chats. Returned only in `getChat`. + , chat_invite_link :: Maybe Text -- ^ Chat invite link, for supergroups and channel chats. Returned only in `getChat`. + , chat_pinned_message :: Maybe Message -- ^ Pinned message, for supergroups. Returned only in 'getChat'. + , chat_sticker_set_name :: Maybe Text -- ^ For supergroups, name of group sticker set. Returned only in 'getChat'. + , chat_can_set_sticker_set :: Maybe Bool -- ^ True, if the bot can change the group sticker set. Returned only in 'getChat'. } deriving (Show, Generic) instance ToJSON Chat where @@ -279,12 +292,14 @@ -- | This object represents a sticker. data Sticker = Sticker { - sticker_file_id :: Text -- ^ Unique identifier for this file - , sticker_width :: Int -- ^ Sticker width - , sticker_height :: Int -- ^ Sticker height - , sticker_thumb :: Maybe PhotoSize -- ^ Sticker thumbnail in .webp or .jpg format - , sticker_emoji :: Maybe Text -- ^ Emoji associated with the sticker - , sticker_file_size :: Maybe Int -- ^ File size + sticker_file_id :: Text -- ^ Unique identifier for this file + , sticker_width :: Int -- ^ Sticker width + , sticker_height :: Int -- ^ Sticker height + , sticker_thumb :: Maybe PhotoSize -- ^ Sticker thumbnail in .webp or .jpg format + , sticker_emoji :: Maybe Text -- ^ Emoji associated with the sticker + , sticker_set_name :: Maybe Text + , sticker_mask_position :: Maybe MaskPosition + , sticker_file_size :: Maybe Int -- ^ File size } deriving (Show, Generic) instance ToJSON Sticker where @@ -815,8 +830,22 @@ data ChatMember = ChatMember { - cm_user :: User -- ^ Information about the user - , cm_status :: Text -- ^ The member's status in the chat. Can be “creator”, “administrator”, “member”, “left” or “kicked” + cm_user :: User -- ^ Information about the user + , cm_status :: Text -- ^ The member's status in the chat. Can be “creator”, “administrator”, “member”, “left” or “kicked” + , cm_until_date :: Maybe Integer -- ^ Restictred and kicked only. Date when restrictions will be lifted for this user, unix time + , cm_can_be_edited :: Maybe Bool -- ^ Administrators only. True, if the bot is allowed to edit administrator privileges of that user + , cm_can_change_info :: Maybe Bool -- ^ Administrators only. True, if the administrator can change the chat title, photo and other settings + , cm_can_post_messages :: Maybe Bool -- ^ Administrators only. True, if the administrator can post in the channel, channels only + , cm_can_edit_messages :: Maybe Bool -- ^ Administrators only. True, if the administrator can edit messages of other users and can pin messages, channels only + , cm_can_delete_messages :: Maybe Bool -- ^ Administrators only. True, if the administrator can delete messages of other users + , cm_can_invite_users :: Maybe Bool -- ^ Administrators only. True, if the administrator can invite new users to the chat + , cm_can_restrict_members :: Maybe Bool -- ^ Administrators only. True, if the administrator can restrict, ban or unban chat members + , cm_can_pin_messages :: Maybe Bool -- ^ Administrators only. True, if the administrator can pin messages, supergroups only + , cm_can_promote_members :: Maybe Bool -- ^ Administrators only. True, if the administrator can add new administrators with a subset of his own privileges or demote administrators that he has promoted, directly or indirectly (promoted by administrators that were appointed by the user) + , cm_can_send_messages :: Maybe Bool -- ^ Restricted only. True, if the user can send text messages, contacts, locations and venues + , cm_can_send_media_messages :: Maybe Bool -- ^ Restricted only. True, if the user can send audios, documents, photos, videos, video notes and voice notes, implies can_send_messages + , cm_can_send_other_messages :: Maybe Bool -- ^ Restricted only. True, if the user can send animations, games, stickers and use inline bots, implies can_send_media_messages + , cm_can_add_web_page_previews :: Maybe Bool -- ^ Restricted only. True, if user may add web page previews to his messages, implies can_send_media_messages } deriving (Show, Generic) instance ToJSON ChatMember where @@ -825,6 +854,18 @@ instance FromJSON ChatMember where parseJSON = parseJsonDrop 3 +data ChatPhoto = ChatPhoto + { + chat_photo_small_file_id :: Text -- ^ Unique file identifier of small (160x160) chat photo. This file_id can be used only for photo download. + , chat_photo_big_file_id :: Text -- ^ Unique file identifier of big (640x640) chat photo. This file_id can be used only for photo download. + } deriving (Show, Generic) + +instance ToJSON ChatPhoto where + toJSON = toJsonDrop 11 + +instance FromJSON ChatPhoto where + parseJSON = parseJsonDrop 11 + -- | This object represents a message. data Message = Message { @@ -835,11 +876,15 @@ , 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 , 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. , edit_date :: Maybe Int -- ^ Date the message was last edited in Unix time + , 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 , 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 @@ -847,11 +892,13 @@ , sticker :: Maybe Sticker -- ^ Message is a sticker, information about the sticker , 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 , caption :: Maybe Text -- ^ Caption for the photo or video , contact :: Maybe Contact -- ^ Message is a shared contact, information about the contact , location :: Maybe Location -- ^ Message is a shared location, information about the location , 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) + , 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 , new_chat_photo :: Maybe [PhotoSize] -- ^ A chat photo was change to this value @@ -864,8 +911,6 @@ , 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. - , video_note :: Maybe VideoNote -- ^ Message is a video note, information about the video message - , 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) } deriving (FromJSON, ToJSON, Show, Generic) -- | This object represents one special entity in a text message. For example, hashtags, usernames, URLs, etc. @@ -1066,3 +1111,90 @@ instance FromJSON PreCheckoutQuery where parseJSON = parseJsonDrop 8 + +data StickerSet = StickerSet + { + stcr_set_name :: Text -- ^ Sticker set name + , stcr_set_title :: Text -- ^ Sticker set title + , stcr_set_contains_masks :: Bool -- ^ True, if the sticker set contains masks + , stcr_set_stickers :: [Sticker] -- ^ List of all set stickers + } deriving (Show, Generic) + +instance ToJSON StickerSet where + toJSON = toJsonDrop 9 + +instance FromJSON StickerSet where + parseJSON = parseJsonDrop 9 + +data MaskPositionPoint = Forehead + | Eyes + | Mouth + | Chin deriving (Show, Generic) + +instance ToJSON MaskPositionPoint where + toJSON Forehead = "forehead" + toJSON Eyes = "eyes" + toJSON Mouth = "mouth" + toJSON Chin = "chin" + +instance FromJSON MaskPositionPoint where + parseJSON "forehead" = pure Forehead + parseJSON "eyes" = pure Eyes + parseJSON "mouth" = pure Mouth + parseJSON "chin" = pure Chin + parseJSON _ = fail $ "Failed to parse MaskPositionPoint" + +data MaskPosition = MaskPosition + { + mask_pos_point :: MaskPositionPoint -- ^ The part of the face relative to which the mask should be placed + , mask_pos_x_shift :: Float -- ^ Shift by X-axis measured in widths of the mask scaled to the face size, from left to right. For example, choosing -1.0 will place mask just to the left of the default mask position. + , mask_pos_y_shift :: Float -- ^ Shift by Y-axis measured in heights of the mask scaled to the face size, from top to bottom. For example, 1.0 will place the mask just below the default mask position. + , mask_pos_scale :: Float -- ^ Mask scaling coefficient. For example, 2.0 means double size. + } deriving (Show, Generic) + +instance ToJSON MaskPosition where + toJSON = toJsonDrop 9 + +instance FromJSON MaskPosition where + parseJSON = parseJsonDrop 9 + +-- | This object represents the content of a media message to be sent. +data InputMedia = + InputMediaPhoto + { + input_media_media :: Text -- ^ File to send. Pass a file_id to send a file that exists on the Telegram servers (recommended), pass an HTTP URL for Telegram to get a file from the Internet + , input_media_caption :: Maybe Text -- ^ Caption of the photo to be sent, 0-200 characters + } + | InputMediaVideo + { + input_media_media :: Text -- ^ File to send. Pass a file_id to send a file that exists on the Telegram servers (recommended), pass an HTTP URL for Telegram to get a file from the Internet + , input_media_caption :: Maybe Text -- ^ Caption of the video to be sent, 0-200 characters + , input_media_width :: Maybe Int -- ^ Video width + , input_media_height :: Maybe Int -- ^ Video height + , input_media_duration :: Maybe Int -- ^ Video duration + } deriving (Show, Generic) + +inputMediaPhoto :: Text -> InputMedia +inputMediaPhoto media = InputMediaPhoto media Nothing + +inputMediaVideo :: Text -> InputMedia +inputMediaVideo media = InputMediaVideo media Nothing Nothing Nothing Nothing + +inputMediaTagModifier :: String -> String +inputMediaTagModifier "InputMediaPhoto" = "photo" +inputMediaTagModifier "InputMediaVideo" = "video" +inputMediaTagModifier x = x + +inputMediaJSONOptions :: Options +inputMediaJSONOptions = defaultOptions { + fieldLabelModifier = drop 12 + , omitNothingFields = True + , sumEncoding = TaggedObject { tagFieldName = "type", contentsFieldName = undefined } + , constructorTagModifier = inputMediaTagModifier + } + +instance ToJSON InputMedia where + toJSON = genericToJSON inputMediaJSONOptions + +instance FromJSON InputMedia where + parseJSON = genericParseJSON inputMediaJSONOptions diff --git a/src/Web/Telegram/API/Bot/Requests.hs b/src/Web/Telegram/API/Bot/Requests.hs --- a/src/Web/Telegram/API/Bot/Requests.hs +++ b/src/Web/Telegram/API/Bot/Requests.hs @@ -19,6 +19,7 @@ , SendVideoRequest (..) , SendVoiceRequest (..) , SendVideoNoteRequest (..) + , SendMediaGroupRequest (..) , SendLocationRequest (..) , SendVenueRequest (..) , SendContactRequest (..) @@ -34,6 +35,14 @@ , SendInvoiceRequest (..) , AnswerShippingQueryRequest (..) , AnswerPreCheckoutQueryRequest (..) + , RestrictChatMemberRequest (..) + , PromoteChatMemberRequest (..) + , SetChatPhotoRequest (..) + , UploadStickerFileRequest (..) + , CreateNewStickerSetRequest (..) + , AddStickerToSetRequest (..) + , EditMessageLiveLocationRequest (..) + , StopMessageLiveLocationRequest (..) -- * Functions , localFileUpload , setWebhookRequest @@ -55,6 +64,7 @@ , uploadVoiceRequest , sendVideoNoteRequest , uploadVideoNoteRequest + , sendMediaGroupRequest , sendLocationRequest , sendVenueRequest , sendContactRequest @@ -75,6 +85,10 @@ , sendInvoiceRequest , okShippingQueryRequest , errorShippingQueryRequest + , okAnswerPrecheckoutQueryRequest + , errorAnswerPrecheckoutQueryRequest + , restrictChatMemberRequest + , promoteChatMemberRequest ) where import Data.Aeson @@ -94,8 +108,10 @@ InlineKeyboardButton, InlineKeyboardMarkup, InlineQueryResult, + InputMedia, KeyboardButton, - LabeledPrice, ParseMode, + LabeledPrice, + MaskPosition, ParseMode, ShippingOption) import Web.Telegram.API.Bot.JsonExt @@ -453,13 +469,13 @@ data SendVideoNoteRequest payload = SendVideoNoteRequest { - _vid_note_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) - , _vid_note_video_note :: payload -- ^ Video note to send. Pass a file_id as String to send a video note that exists on the Telegram servers (recommended) or upload a new video using multipart/form-data. More info on Sending Files ». Sending video notes by a URL is currently unsupported - , _vid_note_duration :: Maybe Int -- ^ Duration of sent video in seconds - , _vid_note_length :: Maybe Int -- ^ Video width and height + _vid_note_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) + , _vid_note_video_note :: payload -- ^ Video note to send. Pass a file_id as String to send a video note that exists on the Telegram servers (recommended) or upload a new video using multipart/form-data. More info on Sending Files ». Sending video notes by a URL is currently unsupported + , _vid_note_duration :: Maybe Int -- ^ Duration of sent video in seconds + , _vid_note_length :: Maybe Int -- ^ Video width and height , _vid_note_disable_notification :: Maybe Bool -- ^ Sends the message silently. iOS users will not receive a notification, Android users will receive a notification with no sound. - , _vid_note_reply_to_message_id :: Maybe Int -- ^ If the message is a reply, ID of the original message - , _vid_note_reply_markup :: Maybe ReplyKeyboard -- ^ Additional interface options. A JSON-serialized object for an inline keyboard, custom reply keyboard, instructions to remove reply keyboard or to force a reply from the user. + , _vid_note_reply_to_message_id :: Maybe Int -- ^ If the message is a reply, ID of the original message + , _vid_note_reply_markup :: Maybe ReplyKeyboard -- ^ Additional interface options. A JSON-serialized object for an inline keyboard, custom reply keyboard, instructions to remove reply keyboard or to force a reply from the user. } deriving (Show, Generic) instance ToJSON (SendVideoNoteRequest Text) where @@ -492,6 +508,7 @@ location_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @@channelusername@) , location_latitude :: Float -- ^ Latitude of location , location_longitude :: Float -- ^ Longitude of location + , location_live_period :: Maybe Int -- ^ Period in seconds for which the location will be updated, should be between 60 and 86400. , location_disable_notification :: Maybe Bool -- ^ Sends the message silently. iOS users will not receive a notification, Android users will receive a notification with no sound. , location_reply_to_message_id :: Maybe Int -- ^ If the message is a reply, ID of the original message , location_reply_markup :: Maybe ReplyKeyboard -- ^ Additional interface options. A JSON-serialized object for a custom reply keyboard, instructions to hide keyboard or to force a reply from the user. @@ -504,8 +521,26 @@ parseJSON = parseJsonDrop 9 sendLocationRequest :: ChatId -> Float -> Float -> SendLocationRequest -sendLocationRequest chatId latitude longitude = SendLocationRequest chatId latitude longitude Nothing Nothing Nothing +sendLocationRequest chatId latitude longitude = SendLocationRequest chatId latitude longitude Nothing Nothing Nothing Nothing +-- | This object represents request for 'sendMediaGroup' +data SendMediaGroupRequest = SendMediaGroupRequest + { + media_group_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) + , media_group_media :: [InputMedia] -- ^ Array describing photos and videos to be sent, must include 2–10 items + , media_group_disable_notification :: Maybe Bool -- ^ Sends the messages silently. Users will receive a notification with no sound. + , media_group_reply_to_message_id :: Maybe Int -- ^ If the messages are a reply, ID of the original message + } deriving(Show, Generic) + +instance ToJSON SendMediaGroupRequest where + toJSON = toJsonDrop 12 + +instance FromJSON SendMediaGroupRequest where + parseJSON = parseJsonDrop 12 + +sendMediaGroupRequest :: ChatId -> [InputMedia] -> SendMediaGroupRequest +sendMediaGroupRequest chatId inputMediaArray = SendMediaGroupRequest chatId inputMediaArray Nothing Nothing + -- | This object represents request for 'sendVenue' data SendVenueRequest = SendVenueRequest { @@ -782,26 +817,29 @@ data SendInvoiceRequest = SendInvoiceRequest { - snd_inv_chat_id :: Int64 -- ^ Unique identifier for the target private chat - , snd_inv_title :: Text -- ^ Product name - , snd_inv_description :: Text -- ^ Product description - , snd_inv_payload :: Text -- ^ Bot-defined invoice payload, 1-128 bytes. This will not be displayed to the user, use for your internal processes. - , snd_inv_provider_token :: Text -- ^ Payments provider token, obtained via Botfather - , snd_inv_start_parameter :: Text -- ^ Unique deep-linking parameter that can be used to generate this invoice when used as a start parameter - , snd_inv_currency :: CurrencyCode -- ^ Three-letter ISO 4217 code - , snd_inv_prices :: [LabeledPrice] -- ^ Price breakdown, a list of components (e.g. product price, tax, discount, delivery cost, delivery tax, bonus, etc.) - , snd_inv_photo_url :: Maybe Text -- ^ URL of the product photo for the invoice. Can be a photo of the goods or a marketing image for a service. People like it better when they see what they are paying for. - , snd_inv_photo_size :: Maybe Int -- ^ Photo size - , snd_inv_photo_width :: Maybe Int -- ^ Photo width - , snd_inv_photo_height :: Maybe Int -- ^ Photo height - , snd_inv_need_name :: Maybe Bool -- ^ Pass `True`, if you require the user's full name to complete the order - , snd_inv_need_phone_number :: Maybe Bool -- ^ Pass `True`, if you require the user's phone number to complete the order - , snd_inv_need_email :: Maybe Bool -- ^ Pass `True`, if you require the user's email to complete the order - , snd_inv_need_shipping_address :: Maybe Bool -- ^ Pass `True`, if you require the user's shipping address to complete the order - , snd_inv_is_flexible :: Maybe Bool -- ^ Pass `True`, if the final price depends on the shipping method - , snd_inv_disable_notification :: Maybe Bool -- ^ Sends the message silently. Users will receive a notification with no sound. - , snd_inv_reply_to_message :: Maybe Int -- ^ If the message is a reply, ID of the original message - , snd_inv_reply_markup :: Maybe InlineKeyboardMarkup -- ^ A JSON-serialized object for an inline keyboard. If empty, one 'Pay total price' button will be shown. If not empty, the first button must be a Pay button. + snd_inv_chat_id :: Int64 -- ^ Unique identifier for the target private chat + , snd_inv_title :: Text -- ^ Product name + , snd_inv_description :: Text -- ^ Product description + , snd_inv_payload :: Text -- ^ Bot-defined invoice payload, 1-128 bytes. This will not be displayed to the user, use for your internal processes. + , snd_inv_provider_token :: Text -- ^ Payments provider token, obtained via Botfather + , snd_inv_start_parameter :: Text -- ^ Unique deep-linking parameter that can be used to generate this invoice when used as a start parameter + , snd_inv_currency :: CurrencyCode -- ^ Three-letter ISO 4217 code + , snd_inv_prices :: [LabeledPrice] -- ^ Price breakdown, a list of components (e.g. product price, tax, discount, delivery cost, delivery tax, bonus, etc.) + , snd_inv_provider_data :: Maybe Text -- ^ JSON-encoded 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. + , snd_inv_photo_url :: Maybe Text -- ^ URL of the product photo for the invoice. Can be a photo of the goods or a marketing image for a service. People like it better when they see what they are paying for. + , snd_inv_photo_size :: Maybe Int -- ^ Photo size + , snd_inv_photo_width :: Maybe Int -- ^ Photo width + , snd_inv_photo_height :: Maybe Int -- ^ Photo height + , snd_inv_need_name :: Maybe Bool -- ^ Pass `True`, if you require the user's full name to complete the order + , snd_inv_need_phone_number :: Maybe Bool -- ^ Pass `True`, if you require the user's phone number to complete the order + , snd_inv_need_email :: Maybe Bool -- ^ Pass `True`, if you require the user's email to complete the order + , snd_inv_need_shipping_address :: Maybe Bool -- ^ Pass `True`, if you require the user's shipping address to complete the order + , snd_inv_send_phone_number_to_provider :: Maybe Bool -- ^ Pass True, if user's phone number should be sent to provider + , snd_inv_send_email_to_provider :: Maybe Bool -- ^ Pass True, if user's email address should be sent to provider + , snd_inv_is_flexible :: Maybe Bool -- ^ Pass `True`, if the final price depends on the shipping method + , snd_inv_disable_notification :: Maybe Bool -- ^ Sends the message silently. Users will receive a notification with no sound. + , snd_inv_reply_to_message :: Maybe Int -- ^ If the message is a reply, ID of the original message + , snd_inv_reply_markup :: Maybe InlineKeyboardMarkup -- ^ A JSON-serialized object for an inline keyboard. If empty, one 'Pay total price' button will be shown. If not empty, the first button must be a Pay button. } deriving (Show, Generic) instance ToJSON SendInvoiceRequest where @@ -820,7 +858,7 @@ -> [LabeledPrice] -- ^ Price breakdown, a list of components (e.g. product price, tax, discount, delivery cost, delivery tax, bonus, etc.) -> SendInvoiceRequest sendInvoiceRequest chatId title description payload providerToken startParameter currency prices - = SendInvoiceRequest chatId title description payload providerToken startParameter currency prices Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + = SendInvoiceRequest chatId title description payload providerToken startParameter currency prices Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing data AnswerShippingQueryRequest -- | If you sent an invoice requesting a shipping address and the parameter is_flexible was specified, the Bot API will send an Update with a shipping_query field to the bot. Use this method to reply to shipping queries. On success, True is returned. @@ -858,6 +896,182 @@ instance FromJSON AnswerPreCheckoutQueryRequest where parseJSON = parseJsonDrop 4 + +okAnswerPrecheckoutQueryRequest :: Text -> AnswerPreCheckoutQueryRequest +okAnswerPrecheckoutQueryRequest queryId = AnswerPreCheckoutQueryRequest queryId True Nothing + +errorAnswerPrecheckoutQueryRequest :: Text -> Text -> AnswerPreCheckoutQueryRequest +errorAnswerPrecheckoutQueryRequest queryId errorMessage = AnswerPreCheckoutQueryRequest queryId False $ Just errorMessage + +data RestrictChatMemberRequest = RestrictChatMemberRequest + { + rcm_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target supergroup (in the format @supergroupusername) + , rcm_user_id :: Int -- ^ Unique identifier of the target user + , rcm_until_date :: Maybe Int -- ^ Date when restrictions will be lifted for the user, unix time. If user is restricted for more than 366 days or less than 30 seconds from the current time, they are considered to be restricted forever + , rcm_can_send_messages :: Maybe Bool -- ^ Pass True, if the user can send text messages, contacts, locations and venues + , rcm_can_send_media_messages :: Maybe Bool -- ^ Pass True, if the user can send audios, documents, photos, videos, video notes and voice notes, implies can_send_messages + , rcm_can_send_other_messages :: Maybe Bool -- ^ Pass True, if the user can send animations, games, stickers and use inline bots, implies can_send_media_messages + , rcm_can_add_web_page_previews :: Maybe Bool -- ^ Pass True, if the user may add web page previews to their messages, implies can_send_media_messages + } deriving (Show, Generic) + +instance ToJSON RestrictChatMemberRequest where + toJSON = toJsonDrop 4 + +instance FromJSON RestrictChatMemberRequest where + parseJSON = parseJsonDrop 4 + +restrictChatMemberRequest :: ChatId -> Int -> RestrictChatMemberRequest +restrictChatMemberRequest chatId userId = RestrictChatMemberRequest chatId userId Nothing Nothing Nothing Nothing Nothing + +data PromoteChatMemberRequest = PromoteChatMemberRequest + { + pcmr_chat_id :: ChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) + , pcmr_user_id :: Int -- ^ Unique identifier of the target user + , pcmr_can_change_info :: Maybe Bool -- ^ Pass True, if the administrator can change chat title, photo and other settings + , pcmr_can_post_messages :: Maybe Bool -- ^ Pass True, if the administrator can create channel posts, channels only + , pcmr_can_edit_messages :: Maybe Bool -- ^ Pass True, if the administrator can edit messages of other users and can pin messages, channels only + , pcmr_can_delete_messages :: Maybe Bool -- ^ Pass True, if the administrator can delete messages of other users + , pcmr_can_invite_users :: Maybe Bool -- ^ Pass True, if the administrator can invite new users to the chat + , pcmr_can_restrict_members :: Maybe Bool -- ^ Pass True, if the administrator can restrict, ban or unban chat members + , pcmr_can_pin_messages :: Maybe Bool -- ^ Pass True, if the administrator can pin messages, supergroups only + , pcmr_can_promote_members :: Maybe Bool -- ^ Pass True, if the administrator can add new administrators with a subset of his own privileges or demote administrators that he has promoted, directly or indirectly (promoted by administrators that were appointed by him) + } deriving (Show, Generic) + +instance ToJSON PromoteChatMemberRequest where + toJSON = toJsonDrop 5 + +instance FromJSON PromoteChatMemberRequest where + parseJSON = parseJsonDrop 5 + +promoteChatMemberRequest :: ChatId -> Int -> PromoteChatMemberRequest +promoteChatMemberRequest chatId userId = PromoteChatMemberRequest chatId userId Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +data SetChatPhotoRequest = SetChatPhotoRequest + { + scp_chat_id :: ChatId + , scp_photo :: FileUpload + } + +instance ToMultipartFormData SetChatPhotoRequest where + toMultipartFormData req = + [ utf8Part "chat_id" (chatIdToPart $ scp_chat_id req) + , fileUploadToPart "photo" (scp_photo req) ] + +data UploadStickerFileRequest = UploadStickerFileRequest + { + upload_sticker_user_id :: Int -- ^ User identifier of sticker file owner + , upload_sticker_png_sticker :: FileUpload -- ^ Png image with the sticker, must be up to 512 kilobytes in size, dimensions must not exceed 512px, and either width or height must be exactly 512px. + } + +instance ToMultipartFormData UploadStickerFileRequest where + toMultipartFormData req = + [ utf8Part "user_id" (tshow $ upload_sticker_user_id req) + , fileUploadToPart "png_sticker" (upload_sticker_png_sticker req) ] + +data CreateNewStickerSetRequest payload = CreateNewStickerSetRequest + { + new_sticker_set_user_id :: Int -- ^ User identifier of created sticker set owner + , new_sticker_set_name :: Text -- ^ Short name of sticker set, to be used in t.me/addstickers/ URLs (e.g., animals). Can contain only english letters, digits and underscores. Must begin with a letter, can't contain consecutive underscores and must end in “_by_”. is case insensitive. 1-64 characters. + , new_sticker_set_title :: Text -- ^ Sticker set title, 1-64 characters + , new_sticker_set_png_sticker :: payload -- ^ Yes Png image with the sticker, must be up to 512 kilobytes in size, dimensions must not exceed 512px, and either width or height must be exactly 512px. Pass a file_id as a String to send a file that already exists on the Telegram servers, pass an HTTP URL as a String for Telegram to get a file from the Internet, or upload a new one using multipart/form-data. More info on Sending Files » + , new_sticker_set_emojis :: Text -- ^ One or more emoji corresponding to the sticker + , new_sticker_set_contains_masks :: Maybe Bool -- ^ Pass True, if a set of mask stickers should be created + , new_sticker_set_mask_position :: Maybe MaskPosition -- ^ A JSON-serialized object for position where the mask should be placed on faces + } deriving (Show, Generic) + +instance ToJSON (CreateNewStickerSetRequest Text) where + toJSON = toJsonDrop 16 + +instance FromJSON (CreateNewStickerSetRequest Text) where + parseJSON = parseJsonDrop 16 + +instance ToMultipartFormData (CreateNewStickerSetRequest FileUpload) where + toMultipartFormData req = + [ utf8Part "user_id" (tshow $ new_sticker_set_user_id req) + , utf8Part "name" $ new_sticker_set_name req + , utf8Part "title" $ new_sticker_set_title req + , utf8Part "emojis" $ new_sticker_set_emojis req + , fileUploadToPart "png_sticker" (new_sticker_set_png_sticker req) ] ++ + catMaybes + [ partLBS "contains_masks" . encode <$> new_sticker_set_contains_masks req + , partLBS "mask_position" . encode <$> new_sticker_set_mask_position req ] + +data AddStickerToSetRequest payload = AddStickerToSetRequest + { + add_sticker_to_set_user_id :: Int -- ^ User identifier of created sticker set owner + , add_sticker_to_set_name :: Text -- ^ Short name of sticker set, to be used in t.me/addstickers/ URLs (e.g., animals). Can contain only english letters, digits and underscores. Must begin with a letter, can't contain consecutive underscores and must end in “_by_”. is case insensitive. 1-64 characters. + , add_sticker_to_set_png_sticker :: payload -- ^ Yes Png image with the sticker, must be up to 512 kilobytes in size, dimensions must not exceed 512px, and either width or height must be exactly 512px. Pass a file_id as a String to send a file that already exists on the Telegram servers, pass an HTTP URL as a String for Telegram to get a file from the Internet, or upload a new one using multipart/form-data. More info on Sending Files » + , add_sticker_to_set_emojis :: Text -- ^ One or more emoji corresponding to the sticker + , add_sticker_to_set_mask_position :: Maybe MaskPosition -- ^ A JSON-serialized object for position where the mask should be placed on faces + } deriving (Show, Generic) + +instance ToJSON (AddStickerToSetRequest Text) where + toJSON = toJsonDrop 19 + +instance FromJSON (AddStickerToSetRequest Text) where + parseJSON = parseJsonDrop 19 + +instance ToMultipartFormData (AddStickerToSetRequest FileUpload) where + toMultipartFormData req = + [ utf8Part "user_id" (tshow $ add_sticker_to_set_user_id req) + , utf8Part "name" $ add_sticker_to_set_name req + , utf8Part "emojis" $ add_sticker_to_set_emojis req + , fileUploadToPart "png_sticker" (add_sticker_to_set_png_sticker req) ] ++ + catMaybes + [ partLBS "mask_position" . encode <$> add_sticker_to_set_mask_position req + ] + +data EditMessageLiveLocationRequest = + EditMessageLiveLocationRequest + { + edit_live_loc_chat_id :: Text -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) + , edit_live_loc_latitude :: Float -- ^ Latitude of new location + , edit_live_loc_longitude :: Float -- ^ Longitude of new location + , edit_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } + | EditMessageLiveLocationMessageRequest + { + edit_live_loc_message_id :: Int -- ^ Identifier of the sent message + , edit_live_loc_latitude :: Float -- ^ Latitude of new location + , edit_live_loc_longitude :: Float -- ^ Longitude of new location + , edit_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } + | EditMessageLiveLocationInlineMessageRequest + { + edit_live_loc_inline_message_id :: Text -- ^ Identifier of the inline message + , edit_live_loc_latitude :: Float -- ^ Latitude of new location + , edit_live_loc_longitude :: Float -- ^ Longitude of new location + , edit_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } deriving (Show, Generic) + +instance ToJSON EditMessageLiveLocationRequest where + toJSON = toJsonDrop 14 + +instance FromJSON EditMessageLiveLocationRequest where + parseJSON = parseJsonDrop 14 + +data StopMessageLiveLocationRequest = + StopMessageLiveLocationRequest + { + stop_live_loc_chat_id :: Text -- ^ Unique identifier for the target chat or username of the target channel (in the format @channelusername) + , stop_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } + | StopMessageLiveLocationMessageRequest + { + stop_live_loc_message_id :: Int -- ^ Identifier of the sent message + , stop_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } + | StopMessageLiveLocationInlineMessageRequest + { + stop_live_loc_inline_message_id :: Text -- ^ Identifier of the inline message + , stop_live_loc_reply_markup :: Maybe InlineKeyboardMarkup -- ^ An object for a new inline keyboard. + } deriving (Show, Generic) + +instance ToJSON StopMessageLiveLocationRequest where + toJSON = toJsonDrop 14 + +instance FromJSON StopMessageLiveLocationRequest where + parseJSON = parseJsonDrop 14 tshow :: Show a => a -> Text tshow = T.pack . show diff --git a/telegram-api.cabal b/telegram-api.cabal --- a/telegram-api.cabal +++ b/telegram-api.cabal @@ -1,5 +1,5 @@ name: telegram-api -version: 0.6.3.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 @@ -20,6 +20,8 @@ , test-data/Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg , test-data/concerto-for-2-trumpets-in-c-major.mp3 , test-data/wikipedia-telegram.txt + , test-data/sticker_1.png + , test-data/sticker_2.png extra-source-files: README.md @@ -36,6 +38,7 @@ , Web.Telegram.API.Bot.API.Updates , Web.Telegram.API.Bot.API.Chats , Web.Telegram.API.Bot.API.Payments + , Web.Telegram.API.Bot.API.Stickers , Web.Telegram.API.Bot.Data , Web.Telegram.API.Bot.Responses , Web.Telegram.API.Bot.Requests @@ -44,10 +47,12 @@ , Servant.Client.MultipartFormData build-depends: base >= 4.7 && < 5 , aeson >= 1.0 && < 1.3 + , containers >= 0.5 && < 0.6 , http-api-data , http-client >= 0.5 && < 0.6 - , servant >= 0.9 && <0.11 - , servant-client >= 0.9 && <0.11 + , servant >= 0.12 && < 0.13 + , servant-client >= 0.12 && < 0.13 + , servant-client-core >= 0.12 && < 0.13 , mtl >= 2.2 && < 2.3 , text , transformers @@ -68,6 +73,8 @@ , PaymentsSpec , JsonSpec , UpdatesSpec + , StickersSpec + , TestCore build-depends: base , aeson >= 1.0 && < 1.3 , hjpath @@ -77,14 +84,16 @@ , http-types , hspec , optparse-applicative - , servant >= 0.9 && <0.11 - , servant-client >= 0.9 && <0.11 + , servant >= 0.12 && <0.13 + , servant-client >= 0.12 && <0.13 + , servant-client-core >= 0.12 && < 0.13 , telegram-api , http-types , filepath , text , transformers , utf8-string + , random ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-name-shadowing default-language: Haskell2010 diff --git a/test-data/sticker_1.png b/test-data/sticker_1.png new file mode 100644 Binary files /dev/null and b/test-data/sticker_1.png differ diff --git a/test-data/sticker_2.png b/test-data/sticker_2.png new file mode 100644 Binary files /dev/null and b/test-data/sticker_2.png differ diff --git a/test/InlineSpec.hs b/test/InlineSpec.hs --- a/test/InlineSpec.hs +++ b/test/InlineSpec.hs @@ -48,6 +48,6 @@ inline_article = InlineQueryResultArticle "2131341" (Just "text article content") (Just message_content) Nothing Nothing Nothing Nothing Nothing Nothing Nothing 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 = 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 -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 +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 = 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 = 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 --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -7,25 +7,20 @@ import Control.Concurrent import Control.Monad -import Data.Either (isLeft, isRight) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status -import Servant.Client +import Paths_telegram_api +import Servant.Client hiding (Response) +import qualified Servant.Client.Core as Core import System.FilePath import Test.Hspec +import TestCore import Web.Telegram.API.Bot -import Paths_telegram_api - --- to print out remote response if response success not match -success, nosuccess :: (Show a, Show b) => Either a b -> Expectation -success e = e `shouldSatisfy` isRight -nosuccess e = e `shouldSatisfy` isLeft - spec :: Token -> ChatId -> Text -> Spec spec token chatId botName = do manager <- runIO $ newManager tlsManagerSettings @@ -47,7 +42,7 @@ it "should return error message" $ do res <- sendMessage token (sendMessageRequest (ChatChannel "") "test message") manager nosuccess res - let Left FailureResponse { responseStatus = Status { statusMessage = msg } } = res + let Left (FailureResponse Core.Response { responseStatusCode = Status { statusMessage = msg } }) = res msg `shouldBe` "Bad Request" it "should send message markdown" $ do @@ -105,7 +100,7 @@ it "should forward message" $ do res <- forwardMessage token (forwardMessageRequest chatId chatId 123000) manager nosuccess res - let Left FailureResponse { responseStatus = Status { statusMessage = msg } } = res + let Left (FailureResponse Core.Response { responseStatusCode = Status { statusMessage = msg } }) = res msg `shouldBe` "Bad Request" describe "/sendPhoto" $ do @@ -113,10 +108,10 @@ let photo = (sendPhotoRequest (ChatChannel "") "photo_id") { photo_caption = Just "photo caption" } - Left FailureResponse { responseStatus = Status { statusMessage = msg } } <- sendPhoto token photo manager + Left (FailureResponse Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- sendPhoto token photo manager msg `shouldBe` "Bad Request" it "should upload photo and resend it by id" $ do - let fileUpload = localFileUpload (testFile "christmas-cat.jpg") + let fileUpload = localFileUpload $ testFile "christmas-cat.jpg" let upload = (uploadPhotoRequest chatId fileUpload) { photo_caption = Just "uploaded photo" } @@ -138,24 +133,25 @@ _audio_performer = Just "performer" , _audio_title = Just "title" } - Left FailureResponse { responseStatus = Status { statusMessage = msg } } <- + Left (FailureResponse Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- sendAudio token audio 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") + 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) { _audio_performer = Just audioPerformer, _audio_title = Just audioTitle } - Right Response { + res <- uploadAudio token audio manager + let Right Response { result = Message { audio = Just Audio { audio_file_id = file_id, audio_title = Just title, audio_performer = Just performer } } - } <- uploadAudio token audio manager + } = res title `shouldBe` audioTitle performer `shouldBe` audioPerformer let audio = sendAudioRequest chatId file_id @@ -170,19 +166,21 @@ sendSticker token sticker manager sticker_file_id sticker `shouldBe` "CAADAgADGgADkWgMAAGXlYGBiM_d2wI" --"BQADAgADGgADkWgMAAGXlYGBiM_d2wI" it "should upload sticker" $ do - let fileUpload = localFileUpload (testFile "haskell-logo.webp") + let fileUpload = localFileUpload $ testFile "haskell-logo.webp" stickerReq = uploadStickerRequest chatId fileUpload - Right Response { result = Message { sticker = Just sticker } } <- - uploadSticker token stickerReq manager + res <- uploadSticker token stickerReq manager + success res + let Right Response { result = Message { sticker = Just sticker } } = res sticker_height sticker `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") + let fileUpload = localFileUpload $ testFile "Possible_PDM_signal_labeled_as_Sputnik_by_NASA.ogg" voiceReq = (uploadVoiceRequest chatId fileUpload) { _voice_duration = Just 10 } - Right Response { result = Message { voice = Just voice } } <- - uploadVoice token voiceReq manager + res <- uploadVoice token voiceReq manager + success res + let Right Response { result = Message { voice = Just voice } } = res voice_duration voice `shouldBe` 10 describe "/sendVideoNote" $ it "should upload video note" $ do @@ -197,15 +195,17 @@ 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") + let fileUpload = localFileUpload $ testFile "lego-video.mp4" videoReq = uploadVideoRequest chatId fileUpload - Right Response { result = Message { video = Just video } } <- - uploadVideo token videoReq manager + res <- uploadVideo token videoReq manager + success res + let Right Response { result = Message { video = Just video } } = res + video_width video `shouldBe` 560 describe "/sendDocument" $ it "should upload document" $ do - let fileUpload = localFileUpload (testFile "wikipedia-telegram.txt") + let fileUpload = localFileUpload $ testFile "wikipedia-telegram.txt" documentReq = uploadDocumentRequest chatId fileUpload Right Response { result = Message { document = Just document } } <- uploadDocument token documentReq manager @@ -265,7 +265,7 @@ fmap (T.take 10) (file_path file) `shouldBe` Just "thumbnails" it "should return error" $ do - Left FailureResponse { responseStatus = Status { statusMessage = msg } } <- + Left (FailureResponse Core.Response { responseStatusCode = Status { statusMessage = msg } }) <- getFile token "AAQEABMXDZEwAARC0Kj3twkzNcMkAmm" manager msg `shouldBe` "Bad Request" @@ -329,5 +329,19 @@ Right Response { result = Message { caption = Just cpt' } } <- editMessageCaption token editRequest manager cpt' `shouldBe` "edited cat picture" + + describe "/sendMediaGroup" $ do + it "should send all media in group" $ do + let photo1 = (inputMediaPhoto "http://s2.quickmeme.com/img/c9/c94711e0f933eb488e0cb0baa9d3eff1888a27ead4fd6089fd37d8f7d8f45a97.jpg") { + input_media_caption = Just "meme" + } + photo2 = (inputMediaPhoto "http://adit.io/imgs/lenses/go_deeper.png") { + input_media_caption = Just "Lenses" + } + request = sendMediaGroupRequest chatId [ photo1, photo2 ] + res <- 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 diff --git a/test/PaymentsSpec.hs b/test/PaymentsSpec.hs --- a/test/PaymentsSpec.hs +++ b/test/PaymentsSpec.hs @@ -5,23 +5,17 @@ module PaymentsSpec (spec) where -import Data.Either (isLeft, isRight) -import qualified Data.Text as T -import Data.Text (Text) -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) +import Data.Text (Text) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Test.Hspec +import TestCore import Web.Telegram.API.Bot --- to print out remote response if response success not match -success, nosuccess :: (Show a, Show b) => Either a b -> Expectation -success e = e `shouldSatisfy` isRight -nosuccess e = e `shouldSatisfy` isLeft - spec :: Token -> ChatId -> Text -> Text -> Spec -spec token (ChatId chatId) _ paymentToken = do +spec token 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" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,6 +12,7 @@ import qualified MainSpec import Options.Applicative import qualified PaymentsSpec +import qualified StickersSpec import System.Environment (lookupEnv, withArgs) import Test.Hspec import qualified Text.PrettyPrint.ANSI.Leijen as PP @@ -75,6 +76,7 @@ describe "Main integration tests" $ MainSpec.spec token chatId botName describe "Payments integration tests" $ PaymentsSpec.spec token chatId botName paymentToken describe "Updates API spec" $ UpdatesSpec.spec token botName + describe "Stickers API spec" $ StickersSpec.spec token chatId botName --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" diff --git a/test/StickersSpec.hs b/test/StickersSpec.hs new file mode 100644 --- /dev/null +++ b/test/StickersSpec.hs @@ -0,0 +1,87 @@ +{-# 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) +import Paths_telegram_api +import System.FilePath +import System.Random +import Test.Hspec +import TestCore +import Web.Telegram.API.Bot + +spec :: Token -> ChatId -> Text -> Spec +spec token chatId _ = do + manager <- runIO $ newManager tlsManagerSettings + dataDir <- runIO getDataDir + + res <- runIO $ runTelegramClient token manager getMeM + 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" + + 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 + + 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 + + describe "/createNewStickerSet" $ do + it "should create sticker set" $ do + rnd :: Integer <- randomRIO (10000, 99999) + 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 + stcr_set_name set `shouldBe` stickerSetName + + describe "StickerSet CRUD" $ do + let setTitle = "Haskell Telegram Bot API Test" + setName = "sticker_set_by_" <> botUsername + runIO $ print setName + _ <- runIO $ runTelegramClient token manager $ do + uploadResult <- uploadStickerFileM $ UploadStickerFileRequest userId stickerFile2 + let fileId = (file_id . result) uploadResult + request = CreateNewStickerSetRequest userId setName setTitle fileId "👍" (Just True) Nothing + createNewStickerSetM request + it "should add new sticker to the sicker set" $ do + Right (set, setAfter) <- runTelegramClient token manager $ do + let maskPosition = MaskPosition Eyes 0.0 0.0 0.0 + uploadRequest = AddStickerToSetRequest userId setName stickerFile1 "😃" (Just maskPosition) + _ <- uploadStickerToSetM uploadRequest + Response { result = set } <- getStickerSetM setName + let firstId = sticker_file_id . head . stcr_set_stickers + _ <- sendStickerM $ sendStickerRequest chatId $ firstId set + let lastId = sticker_file_id . last . stcr_set_stickers + _ <- deleteStickerFromSetM $ lastId set + Response { result = setAfter } <- getStickerSetM setName + return (set, setAfter) + stcr_set_contains_masks set `shouldBe` True + let stickerCount = length . stcr_set_stickers + stickerCount set `shouldBe` 2 + stickerCount setAfter `shouldBe` 1 + + + diff --git a/test/TestCore.hs b/test/TestCore.hs new file mode 100644 --- /dev/null +++ b/test/TestCore.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module TestCore (success, nosuccess, showText) where + +import Data.Either (isLeft, isRight) +import Data.Text (Text) +import qualified Data.Text as T +import Test.Hspec + +-- to print out remote response if response success not match +success, nosuccess :: (Show a, Show b) => Either a b -> Expectation +success e = e `shouldSatisfy` isRight +nosuccess e = e `shouldSatisfy` isLeft + +showText :: (Show a) => a -> Text +showText = T.pack . show diff --git a/test/UpdatesSpec.hs b/test/UpdatesSpec.hs --- a/test/UpdatesSpec.hs +++ b/test/UpdatesSpec.hs @@ -8,28 +8,28 @@ import Control.Concurrent import Control.Monad.IO.Class import Data.Text (Text) +import qualified Data.Text as T import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Test.Hspec import Web.Telegram.API.Bot -import qualified Data.Text as T spec :: Token -> Text -> Spec 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 <- runClient ( do + res <- runTelegramClient token manager $ do b <- getMeM info <- getWebhookInfoM - return (b, info)) token manager + return (b, info) let Right (Response {result = me}, Response {result = whi}) = 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 <- runClient ( do + res <- runTelegramClient token manager $ do info <- getWebhookInfoM liftIO $ (whi_url . result) info `shouldBe` "" liftIO $ threadDelay $ 2 * 1000 * 1000 -- to avoid Too many request error @@ -40,32 +40,31 @@ liftIO $ threadDelay $ 2 * 1000 * 1000 -- to avoid Too many request error del <- deleteWebhookM liftIO $ result del `shouldBe` True - getWebhookInfoM ) token manager + getWebhookInfoM let Right Response { result = whi } = res whi_url whi `shouldBe` "" it "should set allowed updates" $ do let allowedUpdates = map T.pack ["message", "callback_query"] - res <- runClient ( do + res <- runTelegramClient token manager $ do let request = (setWebhookRequest' url) { webhook_allowed_updates = Just allowedUpdates } set <- setWebhookM request liftIO $ result set `shouldBe` True - getWebhookInfoM ) token manager + getWebhookInfoM let Right Response { result = whi } = res whi_allowed_updates whi `shouldBe` Just allowedUpdates it "should set max connections" $ do - res <- runClient ( do - + res <- runTelegramClient token manager $ do let request = (setWebhookRequest' url) { webhook_max_connections = Just 5 } liftIO $ threadDelay $ 2 * 1000 * 1000 -- to avoid Too many request error set <- setWebhookM request liftIO $ result set `shouldBe` True - getWebhookInfoM ) token manager + getWebhookInfoM let Right Response { result = whi } = res whi_max_connections whi `shouldBe` Just 5