diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Poscat (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Poscat nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# telegram-raw-api + +Raw bindings to Telegram bot API 4.7 using servant (incomplete) + +## Todos + +1. complete bindings +2. documentation +3. tests ? + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Web/Telegram/API.hs b/src/Web/Telegram/API.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API.hs @@ -0,0 +1,16 @@ +module Web.Telegram.API + ( module Web.Telegram.API.Getting, + module Web.Telegram.API.Sending, + module Web.Telegram.API.Update, + module Web.Telegram.API.Actions, + module Web.Telegram.API.Editing, + Token (..), + ) +where + +import Web.Telegram.API.Actions +import Web.Telegram.API.Common +import Web.Telegram.API.Editing +import Web.Telegram.API.Getting +import Web.Telegram.API.Sending +import Web.Telegram.API.Update diff --git a/src/Web/Telegram/API/Actions.hs b/src/Web/Telegram/API/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Actions.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +-- | Actions that the bot can perform +module Web.Telegram.API.Actions + ( KickChatMember, + Kick, + UnbanChatMember, + Unban, + RestrictChatMember, + Restriction, + PromoteChatMember, + Promotion, + SetChatAdministratorCustomTitle, + SetChatPermissions, + ExportChatInviteLink, + SetChatPhoto, + DeleteChatPhoto, + SetChatTitle, + SetChatDescription, + PinChatMessage, + UnpinChatMessage, + LeaveChat, + SetChatStickerSet, + DeleteChatStickerSet, + UploadStickerFileU, + UploadStickerFile, + CreateNewStickerSetU, + CreateNewStickerSet, + AddStickerToSetU, + AddStickerToSet, + SetStickerPositionInSet, + DeleteStickerFromSet, + SetStickerSetThumbU, + SetStickerSetThumb, + AnswerInlineQuery, + InlineQueryAnswer, + ) +where + +import Data.Text (Text) +import Servant.API +import Servant.Multipart +import Web.Telegram.API.Actions.Data +import Web.Telegram.API.Common +import Web.Telegram.API.CompoundParam +import Web.Telegram.Types +import Web.Telegram.Types.Input +import Web.Telegram.Types.Update + +type KickChatMember = + Base + :> "kickChatmember" + :> ReqBody '[JSON] Kick + :> Get '[JSON] (ReqResult Bool) + +type UnbanChatMember = + Base + :> "unbanChatMember" + :> ReqBody '[JSON] Unban + :> Get '[JSON] (ReqResult Bool) + +type RestrictChatMember = + Base + :> "restrictChatMember" + :> ReqBody '[JSON] Restriction + :> Get '[JSON] (ReqResult Bool) + +type PromoteChatMember = + Base + :> "promoteChatMember" + :> ReqBody '[JSON] Promotion + :> Get '[JSON] (ReqResult Bool) + +type SetChatAdministratorCustomTitle = + Base + :> "setChatAdministratorCustomTitle" + :> QueryR "chat_id" ChatId + :> QueryR "user_id" Integer + :> QueryParam "custom_title" Text + :> Get '[JSON] (ReqResult Bool) + +type SetChatPermissions = + Base + :> "setChatPermissions" + :> QueryR "chat_id" ChatId + :> QueryR "permissions" ChatPermissions + :> Get '[JSON] (ReqResult Bool) + +type ExportChatInviteLink = + Base + :> "exportChatInviteLink" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Text) + +type SetChatPhoto = + Base + :> "setChatPhoto" + :> QueryR "chat_id" ChatId + :> CompoundParam Mem "photo" InputFile + :> Get '[JSON] (ReqResult Bool) + +type DeleteChatPhoto = + Base + :> "deleteChatPhoto" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Bool) + +type SetChatTitle = + Base + :> "setChatTitle" + :> QueryR "chat_id" ChatId + :> QueryR "title" Text + :> Get '[JSON] (ReqResult Bool) + +type SetChatDescription = + Base + :> "setChatDescription" + :> QueryR "chat_id" ChatId + :> QueryParam "description" Text + :> Get '[JSON] (ReqResult Bool) + +type PinChatMessage = + Base + :> "pinChatMessage" + :> QueryR "chat_id" ChatId + :> QueryR "message_id" Integer + :> QueryParam "disable_notification" Bool + :> Get '[JSON] (ReqResult Bool) + +type UnpinChatMessage = + Base + :> "unpinChatMessage" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Bool) + +type LeaveChat = + Base + :> "leaveChat" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Bool) + +type SetChatStickerSet = + Base + :> "setChatStickerSet" + :> QueryR "chat_id" ChatId + :> QueryR "sticker_set_name" Text + :> Get '[JSON] (ReqResult Bool) + +type DeleteChatStickerSet = + Base + :> "deleteChatStickerSet" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Bool) + +type UploadStickerFile' png = + Base + :> "uploadStickerFile" + :> QueryR "user_id" Integer + :> png + :> Get '[JSON] (ReqResult File) + +type UploadStickerFileU = + UploadStickerFile' (MultipartForm Mem PngSticker) + +type UploadStickerFile = + UploadStickerFile' (QueryR "png_sticker" Text) + +type CreateNewStickerSet' png = + Base + :> "createNewStickerSet" + :> QueryR "user_id" Integer + :> QueryR "name" Text + :> QueryR "title" Text + :> png + :> MultipartForm Mem TgsSticker + :> QueryR "emojis" Text + :> QueryParam "contains_masks" Bool + :> QueryParam "mask_position" MaskPosition + :> Get '[JSON] (ReqResult Bool) + +type CreateNewStickerSetU = + CreateNewStickerSet' (MultipartForm Mem PngSticker) + +type CreateNewStickerSet = + CreateNewStickerSet' (QueryR "png_sticker" Text) + +type AddStickerToSet' png = + Base + :> "addStickerToSet" + :> QueryR "user_id" Integer + :> QueryR "name" Text + :> png + :> MultipartForm Mem TgsSticker + :> QueryR "emojis" Text + :> QueryR "mask_position" MaskPosition + :> Get '[JSON] (ReqResult Bool) + +type AddStickerToSetU = + AddStickerToSet' (MultipartForm Mem PngSticker) + +type AddStickerToSet = + AddStickerToSet' (QueryR "png_sticker" Text) + +type SetStickerPositionInSet = + Base + :> "setStickerPositionInSet" + :> QueryR "sticker" Text + :> QueryR "positon" Integer + :> Get '[JSON] (ReqResult Bool) + +type DeleteStickerFromSet = + Base + :> "deleteStickerFromSet" + :> QueryR "sticker" Text + :> Get '[JSON] (ReqResult Bool) + +type SetStickerSetThumb' t = + Base + :> "setStickerSetThumb" + :> QueryR "name" Text + :> QueryR "user_id" Integer + :> t + :> Get '[JSON] (ReqResult Bool) + +type SetStickerSetThumbU = + SetStickerSetThumb' (MultipartForm Mem PngSticker) + +type SetStickerSetThumb = + SetStickerSetThumb' (QueryR "thumb" Text) + +type AnswerInlineQuery = + Base + :> "answerInlineQuery" + :> ReqBody '[JSON] InlineQueryAnswer + :> Get '[JSON] (ReqResult Bool) + +type AnswerCallbackQuery = + Base + :> "answerCallbackQuery" + :> ReqBody '[JSON] CallbackQueryAnswer + :> Get '[JSON] (ReqResult Bool) + +type SetMyCommands = + Base + :> "setMyCommands" + :> ReqBody '[JSON] CommandSet + :> Get '[JSON] (ReqResult Bool) diff --git a/src/Web/Telegram/API/Actions/Data.hs b/src/Web/Telegram/API/Actions/Data.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Actions/Data.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Web.Telegram.API.Actions.Data where + +import Data.Text (Text) +import Deriving.Aeson +import Web.Telegram.Types +import Web.Telegram.Types.Inline +import Web.Telegram.Types.Stock +import Web.Telegram.Types.Update + +data Kick + = Kick + { chatId :: ChatId, + userId :: Integer, + untilDate :: Maybe Integer + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake Kick + +data Unban + = Unban + { chatId :: ChatId, + userId :: Integer + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake Unban + +data Restriction + = Restriction + { chatId :: ChatId, + userId :: Integer, + permissions :: ChatPermissions, + untilDate :: Maybe Integer + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake Restriction + +data Promotion + = Promotion + { chatId :: ChatId, + userId :: Integer, + canChangeInfo :: Maybe Bool, + canPostMessages :: Maybe Bool, + canEditMessages :: Maybe Bool, + canDeleteMessages :: Maybe Bool, + canInviteUsers :: Maybe Bool, + canRestrictMembers :: Maybe Bool, + canPinMessages :: Maybe Bool, + canPromoteMembers :: Maybe Bool + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake Promotion + +data InlineQueryAnswer + = InlineQueryAnswer + { inlineQueryId :: Text, + results :: [InlineQueryResult], + cacheTime :: Maybe Integer, + isPersonal :: Maybe Bool, + nextOffset :: Maybe Text, + switchPmText :: Maybe Text, + switchPmParameter :: Maybe Text + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON, FromJSON) + via Snake InlineQueryAnswer + +data CallbackQueryAnswer + = CQAns + { callbackQueryId :: Text, + text :: Maybe Text, + showAlert :: Maybe Bool, + url :: Maybe Text, + cacheTime :: Maybe Integer + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON, FromJSON) + via Snake CallbackQueryAnswer + +newtype CommandSet + = CommandSet + { commands :: [BotCommand] + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON, FromJSON) + via Snake CommandSet diff --git a/src/Web/Telegram/API/Common.hs b/src/Web/Telegram/API/Common.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Common.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Web.Telegram.API.Common where + +import Data.Text (Text) +import GHC.Generics +import Servant.API +import Data.Aeson +import Data.String +import Web.Telegram.Types + +newtype Token = Token Text + deriving (Show, Eq, Generic) + deriving newtype (IsString, ToJSON, FromJSON) + +instance Default Token where + def = "123456:ABC-DEF1234ghIkl-zyx57W2v1u123ew11" + +instance ToHttpApiData Token where + toQueryParam (Token t) = "bot" <> t + +type Base = Capture "token" Token diff --git a/src/Web/Telegram/API/CompoundParam.hs b/src/Web/Telegram/API/CompoundParam.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/CompoundParam.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Compound parameters +module Web.Telegram.API.CompoundParam + ( CompoundParam, + CompoundParams, + Warp (..), + ) +where + +import qualified Data.ByteString.Lazy as LBS +import Data.Kind +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits +import Servant.API +import Servant.Client +import Servant.Multipart +import Web.Telegram.Types + +data CompoundParam (tag :: Type) (sym :: Symbol) (a :: Type) + +data CompoundParams (tag :: Type) (sym :: Symbol) (a :: Type) + +instance + (KnownSymbol sym, ToHttpApiData a, HasClient m api, ToMultipart tag a, MultipartBackend tag) => + HasClient m (CompoundParam tag sym a :> api) + where + type + Client m (CompoundParam tag sym a :> api) = + (LBS.ByteString, a) -> Client m api + clientWithRoute pm _ req (boundary, param) = + clientWithRoute pm (Proxy @(MultipartForm tag a :> QueryR sym a :> api)) req (boundary, param) param + hoistClientMonad pm _ f cl arg = + hoistClientMonad pm (Proxy @api) f (cl arg) + +instance + (KnownSymbol sym, ToHttpApiData a, HasClient m api, ToMultipart tag a, MultipartBackend tag) => + HasClient m (CompoundParams tag sym a :> api) + where + type + Client m (CompoundParams tag sym a :> api) = + (LBS.ByteString, [a]) -> Client m api + clientWithRoute pm _ req (boundary, param) = + clientWithRoute pm (Proxy @(MultipartForm tag (Fold [a]) :> QueryR sym (Warp [a]) :> api)) req (boundary, coe param) (coe param) + hoistClientMonad pm _ f cl arg = + hoistClientMonad pm (Proxy @api) f (cl arg) + +newtype Warp a = Warp a + +instance (ToHttpApiData a) => ToHttpApiData (Warp [a]) where + toQueryParam (Warp l) = + "[" + <> T.intercalate "," (fmap toQueryParam l) + <> "]" + +newtype Fold a = Fold {unfold :: a} + +instance Semigroup (Fold (MultipartData tag)) where + Fold d1 <> Fold d2 = Fold $ MultipartData (inputs d1 <> inputs d2) (files d1 <> files d2) + +instance Monoid (Fold (MultipartData tag)) where + mempty = Fold $ MultipartData mempty mempty + +instance (ToMultipart tag a) => ToMultipart tag (Fold [a]) where + toMultipart (Fold l) = unfold $ foldMap (Fold . toMultipart) l diff --git a/src/Web/Telegram/API/Editing.hs b/src/Web/Telegram/API/Editing.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Editing.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Telegram.API.Editing + ( EditMessageText, + EditMessageCaption, + EditMessageMedia, + EditMessageReplyMarkup, + StopPoll, + DeleteMessage, + TextEdit, + CaptionEdit, + MediaEdit, + MarkupEdit, + PollStop, + ) +where + +import Data.Text (Text) +import Servant.API +import Servant.Multipart +import Web.Telegram.API.Common +import Web.Telegram.API.CompoundParam +import Web.Telegram.API.Editing.Data +import Web.Telegram.Types +import Web.Telegram.Types.Input +import Web.Telegram.Types.Update + +type Res = + Get '[JSON] (ReqResult (ReqEither Bool Message)) + +type EditMessageText = + Base + :> "editMessageText" + :> ReqBody '[JSON] TextEdit + :> Res + +type EditMessageCaption = + Base + :> "editMessageCaption" + :> CaptionEdit + :> Res + +type EditMessageMedia = + Base + :> "editMessageMedia" + :> QueryParam "chat_id" ChatId + :> QueryParam "message_id" Integer + :> QueryParam "inline_message_id" Text + :> CompoundParam Mem "media" InputMedia + :> Res + +type EditMessageReplyMarkup = + Base + :> "editMessageReplyMarkup" + :> ReqBody '[JSON] MarkupEdit + :> Res + +type StopPoll = + Base + :> "stopPoll" + :> ReqBody '[JSON] PollStop + :> Get '[JSON] (ReqResult Poll) + +type DeleteMessage = + Base + :> "deleteMessage" + :> QueryR "chat_id" ChatId + :> QueryR "message_id" Integer + :> Get '[JSON] (ReqResult Bool) diff --git a/src/Web/Telegram/API/Editing/Data.hs b/src/Web/Telegram/API/Editing/Data.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Editing/Data.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Web.Telegram.API.Editing.Data where + +import Data.Text (Text) +import Deriving.Aeson +import Web.Telegram.Types +import Web.Telegram.Types.Input +import Web.Telegram.Types.Interaction +import Web.Telegram.Types.Stock + +data TextEdit + = TextE + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + text :: Text, + parseMode :: Maybe ParseMode, + disalbeWebPagePreview :: Maybe Bool, + replyMarkup :: Maybe InlineKeyboardMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (FromJSON, ToJSON) + via Snake TextEdit + +data CaptionEdit + = CaptionE + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + caption :: Maybe Text, + parseMode :: Maybe ParseMode, + replyMarkup :: Maybe InlineKeyboardMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (FromJSON, ToJSON) + via Snake CaptionEdit + +data MediaEdit + = MediaE + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + media :: InputMedia + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake MediaEdit + +data MarkupEdit + = MarkupEdit + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + replyMarkup :: Maybe InlineKeyboardMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake MarkupEdit + +data PollStop + = PollStop + { chatId :: ChatId, + messageId :: Integer, + replyMarkup :: Maybe InlineKeyboardMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake PollStop diff --git a/src/Web/Telegram/API/Getting.hs b/src/Web/Telegram/API/Getting.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Getting.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Telegram.API.Getting where + +import Data.Text (Text) +import Servant.API +import Web.Telegram.API.Common +import Web.Telegram.Types +import Web.Telegram.Types.Update + +type GetMe = + Base + :> "getMe" + :> Get '[JSON] (ReqResult User) + +type GetUserProfilePhotos = + Base + :> "getUserProfilePhotos" + :> QueryR "user_id" Integer + :> QueryParam "offset" Integer + :> QueryParam "limit" Integer + :> Get '[JSON] (ReqResult UserProfilePhotos) + +type GetFile = + Base + :> "getFile" + :> QueryR "file_id" Text + :> Get '[JSON] (ReqResult File) + +type GetChat = + Base + :> "getChat" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Chat) + +type GetChatAdministrators = + Base + :> "getChatAdministrators" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult [ChatMember]) + +type GetChatMembersCount = + Base + :> "getChatMembersCount" + :> QueryR "chat_id" ChatId + :> Get '[JSON] (ReqResult Integer) + +type GetChatMember = + Base + :> "getChatMember" + :> QueryR "chat_id" ChatId + :> QueryR "user_id" Integer + :> Get '[JSON] (ReqResult ChatMember) + +type GetMyCommands = + Base + :> "getMyCommands" + :> Get '[JSON] (ReqResult [BotCommand]) + +type GetStickerSet = + Base + :> "getStickerSet" + :> QueryR "name" Text + :> Get '[JSON] (ReqResult StickerSet) diff --git a/src/Web/Telegram/API/Lens.hs b/src/Web/Telegram/API/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Lens.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module Web.Telegram.API.Lens {-# DEPRECATED "Use labels from generics-lens instead" #-} + ( module Web.Telegram.Types.Lens, + disableWebPagePreview, + parseMode, + disableNotification, + replyToMessageId, + fromChatId, + action, + inlineMessageId, + inlineQueryId, + results, + cacheTime, + isPersonal, + nextOffset, + switchPmText, + switchPmParameter, + offset, + limit, + timeout, + allowedUpdates, + url, + maxConnections, + ) +where + +import Control.Lens +import Data.Generics.Product +import Web.Telegram.Types.Lens + +disableWebPagePreview :: HasField "disableWebPagePreview" s t a b => Lens s t a b +disableWebPagePreview = field @"disableWebPagePreview" + +parseMode :: HasField "parseMode" s t a b => Lens s t a b +parseMode = field @"parseMode" + +disableNotification :: HasField "disableNotification" s t a b => Lens s t a b +disableNotification = field @"disableNotification" + +replyToMessageId :: HasField "replyToMessageId" s t a b => Lens s t a b +replyToMessageId = field @"replyToMessageId" + +fromChatId :: HasField "fromChatId" s t a b => Lens s t a b +fromChatId = field @"fromChatId" + +action :: HasField "action" s t a b => Lens s t a b +action = field @"action" + +inlineMessageId :: HasField "inlineMessageId" s t a b => Lens s t a b +inlineMessageId = field @"inlineMessageId" + +inlineQueryId :: HasField "inlineQueryId" s t a b => Lens s t a b +inlineQueryId = field @"inlineQueryId" + +results :: HasField "results" s t a b => Lens s t a b +results = field @"results" + +cacheTime :: HasField "cacheTime" s t a b => Lens s t a b +cacheTime = field @"cacheTime" + +isPersonal :: HasField "isPersonal" s t a b => Lens s t a b +isPersonal = field @"isPersonal" + +nextOffset :: HasField "nextOffset" s t a b => Lens s t a b +nextOffset = field @"nextOffset" + +switchPmText :: HasField "switchPmText" s t a b => Lens s t a b +switchPmText = field @"switchPmText" + +switchPmParameter :: HasField "switchPmParameter" s t a b => Lens s t a b +switchPmParameter = field @"switchPmParameter" + +offset :: HasField "offset" s t a b => Lens s t a b +offset = field @"offset" + +limit :: HasField "limit" s t a b => Lens s t a b +limit = field @"limit" + +timeout :: HasField "timeout" s t a b => Lens s t a b +timeout = field @"timeout" + +allowedUpdates :: HasField "allowedUpdates" s t a b => Lens s t a b +allowedUpdates = field @"allowedUpdates" + +url :: HasField "url" s t a b => Lens s t a b +url = field @"url" + +maxConnections :: HasField "maxConnections" s t a b => Lens s t a b +maxConnections = field @"maxConnections" diff --git a/src/Web/Telegram/API/Sending.hs b/src/Web/Telegram/API/Sending.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Sending.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +-- | Sending stuff +module Web.Telegram.API.Sending + ( SendMessage, + ForwardMessage, + SendPhoto, + SendPhoto', + SendAudio, + SendAudio', + SendDocument, + SendDocument', + SendVideo, + SendVideo', + SendAnimation, + SendAnimation', + SendVoice, + SendVoice', + SendVideoNote, + SendVideoNote', + SendMediaGroup, + SendLocation, + EditMessageLiveLocation, + StopMessageLiveLocation, + SendVenue, + SendContact, + SendPoll, + SendDice, + SendChatAction, + SendSticker, + SendSticker', + SMessage, + FwdMessage, + PhotoMessage, + AudioMessage, + DocMessage, + VidMessage, + AnimationMessage, + VoiceMessage, + VNMessage, + LocationEdit, + LocationStop, + VenueMessage, + ContactMessage, + PollMessage, + DiceMessage, + ChatAction, + StickerMessage, + ) +where + +import Data.Text (Text) +import Servant.API +import Servant.Multipart +import Web.Telegram.API.Common +import Web.Telegram.API.CompoundParam +import Web.Telegram.API.Sending.Data +import Web.Telegram.Types + ( ChatId (..), + ParseMode (..), + QueryR, + ) +import qualified Web.Telegram.Types as T +import Web.Telegram.Types.Input +import Web.Telegram.Types.Interaction +import Web.Telegram.Types.Update + +type MessageR' = + QueryParam "disable_notification" Bool + :> QueryParam "reply_to_message_id" Integer + :> QueryParam "reply_markup" ReplyMarkup + :> Get '[JSON] (ReqResult T.Message) + +type Res = + Get '[JSON] (ReqResult T.Message) + +type MessageR = + QueryParam "parse_mode" ParseMode + :> MessageR' + +type SendMessage = + Base + :> "sendMessage" + :> ReqBody '[JSON] SMessage + :> Res + +type ForwardMessage = + Base + :> "forwardMessage" + :> ReqBody '[JSON] FwdMessage + :> Res + +type SendPhoto = + Base + :> "sendPhoto" + :> ReqBody '[JSON] (PhotoMessage Text) + :> Res + +type SendPhoto' photo = + Base + :> "sendPhoto" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Photo + :> QueryParam "caption" Text + :> MessageR + +type SendAudio = + Base + :> "sendAudio" + :> ReqBody '[JSON] (AudioMessage Text) + :> Res + +type SendAudio' audio = + Base + :> "sendAudio" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Audio + :> QueryParam "caption" Text + :> QueryParam "duration" Integer + :> QueryParam "performer" Text + :> QueryParam "title" Text + -- TODO: Handle thumbnail + :> MessageR + +type SendDocument = + Base + :> "sendDocument" + :> ReqBody '[JSON] (DocMessage Text) + :> Res + +type SendDocument' doc = + Base + :> "sendDocument" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Doc + :> QueryParam "caption" Text + :> MessageR + +type SendVideo = + Base + :> "sendVideo" + :> ReqBody '[JSON] (VidMessage Text) + :> Res + +type SendVideo' = + Base + :> "sendVideo" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Video + :> QueryParam "duration" Integer + :> QueryParam "width" Integer + :> QueryParam "height" Integer + :> QueryParam "caption" Text + :> QueryParam "supports_streaming" Bool + :> MessageR + +type SendAnimation = + Base + :> "sendAnimation" + :> ReqBody '[JSON] (AnimationMessage Text) + :> Res + +type SendAnimation' = + Base + :> "sendAnimation" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Animation + :> QueryParam "duration" Integer + :> QueryParam "width" Integer + :> QueryParam "height" Integer + :> QueryParam "caption" Text + :> MessageR + +type SendVoice = + Base + :> "sendVoice" + :> ReqBody '[JSON] (VoiceMessage Text) + :> Res + +type SendVoice' = + Base + :> "sendVoice" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Voice + :> QueryParam "duration" Integer + :> QueryParam "caption" Text + :> MessageR + +type SendVideoNote = + Base + :> "sendVideoNote" + :> ReqBody '[JSON] (VNMessage Text) + :> Res + +type SendVideoNote' = + Base + :> "sendVideoNote" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem VideoNote + :> QueryParam "duration" Integer + :> QueryParam "length" Integer + :> MessageR + +type SendMediaGroup = + Base + :> "sendMediaGroup" + :> QueryR "chat_id" ChatId + :> CompoundParams Mem "media" VideoOrPhoto + :> QueryParam "disable_notification" Bool + :> QueryParam "reply_to_message_id" Integer + :> Get '[JSON] (ReqResult [T.Message]) + +type SendLocation = + Base + :> "sendLocation" + :> ReqBody '[JSON] LocationMessage + :> Res + +type EditMessageLiveLocation = + Base + :> "editMessageLiveLocation" + :> ReqBody '[JSON] LocationEdit + :> Get '[JSON] (ReqResult (ReqEither T.Message Bool)) + +type StopMessageLiveLocation = + Base + :> "stopMessageLiveLocation" + :> ReqBody '[JSON] LocationStop + :> Get '[JSON] (ReqResult (ReqEither T.Message Bool)) + +type SendVenue = + Base + :> "sendVenue" + :> ReqBody '[JSON] VenueMessage + :> Res + +type SendContact = + Base + :> "sendContact" + :> ReqBody '[JSON] ContactMessage + :> Res + +type SendPoll = + Base + :> "sendPoll" + :> ReqBody '[JSON] PollMessage + :> Res + +type SendDice = + Base + :> "sendDice" + :> ReqBody '[JSON] DiceMessage + :> Res + +type SendChatAction = + Base + :> "sendChatAction" + :> ReqBody '[JSON] ChatAction + :> Get '[JSON] (ReqResult Bool) + +type SendSticker = + Base + :> "sendSticker" + :> ReqBody '[JSON] StickerMessage + :> Res + +type SendSticker' sticker = + Base + :> "sendSticker" + :> QueryR "chat_id" ChatId + :> MultipartForm Mem Sticker + :> MessageR' diff --git a/src/Web/Telegram/API/Sending/Data.hs b/src/Web/Telegram/API/Sending/Data.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Sending/Data.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DataKinds #-} + +module Web.Telegram.API.Sending.Data where + +import Data.Text (Text) +import Deriving.Aeson +import Web.Telegram.Types +import Web.Telegram.Types.Interaction +import Web.Telegram.Types.Stock + +data SMessage + = SMsg + { chatId :: ChatId, + text :: Text, + disableWebPagePreview :: Maybe Bool, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake SMessage + +data FwdMessage + = FwdMsg + { chatId :: ChatId, + fromChatId :: ChatId, + messageId :: Integer, + disableNotification :: Maybe Bool + } + deriving (Show, Eq, Generic, Default) + deriving + (FromJSON, ToJSON) + via Snake FwdMessage + +data PhotoMessage a + = PhotoMsg + { chatId :: ChatId, + photo :: a, + caption :: Maybe Text, + disableWebPagePreview :: Maybe Bool, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (PhotoMessage a) + +data AudioMessage a + = AudioMsg + { chatId :: ChatId, + audio :: a, + caption :: Maybe Text, + duration :: Maybe Integer, + performer :: Maybe Text, + title :: Maybe Text, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (AudioMessage a) + +data DocMessage a + = DocMsg + { chatId :: ChatId, + document :: a, + caption :: Maybe Text, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (DocMessage a) + +data VidMessage a + = VidMsg + { chatId :: ChatId, + video :: a, + duration :: Maybe Integer, + width :: Maybe Integer, + height :: Maybe Integer, + caption :: Maybe Text, + supportsStreaming :: Maybe Bool, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (VidMessage a) + +data AnimationMessage a + = AniMsg + { chatId :: ChatId, + animation :: a, + duration :: Maybe Integer, + width :: Maybe Integer, + height :: Maybe Integer, + caption :: Maybe Text, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (AnimationMessage a) + +data VoiceMessage a + = VoiceMsg + { chatId :: ChatId, + voice :: a, + duration :: Maybe Integer, + caption :: Maybe Text, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake (VoiceMessage a) + +data VNMessage a + = VNMsg + { chatId :: ChatId, + video_note :: Text, + duration :: Maybe Integer, + length :: Maybe Integer, + parseMode :: Maybe ParseMode, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving (ToJSON) via Snake (VNMessage a) + +data LocationMessage + = LocationMsg + { chatId :: ChatId, + latitude :: Float, + longitude :: Float, + livePeriod :: Maybe Integer, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake LocationMessage + +data LocationEdit + = LocationEdit + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + latitude :: Float, + longitude :: Float, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake LocationEdit + +data LocationStop + = LocationStop + { chatId :: Maybe ChatId, + messageId :: Maybe Integer, + inlineMessageId :: Maybe Text, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake LocationStop + +data VenueMessage + = VenueMessage + { chatId :: ChatId, + latitude :: Float, + longitude :: Float, + title :: Text, + address :: Text, + foursquareId :: Maybe Text, + foursquareType :: Maybe Text, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake VenueMessage + +data ContactMessage + = ContactMessage + { chatId :: ChatId, + phoneNumber :: Text, + firstName :: Text, + lastName :: Maybe Text, + vcard :: Maybe Text, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake ContactMessage + +data PollMessage + = PollMsg + { chatid :: ChatId, + question :: Text, + options :: [Text], + isAnonymous :: Bool, + pollType :: Maybe PollType, + allowsMultipleAnswers :: Maybe Bool, + correctOptionId :: Maybe Integer, + isClosed :: Maybe Bool, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via PrefixedSnake "poll" PollMessage + +data DiceMessage + = DiceMessage + { chatId :: ChatId, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake DiceMessage + +data ChatAction + = ChatAction + { chatId :: ChatId, + action :: Action + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via ChatAction + +data StickerMessage + = StickerMessage + { chatId :: ChatId, + sticker :: Text, + disableNotification :: Maybe Bool, + replyToMessageId :: Maybe Integer, + replyMarkup :: Maybe ReplyMarkup + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON) + via Snake StickerMessage diff --git a/src/Web/Telegram/API/Update.hs b/src/Web/Telegram/API/Update.hs new file mode 100644 --- /dev/null +++ b/src/Web/Telegram/API/Update.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeOperators #-} + +module Web.Telegram.API.Update where + +import Data.Text (Text) +import Deriving.Aeson +import Servant.API +import Web.Telegram.API.Common +import Web.Telegram.Types +import Web.Telegram.Types.Stock +import Web.Telegram.Types.Update +import Web.Telegram.Types.UpdateType + +data Polling + = Polling + { offset :: Maybe Integer, + limit :: Maybe Integer, + timeout :: Maybe Integer, + allowedUpdates :: Maybe Text + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON, FromJSON) + via Snake Polling + +data WebhookSetting + = WebhookSetting + { url :: Text, + maxConnections :: Maybe Integer, + allowedUpdates :: Maybe [UpdateType] + } + deriving (Show, Eq, Generic, Default) + deriving + (ToJSON, FromJSON) + via Snake WebhookSetting + +type GetUpdates = + Base + :> "getUpdates" + :> ReqBody '[JSON] Polling + :> Get '[JSON] (ReqResult [Update]) + +type SetWebhook = + Base + :> "setWebhook" + :> ReqBody '[JSON] WebhookSetting + :> Get '[JSON] (ReqResult Bool) + +type DeleteWebhook = + Base + :> "deleteWebhook" + :> Get '[JSON] (ReqResult Bool) + +type GetWebhookInfo = + Base + :> "getWebhookInfo" + :> Get '[JSON] (ReqResult WebhookInfo) diff --git a/telegram-raw-api.cabal b/telegram-raw-api.cabal new file mode 100644 --- /dev/null +++ b/telegram-raw-api.cabal @@ -0,0 +1,89 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 282bb771376474f83c73fb2c19027d63102ea658b203ce2b189f30c3c380d69f + +name: telegram-raw-api +version: 0.1.0 +synopsis: Servant bindings to the Telegram bot API +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/poscat0x04/telegram-raw-api#readme +bug-reports: https://github.com/poscat0x04/telegram-raw-api/issues +author: Poscat +maintainer: poscat@mail.poscat.moe +copyright: 2020 Poscat +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/poscat0x04/telegram-raw-api + +library + exposed-modules: + Web.Telegram.API.Actions + Web.Telegram.API.Actions.Data + Web.Telegram.API.Editing + Web.Telegram.API.Editing.Data + Web.Telegram.API.Sending + Web.Telegram.API.Sending.Data + Web.Telegram.API.CompoundParam + Web.Telegram.API.Getting + Web.Telegram.API.Lens + Web.Telegram.API.Update + Web.Telegram.API + other-modules: + Web.Telegram.API.Common + Paths_telegram_raw_api + hs-source-dirs: + src + build-depends: + aeson >=1.4.7 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10.10.0 && <0.11 + , connection >=0.3.1 && <0.4 + , deriving-aeson >=0.2.3 && <0.3 + , generic-lens >=1.2.0.1 && <1.3 + , http-media >=0.8.0.0 && <0.9 + , lens >=4.18.1 && <4.19 + , servant >=0.16.2 && <0.17 + , servant-client >=0.16.0.1 && <0.17 + , servant-multipart >=0.11.5 && <0.12 + , telegram-types >=0.1.0 && <0.2 + , text >=1.2.4.0 && <1.3 + default-language: Haskell2010 + +test-suite telegram-raw-api-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_telegram_raw_api + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.4.7 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10.10.0 && <0.11 + , connection >=0.3.1 && <0.4 + , deriving-aeson >=0.2.3 && <0.3 + , generic-lens >=1.2.0.1 && <1.3 + , http-client >=0.6.4.1 && <0.7 + , http-client-tls >=0.3.5.3 && <0.4 + , http-media >=0.8.0.0 && <0.9 + , lens >=4.18.1 && <4.19 + , servant >=0.16.2 && <0.17 + , servant-client >=0.16.0.1 && <0.17 + , servant-client-core >=0.16 && <0.17 + , servant-multipart >=0.11.5 && <0.12 + , telegram-raw-api + , telegram-types >=0.1.0 && <0.2 + , text >=1.2.4.0 && <1.3 + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +module Main where + +main = return ()