module Web.Telegram.API.Bot.Requests
(
SendMessageRequest (..)
, ForwardMessageRequest (..)
, FileUpload (..)
, FileUploadContent (..)
, SendPhotoRequest (..)
, SendAudioRequest (..)
, SendDocumentRequest (..)
, SendStickerRequest (..)
, SendVideoRequest (..)
, SendVoiceRequest (..)
, SendLocationRequest (..)
, SendVenueRequest (..)
, SendContactRequest (..)
, SendChatActionRequest (..)
, ChatAction (..)
, AnswerInlineQueryRequest (..)
, AnswerCallbackQueryRequest (..)
, ReplyKeyboard (..)
, EditMessageTextRequest (..)
, EditMessageCaptionRequest (..)
, EditMessageReplyMarkupRequest (..)
, localFileUpload
, sendMessageRequest
, forwardMessageRequest
, sendPhotoRequest
, uploadPhotoRequest
, sendAudioRequest
, uploadAudioRequest
, sendDocumentRequest
, uploadDocumentRequest
, sendStickerRequest
, uploadStickerRequest
, sendVideoRequest
, uploadVideoRequest
, sendVoiceRequest
, uploadVoiceRequest
, sendLocationRequest
, sendVenueRequest
, sendContactRequest
, sendChatActionRequest
, answerInlineQueryRequest
, answerCallbackQueryRequest
, inlineKeyboardMarkup
, replyKeyboardMarkup
, replyKeyboardHide
, forceReply
, editMessageTextRequest
, editInlineMessageTextRequest
, editMessageCaptionRequest
, editInlineMessageCaptionRequest
, editMessageReplyMarkupRequest
, editInlineMessageReplyMarkupRequest
) where
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.Generics
import Network.HTTP.Client.MultipartFormData
import Network.Mime
import Servant.Client.MultipartFormData (ToMultipartFormData (..))
import Web.Telegram.API.Bot.JsonExt
import Web.Telegram.API.Bot.Data
data FileUploadContent =
FileUploadFile FilePath
| FileUploadBS BS.ByteString
| FileUploadLBS LBS.ByteString
data FileUpload = FileUpload
{
fileUpload_type :: Maybe MimeType
, fileUpload_content :: FileUploadContent
}
localFileUpload :: FilePath -> FileUpload
localFileUpload path =
FileUpload
{ fileUpload_type = Nothing
, fileUpload_content = FileUploadFile path
}
fileUploadToPart :: Text -> FileUpload -> Part
fileUploadToPart inputName fileUpload =
let part =
case fileUpload_content fileUpload of
FileUploadFile path -> partFileSource inputName path
FileUploadBS bs -> partBS inputName bs
FileUploadLBS lbs -> partLBS inputName lbs
in part { partContentType = fileUpload_type fileUpload }
utf8Part :: Text -> Text -> Part
utf8Part inputName = partBS inputName . T.encodeUtf8
data SendMessageRequest = SendMessageRequest
{
message_chat_id :: Text
, message_text :: Text
, message_parse_mode :: Maybe ParseMode
, message_disable_web_page_preview :: Maybe Bool
, message_disable_notification :: Maybe Bool
, message_reply_to_message_id :: Maybe Int
, message_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON SendMessageRequest where
toJSON = toJsonDrop 8
instance FromJSON SendMessageRequest where
parseJSON = parseJsonDrop 8
sendMessageRequest :: Text -> Text -> SendMessageRequest
sendMessageRequest chatId text = SendMessageRequest chatId text Nothing Nothing Nothing Nothing Nothing
data ForwardMessageRequest = ForwardMessageRequest
{
forward_chat_id :: Text
, forward_from_chat_id :: Text
, forward_disable_notification :: Maybe Bool
, forward_message_id :: Int
} deriving (Show, Generic)
instance ToJSON ForwardMessageRequest where
toJSON = toJsonDrop 8
instance FromJSON ForwardMessageRequest where
parseJSON = parseJsonDrop 8
forwardMessageRequest :: Text -> Text -> Int -> ForwardMessageRequest
forwardMessageRequest chatId fromChatId forwardMessageId = ForwardMessageRequest chatId fromChatId Nothing forwardMessageId
data SendPhotoRequest payload = SendPhotoRequest
{
photo_chat_id :: Text
, photo_photo :: payload
, photo_caption :: Maybe Text
, photo_disable_notification :: Maybe Bool
, photo_reply_to_message_id :: Maybe Int
, photo_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendPhotoRequest Text) where
toJSON = toJsonDrop 6
instance FromJSON (SendPhotoRequest Text) where
parseJSON = parseJsonDrop 6
sendPhotoRequest :: Text -> Text -> SendPhotoRequest Text
sendPhotoRequest chatId photo = SendPhotoRequest chatId photo Nothing Nothing Nothing Nothing
uploadPhotoRequest :: Text -> FileUpload -> SendPhotoRequest FileUpload
uploadPhotoRequest chatId photo = SendPhotoRequest chatId photo Nothing Nothing Nothing Nothing
instance ToMultipartFormData (SendPhotoRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (photo_chat_id req) ] ++
catMaybes
[ utf8Part "caption" <$> photo_caption req
, partLBS "disable_notification" . encode <$> photo_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> photo_reply_to_message_id req
, partLBS "reply_markup" . encode <$> photo_reply_markup req
] ++
[ fileUploadToPart "photo" (photo_photo req) ]
data SendAudioRequest payload = SendAudioRequest
{
_audio_chat_id :: Text
, _audio_audio :: payload
, _audio_duration :: Maybe Int
, _audio_performer :: Maybe Text
, _audio_title :: Maybe Text
, _audio_disable_notification :: Maybe Bool
, _audio_reply_to_message_id :: Maybe Int
, _audio_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendAudioRequest Text) where
toJSON = toJsonDrop 7
instance FromJSON (SendAudioRequest Text) where
parseJSON = parseJsonDrop 7
instance ToMultipartFormData (SendAudioRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (_audio_chat_id req) ] ++
catMaybes
[ utf8Part "duration" . T.pack . show <$> _audio_duration req
, utf8Part "performer" <$> _audio_performer req
, utf8Part "title" <$> _audio_title req
, partLBS "disable_notification" . encode <$> _audio_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> _audio_reply_to_message_id req
, partLBS "reply_markup" . encode <$> _audio_reply_markup req
] ++
[ fileUploadToPart "audio" (_audio_audio req) ]
sendAudioRequest :: Text -> Text -> SendAudioRequest Text
sendAudioRequest chatId audio = SendAudioRequest chatId audio Nothing Nothing Nothing Nothing Nothing Nothing
uploadAudioRequest :: Text -> FileUpload -> SendAudioRequest FileUpload
uploadAudioRequest chatId audio = SendAudioRequest chatId audio Nothing Nothing Nothing Nothing Nothing Nothing
data SendStickerRequest payload = SendStickerRequest
{
sticker_chat_id :: Text
, sticker_sticker :: payload
, sticker_disable_notification :: Maybe Bool
, sticker_reply_to_message_id :: Maybe Int
, sticker_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendStickerRequest Text) where
toJSON = toJsonDrop 8
instance FromJSON (SendStickerRequest Text) where
parseJSON = parseJsonDrop 8
instance ToMultipartFormData (SendStickerRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (sticker_chat_id req) ] ++
catMaybes
[ partLBS "disable_notification" . encode <$> sticker_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> sticker_reply_to_message_id req
, partLBS "reply_markup" . encode <$> sticker_reply_markup req
] ++
[ fileUploadToPart "sticker" (sticker_sticker req) ]
sendStickerRequest :: Text -> Text -> SendStickerRequest Text
sendStickerRequest chatId sticker = SendStickerRequest chatId sticker Nothing Nothing Nothing
uploadStickerRequest :: Text -> FileUpload -> SendStickerRequest FileUpload
uploadStickerRequest chatId sticker = SendStickerRequest chatId sticker Nothing Nothing Nothing
data SendDocumentRequest payload = SendDocumentRequest
{
document_chat_id :: Text
, document_document :: payload
, document_caption :: Maybe Text
, document_disable_notification :: Maybe Bool
, document_reply_to_message_id :: Maybe Int
, document_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendDocumentRequest Text) where
toJSON = toJsonDrop 9
instance FromJSON (SendDocumentRequest Text) where
parseJSON = parseJsonDrop 9
instance ToMultipartFormData (SendDocumentRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (document_chat_id req) ] ++
catMaybes
[ utf8Part "caption" <$> document_caption req
, partLBS "disable_notification" . encode <$> document_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> document_reply_to_message_id req
, partLBS "reply_markup" . encode <$> document_reply_markup req
] ++
[ fileUploadToPart "document" (document_document req) ]
sendDocumentRequest :: Text -> Text -> SendDocumentRequest Text
sendDocumentRequest chatId document = SendDocumentRequest chatId document Nothing Nothing Nothing Nothing
uploadDocumentRequest :: Text -> FileUpload -> SendDocumentRequest FileUpload
uploadDocumentRequest chatId document = SendDocumentRequest chatId document Nothing Nothing Nothing Nothing
data SendVideoRequest payload = SendVideoRequest
{
_video_chat_id :: Text
, _video_video :: payload
, _video_duration :: Maybe Int
, _video_caption :: Maybe Text
, _video_disable_notification :: Maybe Bool
, _video_reply_to_message_id :: Maybe Int
, _video_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendVideoRequest Text) where
toJSON = toJsonDrop 7
instance FromJSON (SendVideoRequest Text) where
parseJSON = parseJsonDrop 7
instance ToMultipartFormData (SendVideoRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (_video_chat_id req) ] ++
catMaybes
[ partLBS "duration" . encode <$> _video_duration req
, utf8Part "caption" <$> _video_caption req
, partLBS "disable_notification" . encode <$> _video_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> _video_reply_to_message_id req
, partLBS "reply_markup" . encode <$> _video_reply_markup req
] ++
[ fileUploadToPart "video" (_video_video req) ]
sendVideoRequest :: Text -> Text -> SendVideoRequest Text
sendVideoRequest chatId video = SendVideoRequest chatId video Nothing Nothing Nothing Nothing Nothing
uploadVideoRequest :: Text -> FileUpload -> SendVideoRequest FileUpload
uploadVideoRequest chatId video = SendVideoRequest chatId video Nothing Nothing Nothing Nothing Nothing
data SendVoiceRequest payload = SendVoiceRequest
{
_voice_chat_id :: Text
, _voice_voice :: payload
, _voice_duration :: Maybe Int
, _voice_disable_notification :: Maybe Bool
, _voice_reply_to_message_id :: Maybe Int
, _voice_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON (SendVoiceRequest Text) where
toJSON = toJsonDrop 7
instance FromJSON (SendVoiceRequest Text) where
parseJSON = parseJsonDrop 7
instance ToMultipartFormData (SendVoiceRequest FileUpload) where
toMultipartFormData req =
[ utf8Part "chat_id" (_voice_chat_id req) ] ++
catMaybes
[ partLBS "duration" . encode <$> _voice_duration req
, partLBS "disable_notification" . encode <$> _voice_disable_notification req
, utf8Part "reply_to_message_id" . T.pack . show <$> _voice_reply_to_message_id req
, partLBS "reply_markup" . encode <$> _voice_reply_markup req
] ++
[ fileUploadToPart "voice" (_voice_voice req) ]
sendVoiceRequest :: Text -> Text -> SendVoiceRequest Text
sendVoiceRequest chatId voice = SendVoiceRequest chatId voice Nothing Nothing Nothing Nothing
uploadVoiceRequest :: Text -> FileUpload -> SendVoiceRequest FileUpload
uploadVoiceRequest chatId voice = SendVoiceRequest chatId voice Nothing Nothing Nothing Nothing
data SendLocationRequest = SendLocationRequest
{
location_chat_id :: Text
, location_latitude :: Float
, location_longitude :: Float
, location_disable_notification :: Maybe Bool
, location_reply_to_message_id :: Maybe Int
, location_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON SendLocationRequest where
toJSON = toJsonDrop 9
instance FromJSON SendLocationRequest where
parseJSON = parseJsonDrop 9
sendLocationRequest :: Text -> Float -> Float -> SendLocationRequest
sendLocationRequest chatId latitude longitude = SendLocationRequest chatId latitude longitude Nothing Nothing Nothing
data SendVenueRequest = SendVenueRequest
{
_venue_chat_id :: Text
, _venue_latitude :: Float
, _venue_longitude :: Float
, _venue_title :: Text
, _venue_address :: Text
, _venue_foursquare_id :: Maybe Text
, _venue_disable_notification :: Maybe Bool
, _venue_reply_to_message_id :: Maybe Int
, _venue_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON SendVenueRequest where
toJSON = toJsonDrop 7
instance FromJSON SendVenueRequest where
parseJSON = parseJsonDrop 7
sendVenueRequest :: Text -> Float -> Float -> Text -> Text -> SendVenueRequest
sendVenueRequest chatId latitude longitude title address = SendVenueRequest chatId latitude longitude title address Nothing Nothing Nothing Nothing
data SendContactRequest = SendContactRequest
{
_contact_chat_id :: Text
, _contact_phone_number :: Text
, _contact_first_name :: Text
, _contact_last_name :: Maybe Text
, _contact_disable_notification :: Maybe Bool
, _contact_reply_to_message_id :: Maybe Int
, _contact_reply_markup :: Maybe ReplyKeyboard
} deriving (Show, Generic)
instance ToJSON SendContactRequest where
toJSON = toJsonDrop 9
instance FromJSON SendContactRequest where
parseJSON = parseJsonDrop 9
sendContactRequest :: Text -> Text -> Text -> SendContactRequest
sendContactRequest chatId phoneNumber firstName = SendContactRequest chatId phoneNumber firstName Nothing Nothing Nothing Nothing
data ChatAction = Typing
| UploadPhoto
| RecordVideo
| UploadVideo
| RecordAudio
| UploadAudio
| UploadDocument
| FindLocation deriving (Show, Generic)
instance ToJSON ChatAction where
toJSON Typing = "typing"
toJSON UploadPhoto = "upload_photo"
toJSON RecordVideo = "record_video"
toJSON UploadVideo = "upload_video"
toJSON RecordAudio = "record_audio"
toJSON UploadAudio = "upload_audio"
toJSON UploadDocument = "upload_document"
toJSON FindLocation = "find_location"
instance FromJSON ChatAction where
parseJSON "typing" = pure Typing
parseJSON "upload_photo" = pure UploadPhoto
parseJSON "record_video" = pure RecordVideo
parseJSON "upload_video" = pure UploadVideo
parseJSON "record_audio" = pure RecordAudio
parseJSON "upload_audio" = pure UploadAudio
parseJSON "upload_document" = pure UploadDocument
parseJSON "find_location" = pure FindLocation
parseJSON _ = fail "Failed to parse ChatAction"
data SendChatActionRequest = SendChatActionRequest
{
action_chat_id :: Text
, action_action :: ChatAction
} deriving (Show, Generic)
instance ToJSON SendChatActionRequest where
toJSON = toJsonDrop 7
instance FromJSON SendChatActionRequest where
parseJSON = parseJsonDrop 7
sendChatActionRequest :: Text -> ChatAction -> SendChatActionRequest
sendChatActionRequest chatId action = SendChatActionRequest chatId action
data AnswerInlineQueryRequest = AnswerInlineQueryRequest
{
query_inline_query_id :: Text
, query_results :: [InlineQueryResult]
, query_cache_time :: Maybe Int
, query_is_personal :: Maybe Bool
, query_next_offset :: Maybe Text
, query_switch_pm_text :: Maybe Text
, query_switch_pm_parameter :: Maybe Text
} deriving (Show, Generic)
instance ToJSON AnswerInlineQueryRequest where
toJSON = toJsonDrop 6
instance FromJSON AnswerInlineQueryRequest where
parseJSON = parseJsonDrop 6
answerInlineQueryRequest :: Text -> [InlineQueryResult] -> AnswerInlineQueryRequest
answerInlineQueryRequest queryId results = AnswerInlineQueryRequest queryId results Nothing Nothing Nothing Nothing Nothing
data AnswerCallbackQueryRequest = AnswerCallbackQueryRequest
{
cq_callback_query_id :: Text
, cq_text :: Maybe Text
, cq_show_alert :: Maybe Bool
} deriving (Show, Generic)
instance ToJSON AnswerCallbackQueryRequest where
toJSON = toJsonDrop 3
instance FromJSON AnswerCallbackQueryRequest where
parseJSON = parseJsonDrop 3
answerCallbackQueryRequest :: Text -> AnswerCallbackQueryRequest
answerCallbackQueryRequest chatId = AnswerCallbackQueryRequest chatId Nothing Nothing
data ReplyKeyboard =
ReplyInlineKeyboardMarkup
{
reply_inline_keyboard :: [[InlineKeyboardButton]]
}
| ReplyKeyboardMarkup
{
reply_keyboard :: [[KeyboardButton]]
, reply_resize_keyboard :: Maybe Bool
, reply_one_time_keyboard :: Maybe Bool
, reply_selective :: Maybe Bool
}
| ReplyKeyboardHide
{
reply_hide_keyboard :: Bool
, reply_selective :: Maybe Bool
}
| ForceReply
{
reply_force_reply :: Bool
, reply_selective :: Maybe Bool
} deriving (Show, Generic)
instance ToJSON ReplyKeyboard where
toJSON = toJsonDrop 6
instance FromJSON ReplyKeyboard where
parseJSON = parseJsonDrop 6
inlineKeyboardMarkup :: [[InlineKeyboardButton]] -> ReplyKeyboard
inlineKeyboardMarkup = ReplyInlineKeyboardMarkup
replyKeyboardMarkup :: [[KeyboardButton]] -> ReplyKeyboard
replyKeyboardMarkup keyboard = ReplyKeyboardMarkup keyboard Nothing Nothing Nothing
replyKeyboardHide :: ReplyKeyboard
replyKeyboardHide = ReplyKeyboardHide True Nothing
forceReply :: ReplyKeyboard
forceReply = ForceReply True Nothing
data EditMessageTextRequest = EditMessageTextRequest
{
emt_chat_id :: Maybe Text
, emt_message_id :: Maybe Int
, emt_inline_message_id :: Maybe Text
, emt_text :: Text
, emt_parse_mode :: Maybe ParseMode
, emt_disable_web_page_preview :: Maybe Bool
, emt_reply_markup :: Maybe InlineKeyboardMarkup
} deriving (Show, Generic)
instance ToJSON EditMessageTextRequest where
toJSON = toJsonDrop 4
instance FromJSON EditMessageTextRequest where
parseJSON = parseJsonDrop 4
editMessageTextRequest :: Text -> Int -> Text -> EditMessageTextRequest
editMessageTextRequest chatId messageId text = EditMessageTextRequest (Just chatId) (Just messageId) Nothing text Nothing Nothing Nothing
editInlineMessageTextRequest :: Text -> Text -> EditMessageTextRequest
editInlineMessageTextRequest inlineMessageId text = EditMessageTextRequest Nothing Nothing (Just inlineMessageId) text Nothing Nothing Nothing
data EditMessageCaptionRequest = EditMessageCaptionRequest
{
emc_chat_id :: Maybe Text
, emc_message_id :: Maybe Int
, emc_inline_message_id :: Maybe Text
, emc_caption :: Maybe Text
, emc_reply_markup :: Maybe InlineKeyboardMarkup
} deriving (Show, Generic)
instance ToJSON EditMessageCaptionRequest where
toJSON = toJsonDrop 4
instance FromJSON EditMessageCaptionRequest where
parseJSON = parseJsonDrop 4
editMessageCaptionRequest :: Text -> Int -> Maybe Text -> EditMessageCaptionRequest
editMessageCaptionRequest chatId messageId caption = EditMessageCaptionRequest (Just chatId) (Just messageId) Nothing caption Nothing
editInlineMessageCaptionRequest :: Text -> Maybe Text -> EditMessageCaptionRequest
editInlineMessageCaptionRequest inlineMessageId caption = EditMessageCaptionRequest Nothing Nothing (Just inlineMessageId) caption Nothing
data EditMessageReplyMarkupRequest = EditMessageReplyMarkupRequest
{
emrm_chat_id :: Maybe Text
, emrm_message_id :: Maybe Int
, emrm_inline_message_id :: Maybe Text
, emrm_reply_markup :: Maybe InlineKeyboardMarkup
} deriving (Show, Generic)
instance ToJSON EditMessageReplyMarkupRequest where
toJSON = toJsonDrop 5
instance FromJSON EditMessageReplyMarkupRequest where
parseJSON = parseJsonDrop 5
editMessageReplyMarkupRequest :: Text -> Int -> Maybe InlineKeyboardMarkup -> EditMessageReplyMarkupRequest
editMessageReplyMarkupRequest chatId messageId keyboard = EditMessageReplyMarkupRequest (Just chatId) (Just messageId) Nothing keyboard
editInlineMessageReplyMarkupRequest :: Text -> Maybe InlineKeyboardMarkup -> EditMessageReplyMarkupRequest
editInlineMessageReplyMarkupRequest inlineMessageId keyboard = EditMessageReplyMarkupRequest Nothing Nothing (Just inlineMessageId) keyboard