diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,27 @@ +0.2.0 +--- + +* Major changes: + - Add bot jobs support (see [`9e0424e`](https://github.com/fizruk/telegram-bot-simple/commit/9e0424e)); + - Add `Telegram.Bot.Simple.Debug` (see [`7db84c5`](https://github.com/fizruk/telegram-bot-simple/commit/7db84c5), + [`49679d4`](https://github.com/fizruk/telegram-bot-simple/commit/49679d4), + [`5ba949b`](https://github.com/fizruk/telegram-bot-simple/commit/5ba949b)); + - Introduce `BotEnv` with model state and action queue (see [`98c869a`](https://github.com/fizruk/telegram-bot-simple/commit/98c869a)); + - Add support for message editing (see [`b7c83a4`](https://github.com/fizruk/telegram-bot-simple/commit/b7c83a4)); + - Introduce `replyOrEdit` helper (see [`ecc21cd`](https://github.com/fizruk/telegram-bot-simple/commit/ecc21cd)); + - Add useLatestUpdateInJobs helper to enable reply in jobs (see [`385f9e6`](https://github.com/fizruk/telegram-bot-simple/commit/385f9e6), + [`8a12ceb`](https://github.com/fizruk/telegram-bot-simple/commit/8a12ceb), + [`448bcd2`](https://github.com/fizruk/telegram-bot-simple/commit/448bcd2)); + +* Minor changes: + - Add `getEnvToken` helper (see [`ce7d1f7`](https://github.com/fizruk/telegram-bot-simple/commit/ce7d1f7)); + - Add `IsString` instance for `Telegram.Token` (see [`f105bb9`](https://github.com/fizruk/telegram-bot-simple/commit/f105bb9)); + - Print Servant errors when `getUpdates` fails (see [`bc7c5bb`](https://github.com/fizruk/telegram-bot-simple/commit/bc7c5bb)); + - Split `Telegram.Bot.Simple` into several submodules (see [`8ed2783`](https://github.com/fizruk/telegram-bot-simple/commit/8ed2783)); + - Add `withEffect` helper in `Telegram.Bot.Simple.Eff` (see [`aebba52`](https://github.com/fizruk/telegram-bot-simple/commit/aebba52)); + - More Haddock documentation; + +* Fixes: + - Resolve #7 (see [#8](https://github.com/fizruk/telegram-bot-simple/pull/8)); + - Fix undefined in startBotAsync and add more documentation (see [`7879066`](https://github.com/fizruk/telegram-bot-simple/commit/7879066)); + - Fix inline buttons issue (see [#10](https://github.com/fizruk/telegram-bot-simple/pull/10)); diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2017, Nickolay Kudasov +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 the copyright holder nor the names of its + 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 HOLDER 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,18 @@ +# telegram-bot-simple + +Easy to use library for building Telegram bots in Haskell. + +_**Disclaimer:** this library is under development. +It is usable for most stuff, but is still far from a stable release._ + +## LambdaConf 2018 workshop + +This library was featured in a [LambdaConf 2018 workshop](https://lambdaconf2018.dryfta.com/en/program-schedule/program/32/building-a-telegram-bot-in-haskell). +The supplementary materials for the workshop is available at https://github.com/fizruk/lambdaconf-2018-workshop. + +## Contributing + +Contributions are welcome! +Feel free to ping me on GitHub, file an issue or submit a PR :) + +_Nick_ diff --git a/examples/EchoBot.hs b/examples/EchoBot.hs new file mode 100644 --- /dev/null +++ b/examples/EchoBot.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Telegram.Bot.API +import Telegram.Bot.Simple +import Telegram.Bot.Simple.UpdateParser (updateMessageText) + +type Model = () + +data Action + = NoOp + | Echo Text + +echoBot :: BotApp Model Action +echoBot = BotApp + { botInitialModel = () + , botAction = updateToAction + , botHandler = handleAction + , botJobs = [] + } + +updateToAction :: Update -> Model -> Maybe Action +updateToAction update _ = + case updateMessageText update of + Just text -> Just (Echo text) + Nothing -> Nothing + +handleAction :: Action -> Model -> Eff Action Model +handleAction action model = case action of + NoOp -> pure model + Echo msg -> model <# do + replyText msg + return NoOp + +run :: Token -> IO () +run token = do + env <- defaultTelegramClientEnv token + startBot_ (conversationBot updateChatId echoBot) env + +main :: IO () +main = do + putStrLn "Please, enter Telegram bot's API token:" + token <- Token . Text.pack <$> getLine + run token diff --git a/src/Telegram/Bot/API.hs b/src/Telegram/Bot/API.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API.hs @@ -0,0 +1,30 @@ +module Telegram.Bot.API ( + -- * Making requests + module Telegram.Bot.API.MakingRequests, + -- * Getting updates + module Telegram.Bot.API.GettingUpdates, + -- * Available types + module Telegram.Bot.API.Types, + -- * Available methods + module Telegram.Bot.API.Methods, + -- * Updating messages + module Telegram.Bot.API.UpdatingMessages, +-- -- * Stickers +-- module Telegram.Bot.API.Stickers, +-- -- * Inline mode +-- module Telegram.Bot.API.InlineMode, +-- -- * Payments +-- module Telegram.Bot.API.Payments, +-- -- * Games +-- module Telegram.Bot.API.Games, +) where + +import Telegram.Bot.API.GettingUpdates +import Telegram.Bot.API.MakingRequests +import Telegram.Bot.API.Methods +import Telegram.Bot.API.Types +import Telegram.Bot.API.UpdatingMessages +-- import Telegram.Bot.API.Stickers +-- import Telegram.Bot.API.InlineMode +-- import Telegram.Bot.API.Payments +-- import Telegram.Bot.API.Games diff --git a/src/Telegram/Bot/API/Games.hs b/src/Telegram/Bot/API/Games.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Games.hs @@ -0,0 +1,1 @@ +module Telegram.Bot.API.Games where diff --git a/src/Telegram/Bot/API/GettingUpdates.hs b/src/Telegram/Bot/API/GettingUpdates.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/GettingUpdates.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Telegram.Bot.API.GettingUpdates where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Foldable (asum) +import Data.Int (Int32) +import Data.Proxy +import GHC.Generics (Generic) + +import Servant.API +import Servant.Client hiding (Response) + +import Telegram.Bot.API.Internal.Utils +import Telegram.Bot.API.MakingRequests +import Telegram.Bot.API.Types + +-- ** 'Update' + +newtype UpdateId = UpdateId Int32 + deriving (Eq, Ord, Show, ToJSON, FromJSON) + +-- | This object represents an incoming update. +-- At most __one__ of the optional parameters can be present in any given update. +data Update = Update + { updateUpdateId :: UpdateId -- ^ The update‘s unique identifier. Update identifiers start from a certain positive number and increase sequentially. This ID becomes especially handy if you’re using Webhooks, since it allows you to ignore repeated updates or to restore the correct update sequence, should they get out of order. If there are no new updates for at least a week, then identifier of the next update will be chosen randomly instead of sequentially. + , updateMessage :: Maybe Message -- ^ New incoming message of any kind — text, photo, sticker, etc. + , updateEditedMessage :: Maybe Message -- ^ New version of a message that is known to the bot and was edited + , updateChannelPost :: Maybe Message -- ^ New incoming channel post of any kind — text, photo, sticker, etc. + , updateEditedChannelPost :: Maybe Message -- ^ New version of a channel post that is known to the bot and was edited + +-- , updateInlineQuery :: Maybe InlineQuery -- ^ New incoming inline query +-- , updateChosenInlineResult :: Maybe ChosenInlineResult -- ^ The result of an inline query that was chosen by a user and sent to their chat partner. Please see our documentation on the feedback collecting for details on how to enable these updates for your bot. + + , updateCallbackQuery :: Maybe CallbackQuery -- ^ New incoming callback query + +-- , updateShippingQuery :: Maybe ShippingQuery -- ^ New incoming shipping query. Only for invoices with flexible price +-- , updatePreCheckoutQuery :: Maybe PreCheckoutQuery -- ^ New incoming pre-checkout query. Contains full information about checkout + } deriving (Generic, Show) + +instance ToJSON Update where toJSON = gtoJSON +instance FromJSON Update where parseJSON = gparseJSON + +updateChatId :: Update -> Maybe ChatId +updateChatId = fmap (chatId . messageChat) . extractUpdateMessage + +extractUpdateMessage :: Update -> Maybe Message +extractUpdateMessage Update{..} = asum + [ updateMessage + , updateEditedMessage + , updateChannelPost + , updateEditedChannelPost + , updateCallbackQuery >>= callbackQueryMessage + ] + +-- ** 'getUpdates' + +type GetUpdates + = "getUpdates" :> ReqBody '[JSON] GetUpdatesRequest :> Get '[JSON] (Response [Update]) + +-- | Use this method to receive incoming updates using long polling. +-- An list of 'Update' objects is returned. +-- +-- NOTE: This method will not work if an outgoing webhook is set up. +-- +-- NOTE: In order to avoid getting duplicate updates, recalculate offset after each server response. +getUpdates :: GetUpdatesRequest -> ClientM (Response [Update]) +getUpdates = client (Proxy @GetUpdates) + +-- | Request parameters for 'getUpdates'. +data GetUpdatesRequest = GetUpdatesRequest + { getUpdatesOffset :: Maybe UpdateId -- ^ Identifier of the first update to be returned. Must be greater by one than the highest among the identifiers of previously received updates. By default, updates starting with the earliest unconfirmed update are returned. An update is considered confirmed as soon as getUpdates is called with an offset higher than its update_id. The negative offset can be specified to retrieve updates starting from -offset update from the end of the updates queue. All previous updates will forgotten. + , getUpdatesLimit :: Maybe Int32 -- ^ Limits the number of updates to be retrieved. Values between 1—100 are accepted. Defaults to 100. + , getUpdatesTimeout :: Maybe Seconds -- ^ Timeout in seconds for long polling. Defaults to 0, i.e. usual short polling. Should be positive, short polling should be used for testing purposes only. + , getUpdatesAllowedUpdates :: Maybe [UpdateType] -- ^ List the types of updates you want your bot to receive. For example, specify [“message”, “edited_channel_post”, “callback_query”] to only receive updates of these types. See GetUpdates for a complete list of available update types. Specify an empty list to receive all updates regardless of type (default). If not specified, the previous setting will be used. Please note that this parameter doesn't affect updates created before the call to the getUpdates, so unwanted updates may be received for a short period of time. + } deriving (Generic) + +instance ToJSON GetUpdatesRequest where toJSON = gtoJSON +instance FromJSON GetUpdatesRequest where parseJSON = gparseJSON + +data UpdateType + = UpdateMessage + | UpdateEditedMessage + | UpdateChannelPost + | UpdateEditedChannelPost + | UpdateInlineQuery + | UpdateChosenInlineResult + | UpdateCallbackQuery + | UpdateShippingQuery + | UpdatePreCheckoutQuery + deriving (Generic) + +instance ToJSON UpdateType where toJSON = gtoJSON +instance FromJSON UpdateType where parseJSON = gparseJSON diff --git a/src/Telegram/Bot/API/InlineMode.hs b/src/Telegram/Bot/API/InlineMode.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/InlineMode.hs @@ -0,0 +1,1 @@ +module Telegram.Bot.API.InlineMode where diff --git a/src/Telegram/Bot/API/Internal/Utils.hs b/src/Telegram/Bot/API/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Internal/Utils.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Telegram.Bot.API.Internal.Utils where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), GToJSON, GFromJSON, genericToJSON, genericParseJSON, Zero) +import Data.Aeson.TH (deriveJSON) +import Data.Aeson.Types (Options(..), defaultOptions, Parser) +import Data.Char (isUpper, toUpper, toLower) +import Data.List (intercalate) +import GHC.Generics +import Language.Haskell.TH + +deriveJSON' :: Name -> Q [Dec] +deriveJSON' name = deriveJSON (jsonOptions (nameBase name)) name + +gtoJSON :: forall a d f. (Generic a, GToJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) + => a -> Value +gtoJSON = genericToJSON (jsonOptions (datatypeName (Proxy3 :: Proxy3 d f a))) + +gparseJSON :: forall a d f. (Generic a, GFromJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) + => Value -> Parser a +gparseJSON = genericParseJSON (jsonOptions (datatypeName (Proxy3 :: Proxy3 d f a))) + + +genericSomeToJSON :: (Generic a, GSomeJSON (Rep a)) => a -> Value +genericSomeToJSON = gsomeToJSON . from + +genericSomeParseJSON :: (Generic a, GSomeJSON (Rep a)) => Value -> Parser a +genericSomeParseJSON = fmap to . gsomeParseJSON + +data Proxy3 d f a = Proxy3 + +jsonOptions :: String -> Options +jsonOptions tname = defaultOptions + { fieldLabelModifier = snakeFieldModifier tname + , constructorTagModifier = snakeFieldModifier tname + , omitNothingFields = True + } + +snakeFieldModifier :: String -> String -> String +snakeFieldModifier xs ys = wordsToSnake (stripCommonPrefixWords xs ys) + +camelWords :: String -> [String] +camelWords "" = [] +camelWords s + = case us of + (_:_:_) -> us : camelWords restLs + _ -> (us ++ ls) : camelWords rest + where + (us, restLs) = span isUpper s + (ls, rest) = break isUpper restLs + +stripCommonPrefix :: Eq a => [a] -> [a] -> [a] +stripCommonPrefix (x:xs) (y:ys) | x == y = stripCommonPrefix xs ys +stripCommonPrefix _ ys = ys + +wordsToCamel :: [String] -> String +wordsToCamel [] = "" +wordsToCamel (w:ws) = map toLower w ++ concatMap capitalise ws + +wordsToSnake :: [String] -> String +wordsToSnake = intercalate "_" . map (map toLower) + +capitalise :: String -> String +capitalise (c:s) = toUpper c : s +capitalise "" = "" + +stripCommonPrefixWords :: String -> String -> [String] +stripCommonPrefixWords xs ys = + stripCommonPrefix (camelWords xs) (camelWords (capitalise ys)) + + +class GSomeJSON f where + gsomeToJSON :: f p -> Value + gsomeParseJSON :: Value -> Parser (f p) + +instance GSomeJSON f => GSomeJSON (D1 d f) where + gsomeToJSON (M1 x) = gsomeToJSON x + gsomeParseJSON js = M1 <$> gsomeParseJSON js + +instance (ToJSON a, FromJSON a) => GSomeJSON (C1 c (S1 s (K1 i a))) where + gsomeToJSON (M1 (M1 (K1 x))) = toJSON x + gsomeParseJSON js = (M1 . M1 . K1) <$> parseJSON js + +instance (GSomeJSON f, GSomeJSON g) => GSomeJSON (f :+: g) where + gsomeToJSON (L1 x) = gsomeToJSON x + gsomeToJSON (R1 y) = gsomeToJSON y + + gsomeParseJSON js + = L1 <$> gsomeParseJSON js + <|> R1 <$> gsomeParseJSON js diff --git a/src/Telegram/Bot/API/MakingRequests.hs b/src/Telegram/Bot/API/MakingRequests.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/MakingRequests.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Telegram.Bot.API.MakingRequests where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Monoid ((<>)) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Servant.Client hiding (Response) +import Web.HttpApiData (FromHttpApiData, + ToHttpApiData (..)) + +import Telegram.Bot.API.Internal.Utils +import Telegram.Bot.API.Types + +botBaseUrl :: Token -> BaseUrl +botBaseUrl token = BaseUrl Https "api.telegram.org" 443 + (Text.unpack ("/bot" <> toUrlPiece token)) + +defaultTelegramClientEnv :: Token -> IO ClientEnv +defaultTelegramClientEnv token = ClientEnv + <$> newManager tlsManagerSettings + <*> pure (botBaseUrl token) + <*> pure Nothing + +defaultRunBot :: Token -> ClientM a -> IO (Either ServantError a) +defaultRunBot token bot = do + env <- defaultTelegramClientEnv token + runClientM bot env + +data Response a = Response + { responseOk :: Bool + , responseDescription :: Maybe Text + , responseResult :: a + , responseErrorCode :: Maybe Integer + , responseParameters :: Maybe ResponseParameters + } deriving (Show, Generic) + +instance ToJSON a => ToJSON (Response a) where toJSON = gtoJSON +instance FromJSON a => FromJSON (Response a) where parseJSON = gparseJSON + +newtype Token = Token Text + deriving (Eq, Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, IsString) diff --git a/src/Telegram/Bot/API/Methods.hs b/src/Telegram/Bot/API/Methods.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Methods.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Telegram.Bot.API.Methods where + +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.API +import Servant.Client hiding (Response) + +import Telegram.Bot.API.Internal.Utils +import Telegram.Bot.API.MakingRequests +import Telegram.Bot.API.Types + +-- * Available methods + +-- ** 'getMe' + +type GetMe = "getMe" :> Get '[JSON] (Response User) + +-- | A simple method for testing your bot's auth token. +-- Requires no parameters. +-- Returns basic information about the bot in form of a 'User' object. +getMe :: ClientM (Response User) +getMe = client (Proxy @GetMe) + +-- ** 'sendMessage' + +type SendMessage + = "sendMessage" :> ReqBody '[JSON] SendMessageRequest :> Post '[JSON] (Response Message) + +-- | Use this method to send text messages. +-- On success, the sent 'Message' is returned. +sendMessage :: SendMessageRequest -> ClientM (Response Message) +sendMessage = client (Proxy @SendMessage) + +-- | Unique identifier for the target chat +-- or username of the target channel (in the format @\@channelusername@). +data SomeChatId + = SomeChatId ChatId -- ^ Unique chat ID. + | SomeChatUsername Text -- ^ Username of the target channel. + deriving (Generic) + +instance ToJSON SomeChatId where toJSON = genericSomeToJSON +instance FromJSON SomeChatId where parseJSON = genericSomeParseJSON + +-- | 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. +data SomeReplyMarkup + = SomeInlineKeyboardMarkup InlineKeyboardMarkup + | SomeReplyKeyboardMarkup ReplyKeyboardMarkup + | SomeReplyKeyboardRemove ReplyKeyboardRemove + | SomeForceReply ForceReply + deriving (Generic) + +instance ToJSON SomeReplyMarkup where toJSON = genericSomeToJSON +instance FromJSON SomeReplyMarkup where parseJSON = genericSomeParseJSON + +data ParseMode + = Markdown + | HTML + deriving (Generic) + +instance ToJSON ParseMode +instance FromJSON ParseMode + +-- | Request parameters for 'sendMessage'. +data SendMessageRequest = SendMessageRequest + { sendMessageChatId :: SomeChatId -- ^ Unique identifier for the target chat or username of the target channel (in the format @\@channelusername@). + , sendMessageText :: Text -- ^ Text of the message to be sent. + , sendMessageParseMode :: Maybe ParseMode -- ^ Send 'Markdown' or 'HTML', if you want Telegram apps to show bold, italic, fixed-width text or inline URLs in your bot's message. + , sendMessageDisableWebPagePreview :: Maybe Bool -- ^ Disables link previews for links in this message. + , sendMessageDisableNotification :: Maybe Bool -- ^ Sends the message silently. Users will receive a notification with no sound. + , sendMessageReplyToMessageId :: Maybe MessageId -- ^ If the message is a reply, ID of the original message. + , sendMessageReplyMarkup :: Maybe SomeReplyMarkup -- ^ 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 (Generic) + +instance ToJSON SendMessageRequest where toJSON = gtoJSON +instance FromJSON SendMessageRequest where parseJSON = gparseJSON diff --git a/src/Telegram/Bot/API/Payments.hs b/src/Telegram/Bot/API/Payments.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Payments.hs @@ -0,0 +1,1 @@ +module Telegram.Bot.API.Payments where diff --git a/src/Telegram/Bot/API/Stickers.hs b/src/Telegram/Bot/API/Stickers.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Stickers.hs @@ -0,0 +1,1 @@ +module Telegram.Bot.API.Stickers where diff --git a/src/Telegram/Bot/API/Types.hs b/src/Telegram/Bot/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/Types.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Telegram.Bot.API.Types where + +import Data.Aeson (ToJSON(..), FromJSON(..)) +import Data.Int (Int32) +import Data.Hashable (Hashable) +import Data.String +import Data.Text (Text) +import Data.Time.Clock.POSIX (POSIXTime) +import GHC.Generics (Generic) + +import Telegram.Bot.API.Internal.Utils + +newtype Seconds = Seconds Int32 + deriving (Eq, Show, Num, ToJSON, FromJSON) + +-- * Available types + +-- ** User + +-- | This object represents a Telegram user or bot. +-- +-- +data User = User + { userId :: UserId -- ^ Unique identifier for this user or bot. + , userIsBot :: Bool -- ^ 'True', if this user is a bot. + , userFirstName :: Text -- ^ User's or bot's first name. + , userLastName :: Maybe Text -- ^ User‘s or bot’s last name + , userUsername :: Maybe Text -- ^ User‘s or bot’s username + , userLanguageCode :: Maybe Text -- ^ IETF language tag of the user's language + } deriving (Show, Generic) + +-- | Unique identifier for this user or bot. +newtype UserId = UserId Int32 + deriving (Eq, Show, ToJSON, FromJSON) + +-- ** Chat + +-- | This object represents a chat. +-- +-- +data Chat = Chat + { chatId :: ChatId -- ^ Unique identifier for this chat. This number may be greater than 32 bits and some programming languages may have difficulty/silent defects in interpreting it. But it is smaller than 52 bits, so a signed 64 bit integer or double-precision float type are safe for storing this identifier. + , chatType :: ChatType -- ^ Type of chat. + , chatTitle :: Maybe Text -- ^ Title, for supergroups, channels and group chats + , chatUsername :: Maybe Text -- ^ Username, for private chats, supergroups and channels if available + , chatFirstName :: Maybe Text -- ^ First name of the other party in a private chat + , chatLastName :: Maybe Text -- ^ Last name of the other party in a private chat + , chatAllMembersAreAdministrators :: Maybe Bool -- ^ 'True' if a group has ‘All Members Are Admins’ enabled. + , chatPhoto :: Maybe ChatPhoto -- ^ Chat photo. Returned only in getChat. + , chatDescription :: Maybe Text -- ^ Description, for supergroups and channel chats. Returned only in getChat. + , chatInviteLink :: Maybe Text -- ^ Chat invite link, for supergroups and channel chats. Returned only in getChat. + , chatPinnedMessage :: Maybe Message -- ^ Pinned message, for supergroups. Returned only in getChat. + , chatStickerSetName :: Maybe Text -- ^ For supergroups, name of group sticker set. Returned only in getChat. + , chatCanSetStickerSet :: Maybe Bool -- ^ True, if the bot can change the group sticker set. Returned only in getChat. + } deriving (Generic, Show) + +-- | Unique identifier for this chat. +newtype ChatId = ChatId Integer + deriving (Eq, Show, ToJSON, FromJSON, Hashable) + +-- | Type of chat. +data ChatType + = ChatTypePrivate + | ChatTypeGroup + | ChatTypeSupergroup + | ChatTypeChannel + deriving (Generic, Show) + +instance ToJSON ChatType where toJSON = gtoJSON +instance FromJSON ChatType where parseJSON = gparseJSON + +-- ** Message + +-- | This object represents a message. +data Message = Message + { messageMessageId :: MessageId -- ^ Unique message identifier inside this chat + , messageFrom :: Maybe User -- ^ Sender, empty for messages sent to channels + , messageDate :: POSIXTime -- ^ Date the message was sent in Unix time + , messageChat :: Chat -- ^ Conversation the message belongs to + , messageForwardFrom :: Maybe User -- ^ For forwarded messages, sender of the original message + , messageForwardFromChat :: Maybe Chat -- ^ For messages forwarded from channels, information about the original channel + , messageForwardFromMessageId :: Maybe MessageId -- ^ For messages forwarded from channels, identifier of the original message in the channel + , messageForwardSignature :: Maybe Text -- ^ For messages forwarded from channels, signature of the post author if present + , messageForwardDate :: Maybe POSIXTime -- ^ For forwarded messages, date the original message was sent in Unix time + , messageReplyToMessage :: 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. + , messageEditDate :: Maybe POSIXTime -- ^ Date the message was last edited in Unix time + , messageMediaGroupId :: Maybe MediaGroupId -- ^ The unique identifier of a media message group this message belongs to + , messageAuthorSignature :: Maybe Text -- ^ Signature of the post author for messages in channels + , messageText :: Maybe Text -- ^ For text messages, the actual UTF-8 text of the message, 0-4096 characters. + , messageEntities :: Maybe [MessageEntity] -- ^ For text messages, special entities like usernames, URLs, bot commands, etc. that appear in the text + , messageCaptionEntities :: Maybe [MessageEntity] -- ^ For messages with a caption, special entities like usernames, URLs, bot commands, etc. that appear in the caption + , messageAudio :: Maybe Audio -- ^ Message is an audio file, information about the file + , messageDocument :: Maybe Document -- ^ Message is a general file, information about the file + +-- , messageGame :: Maybe Game -- ^ Message is a game, information about the game. More about games » + + , messagePhoto :: Maybe [PhotoSize] -- ^ Message is a photo, available sizes of the photo + +-- , messageSticker :: Maybe Sticker -- ^ Message is a sticker, information about the sticker + + , messageVideo :: Maybe Video -- ^ Message is a video, information about the video + , messageVoice :: Maybe Voice -- ^ Message is a voice message, information about the file + , messageVideoNote :: Maybe VideoNote -- ^ Message is a video note, information about the video message + , messageCaption :: Maybe Text -- ^ Caption for the audio, document, photo, video or voice, 0-200 characters + , messageContact :: Maybe Contact -- ^ Message is a shared contact, information about the contact + , messageLocation :: Maybe Location -- ^ Message is a shared location, information about the location + , messageVenue :: Maybe Venue -- ^ Message is a venue, information about the venue + , messageNewChatMembers :: 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) + , messageLeftChatMember :: Maybe User -- ^ A member was removed from the group, information about them (this member may be the bot itself) + , messageNewChatTitle :: Maybe Text -- ^ A chat title was changed to this value + , messageNewChatPhoto :: Maybe [PhotoSize] -- ^ A chat photo was change to this value + , messageDeleteChatPhoto :: Maybe Bool -- ^ Service message: the chat photo was deleted + , messageGroupChatCreated :: Maybe Bool -- ^ Service message: the group has been created + , messageSupergroupChatCreated :: Maybe Bool -- ^ Service message: the supergroup has been created. This field can‘t be received in a message coming through updates, because bot can’t be a member of a supergroup when it is created. It can only be found in reply_to_message if someone replies to a very first message in a directly created supergroup. + , messageChannelChatCreated :: Maybe Bool -- ^ Service message: the channel has been created. This field can‘t be received in a message coming through updates, because bot can’t be a member of a channel when it is created. It can only be found in reply_to_message if someone replies to a very first message in a channel. + , messageMigrateToChatId :: Maybe ChatId -- ^ The group has been migrated to a supergroup with the specified identifier. This number may be greater than 32 bits and some programming languages may have difficulty/silent defects in interpreting it. But it is smaller than 52 bits, so a signed 64 bit integer or double-precision float type are safe for storing this identifier. + , messageMigrateFromChatId :: Maybe ChatId -- ^ The supergroup has been migrated from a group with the specified identifier. This number may be greater than 32 bits and some programming languages may have difficulty/silent defects in interpreting it. But it is smaller than 52 bits, so a signed 64 bit integer or double-precision float type are safe for storing this identifier. + , messagePinnedMessage :: 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. + +-- , messageInvoice :: Maybe Invoice -- ^ Message is an invoice for a payment, information about the invoice. More about payments » +-- , messageSuccessfulPayment :: Maybe SuccessfulPayment -- ^ Message is a service message about a successful payment, information about the payment. More about payments » + } deriving (Generic, Show) + +-- | Unique message identifier inside this chat. +newtype MessageId = MessageId Int32 + deriving (Eq, Show, ToJSON, FromJSON) + +-- | The unique identifier of a media message group a message belongs to. +newtype MediaGroupId = MediaGroupId Text + deriving (Eq, Show, ToJSON, FromJSON) + +-- ** MessageEntity + +-- | This object represents one special entity in a text message. For example, hashtags, usernames, URLs, etc. +data MessageEntity = MessageEntity + { messageEntityType :: MessageEntityType -- ^ Type of the entity. Can be mention (@username), hashtag, bot_command, url, email, bold (bold text), italic (italic text), code (monowidth string), pre (monowidth block), text_link (for clickable text URLs), text_mention (for users without usernames) + , messageEntityOffset :: Int32 -- ^ Offset in UTF-16 code units to the start of the entity + , messageEntityLength :: Int32 -- ^ Length of the entity in UTF-16 code units + , messageEntityUrl :: Maybe Text -- ^ For “text_link” only, url that will be opened after user taps on the text + , messageEntityUser :: Maybe User -- ^ For “text_mention” only, the mentioned user + } deriving (Generic, Show) + +-- | Type of the entity. Can be mention (@username), hashtag, bot_command, url, email, bold (bold text), italic (italic text), code (monowidth string), pre (monowidth block), text_link (for clickable text URLs), text_mention (for users without usernames) +data MessageEntityType + = MessageEntityMention + | MessageEntityHashtag + | MessageEntityBotCommand + | MessageEntityUrl + | MessageEntityEmail + | MessageEntityBold + | MessageEntityItalic + | MessageEntityCode + | MessageEntityPre + | MessageEntityTextLink + | MessageEntityTextMention + deriving (Eq, Show, Generic) + +instance ToJSON MessageEntityType where toJSON = gtoJSON +instance FromJSON MessageEntityType where parseJSON = gparseJSON + +-- ** 'PhotoSize' + +-- | This object represents one size of a photo or a file / sticker thumbnail. +data PhotoSize = PhotoSize + { photoSizeFileId :: FileId -- ^ Unique identifier for this file + , photoSizeWidth :: Int32 -- ^ Photo width + , photoSizeHeight :: Int32 -- ^ Photo height + , photoSizeFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- | Unique identifier for this file. +newtype FileId = FileId Text + deriving (Eq, Show, ToJSON, FromJSON) + +-- ** 'Audio' + +-- | This object represents an audio file to be treated as music by the Telegram clients. +data Audio = Audio + { audioFileId :: FileId -- ^ Unique identifier for this file + , audioDuration :: Seconds -- ^ Duration of the audio in seconds as defined by sender + , audioPerformer :: Maybe Text -- ^ Performer of the audio as defined by sender or by audio tags + , audioTitle :: Maybe Text -- ^ Title of the audio as defined by sender or by audio tags + , audioMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender + , audioFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- ** 'Document' + +-- | This object represents a general file (as opposed to photos, voice messages and audio files). +data Document = Document + { documentFileId :: FileId -- ^ Unique file identifier + , documentThumb :: Maybe PhotoSize -- ^ Document thumbnail as defined by sender + , documentFileName :: Maybe Text -- ^ Original filename as defined by sender + , documentMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender + , documentFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- ** 'Video' + +-- | This object represents a video file. +data Video = Video + { videoFileId :: FileId -- ^ Unique identifier for this file + , videoWidth :: Int32 -- ^ Video width as defined by sender + , videoHeight :: Int32 -- ^ Video height as defined by sender + , videoDuration :: Seconds -- ^ Duration of the video in seconds as defined by sender + , videoThumb :: Maybe PhotoSize -- ^ Video thumbnail + , videoMimeType :: Maybe Text -- ^ Mime type of a file as defined by sender + , videoFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- ** 'Voice' + +-- | This object represents a voice note. +data Voice = Voice + { voiceFileId :: FileId -- ^ Unique identifier for this file + , voiceDuration :: Seconds -- ^ Duration of the audio in seconds as defined by sender + , voiceMimeType :: Maybe Text -- ^ MIME type of the file as defined by sender + , voiceFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- ** 'VideoNote' + +-- | This object represents a video message (available in Telegram apps as of v.4.0). +data VideoNote = VideoNote + { videoNoteFileId :: Text -- ^ Unique identifier for this file + , videoNoteLength :: Int32 -- ^ Video width and height as defined by sender + , videoNoteDuration :: Seconds -- ^ Duration of the video in seconds as defined by sender + , videoNoteThumb :: Maybe PhotoSize -- ^ Video thumbnail + , videoNoteFileSize :: Maybe Int32 -- ^ File size + } deriving (Generic, Show) + +-- ** 'Contact' + +-- | This object represents a phone contact. +data Contact = Contact + { contactPhoneNumber :: Text -- ^ Contact's phone number + , contactFirstName :: Text -- ^ Contact's first name + , contactLastName :: Maybe Text -- ^ Contact's last name + , contactUserId :: Maybe UserId -- ^ Contact's user identifier in Telegram + } deriving (Generic, Show) + +-- ** Location + +-- | This object represents a point on the map. +data Location = Location + { locationLongitude :: Float -- ^ Longitude as defined by sender + , locationLatitude :: Float -- ^ Latitude as defined by sender + } deriving (Generic, Show) + +-- ** 'Venue' + +-- | This object represents a venue. +data Venue = Venue + { venueLocation :: Location -- ^ Venue location + , venueTitle :: Text -- ^ Name of the venue + , venueAddress :: Text -- ^ Address of the venue + , venueFoursquareId :: Maybe Text -- ^ Foursquare identifier of the venue + } deriving (Generic, Show) + +-- ** 'UserProfilePhotos' + +-- | This object represent a user's profile pictures. +data UserProfilePhotos = UserProfilePhotos + { userProfilePhotosTotalCount :: Int32 -- ^ Total number of profile pictures the target user has + , userProfilePhotosPhotos :: [[PhotoSize]] -- ^ Requested profile pictures (in up to 4 sizes each) + } deriving (Generic, Show) + +-- ** 'File' + +-- | This object represents a file ready to be downloaded. +-- The file can be downloaded via the link @https://api.telegram.org/file/bot/@. +-- It is guaranteed that the link will be valid for at least 1 hour. +-- When the link expires, a new one can be requested by calling getFile. +data File = File + { fileFileId :: FileId -- ^ Unique identifier for this file + , fileFileSize :: Maybe Int32 -- ^ File size, if known + , fileFilePath :: Maybe Text -- ^ File path. Use https://api.telegram.org/file/bot/ to get the file. + } deriving (Generic, Show) + +-- ** 'ReplyKeyboardMarkup' + +-- | This object represents a custom keyboard with reply options (see Introduction to bots for details and examples). +data ReplyKeyboardMarkup = ReplyKeyboardMarkup + { replyKeyboardMarkupKeyboard :: [[KeyboardButton]] -- ^ Array of button rows, each represented by an Array of KeyboardButton objects + , replyKeyboardMarkupResizeKeyboard :: Maybe Bool -- ^ Requests clients to resize the keyboard vertically for optimal fit (e.g., make the keyboard smaller if there are just two rows of buttons). Defaults to false, in which case the custom keyboard is always of the same height as the app's standard keyboard. + , replyKeyboardMarkupOneTimeKeyboard :: Maybe Bool -- ^ Requests clients to hide the keyboard as soon as it's been used. The keyboard will still be available, but clients will automatically display the usual letter-keyboard in the chat – the user can press a special button in the input field to see the custom keyboard again. Defaults to false. + , replyKeyboardMarkupSelective :: Maybe Bool -- ^ Use this parameter if you want to show the keyboard to specific users only. Targets: 1) users that are @mentioned in the text of the Message object; 2) if the bot's message is a reply (has reply_to_message_id), sender of the original message. + } deriving (Generic, Show) + +-- ** 'KeyboardButton' + +-- | This object represents one button of the reply keyboard. +-- For simple text buttons String can be used instead of this object +-- to specify text of the button. Optional fields are mutually exclusive. +data KeyboardButton = KeyboardButton + { keyboardButtonText :: Text -- ^ Text of the button. If none of the optional fields are used, it will be sent as a message when the button is pressed + , keyboardButtonRequestContact :: Maybe Bool -- ^ If True, the user's phone number will be sent as a contact when the button is pressed. Available in private chats only + , keyboardButtonRequestLocation :: Maybe Bool -- ^ If True, the user's current location will be sent when the button is pressed. Available in private chats only + } deriving (Generic, Show) + +instance IsString KeyboardButton where + fromString s = KeyboardButton (fromString s) Nothing Nothing + +-- ** 'ReplyKeyboardRemove' + +-- | Upon receiving a message with this object, +-- Telegram clients will remove the current custom keyboard +-- and display the default letter-keyboard. +-- +-- By default, custom keyboards are displayed until a new keyboard is sent by a bot. +-- An exception is made for one-time keyboards that are hidden immediately after +-- the user presses a button (see 'ReplyKeyboardMarkup'). +data ReplyKeyboardRemove = ReplyKeyboardRemove + { replyKeyboardRemoveRemoveKeyboard :: Bool -- ^ Requests clients to remove the custom keyboard (user will not be able to summon this keyboard; if you want to hide the keyboard from sight but keep it accessible, use one_time_keyboard in ReplyKeyboardMarkup) + , replyKeyboardRemoveSelective :: Maybe Bool -- ^ Use this parameter if you want to remove the keyboard for specific users only. Targets: 1) users that are @mentioned in the text of the Message object; 2) if the bot's message is a reply (has reply_to_message_id), sender of the original message. + } deriving (Generic, Show) + +-- ** 'InlineKeyboardMarkup' + +-- | This object represents an inline keyboard that appears +-- right next to the message it belongs to. +data InlineKeyboardMarkup = InlineKeyboardMarkup + { inlineKeyboardMarkupInlineKeyboard :: [[InlineKeyboardButton]] -- ^ Array of button rows, each represented by an Array of InlineKeyboardButton objects + } deriving (Generic, Show) + +-- ** 'InlineKeyboardButton' + +-- | This object represents one button of an inline keyboard. You must use exactly one of the optional fields. +data InlineKeyboardButton = InlineKeyboardButton + { inlineKeyboardButtonText :: Text -- ^ Label text on the button + , inlineKeyboardButtonUrl :: Maybe Text -- ^ HTTP url to be opened when button is pressed + , inlineKeyboardButtonCallbackData :: Maybe Text -- ^ Data to be sent in a callback query to the bot when button is pressed, 1-64 bytes + , inlineKeyboardButtonSwitchInlineQuery :: Maybe Text -- ^ If set, pressing the button will prompt the user to select one of their chats, open that chat and insert the bot‘s username and the specified inline query in the input field. Can be empty, in which case just the bot’s username will be inserted. + , inlineKeyboardButtonSwitchInlineQueryCurrentChat :: Maybe Text -- ^ If set, pressing the button will insert the bot‘s username and the specified inline query in the current chat's input field. Can be empty, in which case only the bot’s username will be inserted. + +-- , inlineKeyboardButtonCallbackGame :: Maybe CallbackGame -- ^ Description of the game that will be launched when the user presses the button. + + , inlineKeyboardButtonPay :: Maybe Bool -- ^ Specify True, to send a Pay button. + } deriving (Generic, Show) + +labeledInlineKeyboardButton :: Text -> InlineKeyboardButton +labeledInlineKeyboardButton label = InlineKeyboardButton label Nothing Nothing Nothing Nothing Nothing + +-- ** 'CallbackQuery' + +-- | This object represents an incoming callback query from a callback button +-- in an inline keyboard. If the button that originated the query was attached +-- to a message sent by the bot, the field message will be present. +-- If the button was attached to a message sent via the bot (in inline mode), +-- the field @inline_message_id@ will be present. +-- Exactly one of the fields data or game_short_name will be present. +data CallbackQuery = CallbackQuery + { callbackQueryId :: CallbackQueryId -- ^ Unique identifier for this query + , callbackQueryFrom :: User -- ^ Sender + , callbackQueryMessage :: Maybe Message -- ^ Message with the callback button that originated the query. Note that message content and message date will not be available if the message is too old + , callbackQueryInlineMessageId :: Maybe MessageId -- ^ Identifier of the message sent via the bot in inline mode, that originated the query. + , callbackQueryChatInstance :: Text -- ^ Global identifier, uniquely corresponding to the chat to which the message with the callback button was sent. Useful for high scores in games. + , callbackQueryData :: Maybe Text -- ^ Data associated with the callback button. Be aware that a bad client can send arbitrary data in this field. + , callbackQueryGameShortName :: Maybe Text -- ^ Short name of a Game to be returned, serves as the unique identifier for the game + } deriving (Generic, Show) + +newtype CallbackQueryId = CallbackQueryId Text + deriving (Eq, Show, Generic, ToJSON, FromJSON) + +-- ** 'ForceReply' + +-- | Upon receiving a message with this object, +-- Telegram clients will display a reply interface to the user +-- (act as if the user has selected the bot‘s message and tapped ’Reply'). +-- This can be extremely useful if you want to create user-friendly +-- step-by-step interfaces without having to sacrifice privacy mode. +data ForceReply = ForceReply + { forceReplyForceReply :: Bool -- ^ Shows reply interface to the user, as if they manually selected the bot‘s message and tapped ’Reply' + , forceReplySelective :: Maybe Bool -- ^ Use this parameter if you want to force reply from specific users only. Targets: 1) users that are @mentioned in the text of the Message object; 2) if the bot's message is a reply (has reply_to_message_id), sender of the original message. + } deriving (Generic, Show) + +-- ** Chat photo + +-- | Chat photo. Returned only in getChat. +data ChatPhoto = ChatPhoto + { chatPhotoSmallFileId :: FileId -- ^ Unique file identifier of small (160x160) chat photo. This file_id can be used only for photo download. + , chatPhotoBigFileId :: FileId -- ^ Unique file identifier of big (640x640) chat photo. This file_id can be used only for photo download. + } deriving (Generic, Show) + +-- ** 'ChatMember' + +-- | This object contains information about one member of a chat. +data ChatMember = ChatMember + { chatMemberUser :: User -- ^ Information about the user + , chatMemberStatus :: Text -- ^ The member's status in the chat. Can be “creator”, “administrator”, “member”, “restricted”, “left” or “kicked” + , chatMemberUntilDate :: Maybe POSIXTime -- ^ Restictred and kicked only. Date when restrictions will be lifted for this user, unix time + , chatMemberCanBeEdited :: Maybe Bool -- ^ Administrators only. True, if the bot is allowed to edit administrator privileges of that user + , chatMemberCanChangeInfo :: Maybe Bool -- ^ Administrators only. True, if the administrator can change the chat title, photo and other settings + , chatMemberCanPostMessages :: Maybe Bool -- ^ Administrators only. True, if the administrator can post in the channel, channels only + , chatMemberCanEditMessages :: Maybe Bool -- ^ Administrators only. True, if the administrator can edit messages of other users and can pin messages, channels only + , chatMemberCanDeleteMessages :: Maybe Bool -- ^ Administrators only. True, if the administrator can delete messages of other users + , chatMemberCanInviteUsers :: Maybe Bool -- ^ Administrators only. True, if the administrator can invite new users to the chat + , chatMemberCanRestrictMembers :: Maybe Bool -- ^ Administrators only. True, if the administrator can restrict, ban or unban chat members + , chatMemberCanPinMessages :: Maybe Bool -- ^ Administrators only. True, if the administrator can pin messages, supergroups only + , chatMemberCanPromoteMembers :: 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) + , chatMemberCanSendMessages :: Maybe Bool -- ^ Restricted only. True, if the user can send text messages, contacts, locations and venues + , chatMemberCanSendMediaMessages :: Maybe Bool -- ^ Restricted only. True, if the user can send audios, documents, photos, videos, video notes and voice notes, implies can_send_messages + , chatMemberCanSendOtherMessages :: Maybe Bool -- ^ Restricted only. True, if the user can send animations, games, stickers and use inline bots, implies can_send_media_messages + , chatMemberCanAddWebPagePreviews :: Maybe Bool -- ^ Restricted only. True, if user may add web page previews to his messages, implies can_send_media_messages + } deriving (Generic, Show) + +-- ** 'ResponseParameters' + +-- | Contains information about why a request was unsuccessful. +data ResponseParameters = ResponseParameters + { responseParametersMigrateToChatId :: Maybe ChatId -- ^ The group has been migrated to a supergroup with the specified identifier. This number may be greater than 32 bits and some programming languages may have difficulty/silent defects in interpreting it. But it is smaller than 52 bits, so a signed 64 bit integer or double-precision float type are safe for storing this identifier. + , responseParametersRetryAfter :: Maybe Seconds -- ^ In case of exceeding flood control, the number of seconds left to wait before the request can be repeated + } deriving (Show, Generic) + +deriveJSON' ''User +deriveJSON' ''Chat +deriveJSON' ''Message +deriveJSON' ''MessageEntity +deriveJSON' ''PhotoSize +deriveJSON' ''Audio +deriveJSON' ''Document +deriveJSON' ''Video +deriveJSON' ''Voice +deriveJSON' ''VideoNote +deriveJSON' ''Contact +deriveJSON' ''Location +deriveJSON' ''Venue +deriveJSON' ''UserProfilePhotos +deriveJSON' ''File +deriveJSON' ''ReplyKeyboardMarkup +deriveJSON' ''KeyboardButton +deriveJSON' ''ReplyKeyboardRemove +deriveJSON' ''InlineKeyboardMarkup +deriveJSON' ''InlineKeyboardButton +deriveJSON' ''CallbackQuery +deriveJSON' ''ForceReply +deriveJSON' ''ChatPhoto +deriveJSON' ''ChatMember +deriveJSON' ''ResponseParameters diff --git a/src/Telegram/Bot/API/UpdatingMessages.hs b/src/Telegram/Bot/API/UpdatingMessages.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/API/UpdatingMessages.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Telegram.Bot.API.UpdatingMessages where + +import Data.Aeson +import Data.Proxy +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.API +import Servant.Client (ClientM, client) + +import Telegram.Bot.API.Internal.Utils (gparseJSON, gtoJSON) +import Telegram.Bot.API.MakingRequests +import Telegram.Bot.API.Methods +import Telegram.Bot.API.Types + +-- ** 'editMessageText' + +type EditMessageText + = "editMessageText" + :> ReqBody '[JSON] EditMessageTextRequest + :> Post '[JSON] (Response Message) + +-- | Use this method to send text messages. +-- On success, the sent 'Message' is returned. +editMessageText :: EditMessageTextRequest -> ClientM (Response Message) +editMessageText = client (Proxy @EditMessageText) + +-- | Request parameters for 'sendMessage'. +data EditMessageTextRequest = EditMessageTextRequest + { editMessageTextChatId :: Maybe SomeChatId -- ^ Required if 'editMessageTextInlineMessageId' is not specified. Unique identifier for the target chat or username of the target channel (in the format @\@channelusername@). + , editMessageTextMessageId :: Maybe MessageId -- ^ Required if 'editMessageTextInlineMessageId' is not specified. Identifier of the sent message. + , editMessageTextInlineMessageId :: Maybe MessageId -- ^ Required if 'editMessageTextChatId' and 'editMessageTextMessageId' are not specified. Identifier of the sent message. + , editMessageTextText :: Text -- ^ Text of the message to be sent. + , editMessageTextParseMode :: Maybe ParseMode -- ^ Send 'Markdown' or 'HTML', if you want Telegram apps to show bold, italic, fixed-width text or inline URLs in your bot's message. + , editMessageTextDisableWebPagePreview :: Maybe Bool -- ^ Disables link previews for links in this message. + , editMessageTextReplyMarkup :: Maybe SomeReplyMarkup -- ^ 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 (Generic) + +instance ToJSON EditMessageTextRequest where toJSON = gtoJSON +instance FromJSON EditMessageTextRequest where parseJSON = gparseJSON diff --git a/src/Telegram/Bot/Simple.hs b/src/Telegram/Bot/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple.hs @@ -0,0 +1,14 @@ +module Telegram.Bot.Simple ( + module Telegram.Bot.Simple.BotApp, + module Telegram.Bot.Simple.Conversation, + module Telegram.Bot.Simple.Eff, + module Telegram.Bot.Simple.InlineKeyboard, + module Telegram.Bot.Simple.Reply, +) where + +import Telegram.Bot.Simple.BotApp +import Telegram.Bot.Simple.Conversation +import Telegram.Bot.Simple.Eff +import Telegram.Bot.Simple.InlineKeyboard +import Telegram.Bot.Simple.Reply + diff --git a/src/Telegram/Bot/Simple/BotApp.hs b/src/Telegram/Bot/Simple/BotApp.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/BotApp.hs @@ -0,0 +1,59 @@ +module Telegram.Bot.Simple.BotApp ( + BotApp(..), + BotJob(..), + + startBot, + startBot_, + + startBotAsync, + startBotAsync_, + + getEnvToken, +) where + +import Control.Concurrent (forkIO) +import Control.Monad (void) +import Data.String (fromString) +import Servant.Client +import System.Environment (getEnv) + +import qualified Telegram.Bot.API as Telegram +import Telegram.Bot.Simple.BotApp.Internal + +-- | Start bot with asynchronous polling. +-- The result is a function that allows you to send actions +-- directly to the bot. +startBotAsync :: BotApp model action -> ClientEnv -> IO (action -> IO ()) +startBotAsync bot env = do + botEnv <- defaultBotEnv bot env + jobThreadIds <- scheduleBotJobs botEnv (botJobs bot) + fork_ $ startBotPolling bot botEnv + return (issueAction botEnv Nothing) + where + fork_ = void . forkIO . void . flip runClientM env + +-- | Like 'startBotAsync', but ignores result. +startBotAsync_ :: BotApp model action -> ClientEnv -> IO () +startBotAsync_ bot env = void (startBotAsync bot env) + +-- | Start bot with update polling in the main thread. +startBot :: BotApp model action -> ClientEnv -> IO (Either ServantError ()) +startBot bot env = do + botEnv <- defaultBotEnv bot env + jobThreadIds <- scheduleBotJobs botEnv (botJobs bot) + _actionsThreadId <- processActionsIndefinitely bot botEnv + runClientM (startBotPolling bot botEnv) env + +-- | Like 'startBot', but ignores result. +startBot_ :: BotApp model action -> ClientEnv -> IO () +startBot_ bot = void . startBot bot + +-- | Get a 'Telegram.Token' from environment variable. +-- +-- Common use: +-- +-- @ +-- 'getEnvToken' "TELEGRAM_BOT_TOKEN" +-- @ +getEnvToken :: String -> IO Telegram.Token +getEnvToken varName = fromString <$> getEnv varName diff --git a/src/Telegram/Bot/Simple/BotApp/Internal.hs b/src/Telegram/Bot/Simple/BotApp/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/BotApp/Internal.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Telegram.Bot.Simple.BotApp.Internal where + +import Control.Concurrent (ThreadId, forkIO, threadDelay) +import Control.Concurrent.STM +import Control.Monad (forever, void) +import Control.Monad.Except (catchError) +import Control.Monad.Trans (liftIO) +import Data.Bifunctor (first) +import Data.Text (Text) +import Servant.Client (ClientEnv, ClientM, runClientM) +import qualified System.Cron as Cron + +import qualified Telegram.Bot.API as Telegram +import Telegram.Bot.Simple.Eff + +-- | A bot application. +data BotApp model action = BotApp + { botInitialModel :: model + -- ^ Initial bot state. + , botAction :: Telegram.Update -> model -> Maybe action + -- ^ How to convert incoming 'Telegram.Update's into @action@s. + -- See "Telegram.Bot.Simple.UpdateParser" for some helpers. + , botHandler :: action -> model -> Eff action model + -- ^ How to handle @action@s. + , botJobs :: [BotJob model action] + -- ^ Background bot jobs. + } + +-- | A background bot job. +data BotJob model action = BotJob + { botJobSchedule :: Text + -- ^ Cron schedule for the job. + , botJobTask :: model -> Eff action model + -- ^ Job function. + } + +-- | An environment actual bot runs in. +data BotEnv model action = BotEnv + { botModelVar :: TVar model + -- ^ A transactional variable with bot's current state. + , botActionsQueue :: TQueue (Maybe Telegram.Update, action) + -- ^ A queue of @action@s to process (with associated 'Telegram.Update's). + , botClientEnv :: ClientEnv + -- ^ HTTP client environment (where and how exactly to make requests to Telegram Bot API). + -- This includes 'Telegram.Token'. + , botUser :: Telegram.User + -- ^ Information about the bot in the form of 'Telegram.User'. + } + +instance Functor (BotJob model) where + fmap f BotJob{..} = BotJob{ botJobTask = first f . botJobTask, .. } + +-- | Run bot job task once. +runJobTask :: BotEnv model action -> (model -> Eff action model) -> IO () +runJobTask botEnv@BotEnv{..} task = do + effects <- liftIO $ atomically $ do + model <- readTVar botModelVar + case runEff (task model) of + (newModel, effects) -> do + writeTVar botModelVar newModel + return effects + res <- flip runClientM botClientEnv $ + mapM_ ((>>= liftIO . issueAction botEnv Nothing) . runBotM (BotContext botUser Nothing)) effects + case res of + Left err -> print err + Right _ -> return () + +-- | Schedule a cron-like bot job. +scheduleBotJob :: BotEnv model action -> BotJob model action -> IO [ThreadId] +scheduleBotJob botEnv BotJob{..} = Cron.execSchedule $ do + Cron.addJob (runJobTask botEnv botJobTask) botJobSchedule + +-- | Schedule all bot jobs. +scheduleBotJobs :: BotEnv model action -> [BotJob model action] -> IO [ThreadId] +scheduleBotJobs botEnv jobs = concat + <$> traverse (scheduleBotJob botEnv) jobs + +-- | Construct a default @'BotEnv' model action@ for a bot. +defaultBotEnv :: BotApp model action -> ClientEnv -> IO (BotEnv model action) +defaultBotEnv BotApp{..} env = BotEnv + <$> newTVarIO botInitialModel + <*> newTQueueIO + <*> pure env + <*> (either (error . show) Telegram.responseResult <$> runClientM Telegram.getMe env) + +-- | Issue a new action for the bot to process. +issueAction :: BotEnv model action -> Maybe Telegram.Update -> action -> IO () +issueAction BotEnv{..} update action = atomically $ + writeTQueue botActionsQueue (update, action) + +-- | Process one action. +processAction + :: BotApp model action + -> BotEnv model action + -> Maybe Telegram.Update + -> action + -> ClientM () +processAction BotApp{..} botEnv@BotEnv{..} update action = do + effects <- liftIO $ atomically $ do + model <- readTVar botModelVar + case runEff (botHandler action model) of + (newModel, effects) -> do + writeTVar botModelVar newModel + return effects + mapM_ ((>>= liftIO . issueAction botEnv update) . runBotM (BotContext botUser update)) effects + +-- | A job to wait for the next action and process it. +processActionJob :: BotApp model action -> BotEnv model action -> ClientM () +processActionJob botApp botEnv@BotEnv{..} = do + (update, action) <- liftIO . atomically $ readTQueue botActionsQueue + processAction botApp botEnv update action + +-- | Process incoming actions indefinitely. +processActionsIndefinitely + :: BotApp model action -> BotEnv model action -> IO ThreadId +processActionsIndefinitely botApp botEnv = forkIO . forever $ do + runClientM (processActionJob botApp botEnv) (botClientEnv botEnv) + +-- | Start 'Telegram.Update' polling for a bot. +startBotPolling :: BotApp model action -> BotEnv model action -> ClientM () +startBotPolling BotApp{..} botEnv@BotEnv{..} = startPolling handleUpdate + where + handleUpdate update = liftIO . void . forkIO $ do + maction <- botAction update <$> readTVarIO botModelVar + case maction of + Nothing -> return () + Just action -> issueAction botEnv (Just update) action + +-- | Start 'Telegram.Update' polling with a given update handler. +startPolling :: (Telegram.Update -> ClientM ()) -> ClientM () +startPolling handleUpdate = go Nothing + where + go lastUpdateId = do + let inc (Telegram.UpdateId n) = Telegram.UpdateId (n + 1) + offset = fmap inc lastUpdateId + res <- + (Right <$> Telegram.getUpdates + (Telegram.GetUpdatesRequest offset Nothing Nothing Nothing)) + `catchError` (pure . Left) + + nextUpdateId <- case res of + Left servantErr -> do + liftIO (print servantErr) + pure lastUpdateId + Right result -> do + let updates = Telegram.responseResult result + updateIds = map Telegram.updateUpdateId updates + maxUpdateId = maximum (Nothing : map Just updateIds) + mapM_ handleUpdate updates + pure maxUpdateId + liftIO $ threadDelay 1000000 + go nextUpdateId diff --git a/src/Telegram/Bot/Simple/Conversation.hs b/src/Telegram/Bot/Simple/Conversation.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/Conversation.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Telegram.Bot.Simple.Conversation where + +import Data.Bifunctor +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Maybe (fromMaybe) + +import qualified Telegram.Bot.API as Telegram +import Telegram.Bot.Simple.BotApp +import Telegram.Bot.Simple.Eff + +-- | Make bot to have a separate state for each conversation. +-- +-- Common use (to have a separate state for each chat): +-- +-- @ +-- 'conversationBot' 'Telegram.updateChatId' bot +-- @ +conversationBot + :: (Eq conversation, Hashable conversation) + => (Telegram.Update -> Maybe conversation) -- ^ How to disambiguate conversations. + -> BotApp model action + -> BotApp (HashMap (Maybe conversation) model) (Maybe conversation, action) +conversationBot toConversation BotApp{..} = BotApp + { botInitialModel = conversationInitialModel + , botAction = conversationAction + , botHandler = conversationHandler + , botJobs = conversationJobs + } + where + conversationInitialModel = HashMap.empty + + conversationAction update conversations = do + conversation <- toConversation update + let model = fromMaybe botInitialModel (HashMap.lookup (Just conversation) conversations) + (Just conversation,) <$> botAction update model + + conversationHandler (conversation, action) conversations = + bimap (conversation,) (\m -> HashMap.insert conversation m conversations) $ + botHandler action model + where + model = fromMaybe botInitialModel (HashMap.lookup conversation conversations) + + conversationJobs = map toConversationJob botJobs + + toConversationJob BotJob{..} = BotJob + { botJobSchedule = botJobSchedule + , botJobTask = HashMap.traverseWithKey $ + \conversation -> first (conversation,) . botJobTask + } + +-- | Pass latest 'Telegram.Update' to all bot jobs. +-- +-- This enables jobs to easily send notifications. +useLatestUpdateInJobs + :: BotApp model action + -> BotApp (Maybe Telegram.Update, model) (Maybe Telegram.Update, action) +useLatestUpdateInJobs BotApp{..} = BotApp + { botInitialModel = (Nothing, botInitialModel) + , botAction = newAction + , botHandler = newHandler + , botJobs = newJobs + } + where + newAction update (_, model) = (Just update,) <$> botAction update model + + newHandler (update, action) (_update, model) = + bimap (update,) (update,) $ + -- re-enforcing update here is needed for actions issued in jobs + setEffUpdate update (botHandler action model) + + newJobs = map addUpdateToJob botJobs + + addUpdateToJob BotJob{..} = BotJob + { botJobSchedule = botJobSchedule + , botJobTask = \(update, model) -> + bimap (update,) (update,) (setEffUpdate update (botJobTask model)) + } diff --git a/src/Telegram/Bot/Simple/Debug.hs b/src/Telegram/Bot/Simple/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/Debug.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE BangPatterns #-} +module Telegram.Bot.Simple.Debug where + +import Control.Monad.Trans (liftIO) +import Control.Monad.Writer (tell) +import Data.Aeson (ToJSON) +import qualified Data.Aeson.Encode.Pretty as Aeson +import Data.Monoid ((<>)) +import qualified Data.Text.Lazy as Text +import qualified Data.Text.Lazy.Encoding as Text +import Debug.Trace (trace) +import Text.Show.Pretty (ppShow) + +import qualified Telegram.Bot.API as Telegram +import Telegram.Bot.Simple.BotApp +import Telegram.Bot.Simple.Eff + +-- * Bot debug tracing + +-- | This a default bot tracing modifier that relies on +-- +-- * 'traceTelegramUpdatesJSON' +-- * 'traceBotActionsShow' +-- * 'traceBotModelShow' +traceBotDefault + :: (Show model, Show action) + => BotApp model action + -> BotApp model action +traceBotDefault + = traceTelegramUpdatesJSON + . traceBotActionsShow + . traceBotModelShow + +-- ** Trace 'Telegram.Update's + +-- | Trace (debug print) every 'Telegram.Update' before parsing it. +traceTelegramUpdatesWith + :: (Telegram.Update -> String) -- ^ How to display an update. + -> BotApp model action + -> BotApp model action +traceTelegramUpdatesWith f botApp = botApp + { botAction = \update -> botAction botApp $! trace (f update) update + } + +-- | Trace (debug print) every update as pretty JSON value. +traceTelegramUpdatesJSON :: BotApp model action -> BotApp model action +traceTelegramUpdatesJSON = traceTelegramUpdatesWith ppAsJSON + +-- | Trace (debug print) every update using 'Show' instance. +traceTelegramUpdatesShow :: BotApp model action -> BotApp model action +traceTelegramUpdatesShow = traceTelegramUpdatesWith ppShow + +-- ** Trace bot actions + +-- | A type of an action to trace. +data TracedAction action + = TracedIncomingAction action -- ^ An action that's about to be handled. + | TracedIssuedAction action -- ^ An action that's just been issued by some handler. + deriving (Eq, Show) + +-- | Pretty print 'TraceActionType'. +ppTracedAction :: Show action => TracedAction action -> String +ppTracedAction (TracedIncomingAction action) = "Incoming: " <> ppShow action +ppTracedAction (TracedIssuedAction action) = "Issued: " <> ppShow action + +-- | Trace (debug print) every incoming and issued action. +traceBotActionsWith + :: (TracedAction action -> String) -- ^ How to display an action. + -> BotApp model action + -> BotApp model action +traceBotActionsWith f botApp = botApp { botHandler = newHandler } + where + traceAction action = action <$ do + liftIO $ putStrLn (f (TracedIssuedAction action)) + + newHandler !action model = do + Eff (tell (map (>>= traceAction) actions)) + pure newModel + where + (newModel, actions) = runEff $ + botHandler botApp + (trace (f (TracedIncomingAction action)) action) + model + +-- | Trace (debug print) bot actions using 'Show' instance. +traceBotActionsShow + :: Show action => BotApp model action -> BotApp model action +traceBotActionsShow = traceBotActionsWith ppTracedAction + +-- ** Trace bot state model + +-- | Trace (debug print) bot model. +traceBotModelWith + :: (model -> String) -- ^ How to display a model. + -> BotApp model action + -> BotApp model action +traceBotModelWith f botApp = botApp + { botInitialModel = newInitialModel + , botHandler = newHandler + } + where + !newInitialModel = traceModel (botInitialModel botApp) + newHandler action !model = traceModel <$> botHandler botApp action model + traceModel = trace <$> f <*> id + +-- | Trace (debug print) bot model using 'Show' instance. +traceBotModelShow + :: Show model => BotApp model action -> BotApp model action +traceBotModelShow = traceBotModelWith ppShow + +-- | Trace (debug print) bot model using 'Show' instance. +traceBotModelJSON + :: ToJSON model => BotApp model action -> BotApp model action +traceBotModelJSON = traceBotModelWith ppAsJSON + +-- * Helpers + +-- | Pretty print a value as JSON. +ppAsJSON :: ToJSON a => a -> String +ppAsJSON = Text.unpack . Text.decodeUtf8 . Aeson.encodePretty diff --git a/src/Telegram/Bot/Simple/Eff.hs b/src/Telegram/Bot/Simple/Eff.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/Eff.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Telegram.Bot.Simple.Eff where + +import Control.Monad.Reader +import Control.Monad.Writer +import Data.Bifunctor +import Servant.Client + +import qualified Telegram.Bot.API as Telegram + +-- | Bot handler context. +-- +-- The context may include an 'Update' the bot is handling at the moment. +newtype BotM a = BotM { _runBotM :: ReaderT BotContext ClientM a } + deriving (Functor, Applicative, Monad, MonadReader BotContext, MonadIO) + +data BotContext = BotContext + { botContextUser :: Telegram.User + , botContextUpdate :: Maybe Telegram.Update + } + +liftClientM :: ClientM a -> BotM a +liftClientM = BotM . lift + +runBotM :: BotContext -> BotM a -> ClientM a +runBotM update = flip runReaderT update . _runBotM + +newtype Eff action model = Eff { _runEff :: Writer [BotM action] model } + deriving (Functor, Applicative, Monad) + +instance Bifunctor Eff where + bimap f g = Eff . mapWriter (bimap g (map (fmap f))) . _runEff + +runEff :: Eff action model -> (model, [BotM action]) +runEff = runWriter . _runEff + +eff :: BotM a -> Eff a () +eff e = Eff (tell [e]) + +withEffect :: BotM action -> model -> Eff action model +withEffect effect model = eff effect >> pure model + +(<#) :: model -> BotM action -> Eff action model +(<#) = flip withEffect + +-- | Set a specific 'Telegram.Update' in a 'BotM' context. +setBotMUpdate :: Maybe Telegram.Update -> BotM a -> BotM a +setBotMUpdate update (BotM m) = BotM (local f m) + where + f botContext = botContext { botContextUpdate = update } + +-- | Set a specific 'Telegram.Update' in every effect of 'Eff' context. +setEffUpdate :: Maybe Telegram.Update -> Eff action model -> Eff action model +setEffUpdate update (Eff m) = Eff (censor (map (setBotMUpdate update)) m) diff --git a/src/Telegram/Bot/Simple/InlineKeyboard.hs b/src/Telegram/Bot/Simple/InlineKeyboard.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/InlineKeyboard.hs @@ -0,0 +1,17 @@ +module Telegram.Bot.Simple.InlineKeyboard where + +import Data.Text (Text) +import qualified Data.Text as Text + +import Telegram.Bot.API + +urlButton :: Text -> Text -> InlineKeyboardButton +urlButton label url = (labeledInlineKeyboardButton label) + { inlineKeyboardButtonUrl = Just url} + +callbackButton :: Text -> Text -> InlineKeyboardButton +callbackButton label data_ = (labeledInlineKeyboardButton label) + { inlineKeyboardButtonCallbackData = Just data_} + +actionButton :: Show action => Text -> action -> InlineKeyboardButton +actionButton label = callbackButton label . Text.pack . show diff --git a/src/Telegram/Bot/Simple/Reply.hs b/src/Telegram/Bot/Simple/Reply.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/Reply.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +module Telegram.Bot.Simple.Reply where + +import Control.Applicative ((<|>)) +import Control.Monad.Reader +import Data.String +import Data.Text (Text) +import GHC.Generics (Generic) + +import Telegram.Bot.API as Telegram +import Telegram.Bot.Simple.Eff + +-- | Get current 'ChatId' if possible. +currentChatId :: BotM (Maybe ChatId) +currentChatId = do + mupdate <- asks botContextUpdate + pure $ updateChatId =<< mupdate + +getEditMessageId :: BotM (Maybe EditMessageId) +getEditMessageId = do + mupdate <- asks botContextUpdate + pure $ updateEditMessageId =<< mupdate + +updateEditMessageId :: Update -> Maybe EditMessageId +updateEditMessageId update + = EditInlineMessageId + <$> (callbackQueryInlineMessageId =<< updateCallbackQuery update) + <|> EditChatMessageId + <$> (SomeChatId . chatId . messageChat <$> message) + <*> (messageMessageId <$> message) + where + message = extractUpdateMessage update + +-- | Reply message parameters. +-- This is just like 'SendMessageRequest' but without 'SomeChatId' specified. +data ReplyMessage = ReplyMessage + { replyMessageText :: Text -- ^ Text of the message to be sent. + , replyMessageParseMode :: Maybe ParseMode -- ^ Send 'Markdown' or 'HTML', if you want Telegram apps to show bold, italic, fixed-width text or inline URLs in your bot's message. + , replyMessageDisableWebPagePreview :: Maybe Bool -- ^ Disables link previews for links in this message. + , replyMessageDisableNotification :: Maybe Bool -- ^ Sends the message silently. Users will receive a notification with no sound. + , replyMessageReplyToMessageId :: Maybe MessageId -- ^ If the message is a reply, ID of the original message. + , replyMessageReplyMarkup :: Maybe SomeReplyMarkup -- ^ 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 (Generic) + +instance IsString ReplyMessage where + fromString = toReplyMessage . fromString + +-- | Create a 'ReplyMessage' with just some 'Text' message. +toReplyMessage :: Text -> ReplyMessage +toReplyMessage text = ReplyMessage text Nothing Nothing Nothing Nothing Nothing + +replyMessageToSendMessageRequest :: SomeChatId -> ReplyMessage -> SendMessageRequest +replyMessageToSendMessageRequest someChatId ReplyMessage{..} = SendMessageRequest + { sendMessageChatId = someChatId + , sendMessageText = replyMessageText + , sendMessageParseMode = replyMessageParseMode + , sendMessageDisableWebPagePreview = replyMessageDisableWebPagePreview + , sendMessageDisableNotification = replyMessageDisableNotification + , sendMessageReplyToMessageId = replyMessageReplyToMessageId + , sendMessageReplyMarkup = replyMessageReplyMarkup + } + +-- | Reply in a chat with a given 'SomeChatId'. +replyTo :: SomeChatId -> ReplyMessage -> BotM () +replyTo someChatId rmsg = do + let msg = replyMessageToSendMessageRequest someChatId rmsg + void $ liftClientM $ sendMessage msg + +-- | Reply in the current chat (if possible). +reply :: ReplyMessage -> BotM () +reply rmsg = do + mchatId <- currentChatId + case mchatId of + Just chatId -> replyTo (SomeChatId chatId) rmsg + Nothing -> liftIO $ putStrLn "No chat to reply to" + +-- | Reply with a text. +replyText :: Text -> BotM () +replyText = reply . toReplyMessage + +data EditMessage = EditMessage + { editMessageText :: Text + , editMessageParseMode :: Maybe ParseMode + , editMessageDisableWebPagePreview :: Maybe Bool + , editMessageReplyMarkup :: Maybe SomeReplyMarkup + } + +instance IsString EditMessage where + fromString = toEditMessage . fromString + +data EditMessageId + = EditChatMessageId SomeChatId MessageId + | EditInlineMessageId MessageId + +toEditMessage :: Text -> EditMessage +toEditMessage msg = EditMessage msg Nothing Nothing Nothing + +editMessageToEditMessageTextRequest + :: EditMessageId -> EditMessage -> EditMessageTextRequest +editMessageToEditMessageTextRequest editMessageId EditMessage{..} + = EditMessageTextRequest + { editMessageTextText = editMessageText + , editMessageTextParseMode = editMessageParseMode + , editMessageTextDisableWebPagePreview = editMessageDisableWebPagePreview + , editMessageTextReplyMarkup = editMessageReplyMarkup + , .. + } + where + ( editMessageTextChatId, + editMessageTextMessageId, + editMessageTextInlineMessageId ) + = case editMessageId of + EditChatMessageId chatId messageId + -> (Just chatId, Just messageId, Nothing) + EditInlineMessageId messageId + -> (Nothing, Nothing, Just messageId) + +editMessageToReplyMessage :: EditMessage -> ReplyMessage +editMessageToReplyMessage EditMessage{..} = (toReplyMessage editMessageText) + { replyMessageParseMode = editMessageParseMode + , replyMessageDisableWebPagePreview = editMessageDisableWebPagePreview + , replyMessageReplyMarkup = editMessageReplyMarkup + } + +editMessage :: EditMessageId -> EditMessage -> BotM () +editMessage editMessageId emsg = do + let msg = editMessageToEditMessageTextRequest editMessageId emsg + void $ liftClientM $ Telegram.editMessageText msg + +editUpdateMessage :: EditMessage -> BotM () +editUpdateMessage emsg = do + mEditMessageId <- getEditMessageId + case mEditMessageId of + Just editMessageId -> editMessage editMessageId emsg + Nothing -> liftIO $ putStrLn "Can't find message to edit!" + +editUpdateMessageText :: Text -> BotM () +editUpdateMessageText = editUpdateMessage . toEditMessage + +replyOrEdit :: EditMessage -> BotM () +replyOrEdit emsg = do + uid <- asks (fmap userId . (messageFrom =<<) . (extractUpdateMessage =<<) . botContextUpdate) + botUserId <- asks (userId . botContextUser) + if uid == Just botUserId + then editUpdateMessage emsg + else reply (editMessageToReplyMessage emsg) diff --git a/src/Telegram/Bot/Simple/UpdateParser.hs b/src/Telegram/Bot/Simple/UpdateParser.hs new file mode 100644 --- /dev/null +++ b/src/Telegram/Bot/Simple/UpdateParser.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +module Telegram.Bot.Simple.UpdateParser where + +import Control.Applicative +import Control.Monad.Reader +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as Text +import Text.Read (readMaybe) + +import Telegram.Bot.API + +newtype UpdateParser a = UpdateParser + { runUpdateParser :: Update -> Maybe a + } deriving (Functor) + +instance Applicative UpdateParser where + pure x = UpdateParser (pure (pure x)) + UpdateParser f <*> UpdateParser x = UpdateParser (\u -> f u <*> x u) + +instance Alternative UpdateParser where + empty = UpdateParser (const Nothing) + UpdateParser f <|> UpdateParser g = UpdateParser (\u -> f u <|> g u) + +instance Monad UpdateParser where + return = pure + UpdateParser x >>= f = UpdateParser (\u -> x u >>= flip runUpdateParser u . f) + fail _ = empty + +mkParser :: (Update -> Maybe a) -> UpdateParser a +mkParser = UpdateParser + +parseUpdate :: UpdateParser a -> Update -> Maybe a +parseUpdate = runUpdateParser + +text :: UpdateParser Text +text = UpdateParser (updateMessage >=> messageText) + +plainText :: UpdateParser Text +plainText = do + t <- text + if "/" `Text.isPrefixOf` t + then fail "command" + else pure t + +command :: Text -> UpdateParser Text +command name = do + t <- text + case Text.words t of + (w:ws) | w == "/" <> name + -> pure (Text.unwords ws) + _ -> fail "not that command" + +callbackQueryDataRead :: Read a => UpdateParser a +callbackQueryDataRead = mkParser $ \update -> do + query <- updateCallbackQuery update + data_ <- callbackQueryData query + readMaybe (Text.unpack data_) + +updateMessageText :: Update -> Maybe Text +updateMessageText = updateMessage >=> messageText diff --git a/telegram-bot-simple.cabal b/telegram-bot-simple.cabal new file mode 100644 --- /dev/null +++ b/telegram-bot-simple.cabal @@ -0,0 +1,141 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4280984aa13d278dcdd078adc9dbae36453194881344c26a0dc1fb8e4f46ee35 + +name: telegram-bot-simple +version: 0.2.0 +synopsis: Easy to use library for building Telegram bots. +description: Please see the README on Github at +category: Web +homepage: https://github.com/fizruk/telegram-bot-simple#readme +bug-reports: https://github.com/fizruk/telegram-bot-simple/issues +author: Nickolay Kudasov +maintainer: nickolay.kudasov@gmail.com +copyright: Nickolay Kudasov +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/fizruk/telegram-bot-simple + +library + exposed-modules: + Telegram.Bot.API + Telegram.Bot.API.Games + Telegram.Bot.API.GettingUpdates + Telegram.Bot.API.InlineMode + Telegram.Bot.API.Internal.Utils + Telegram.Bot.API.MakingRequests + Telegram.Bot.API.Methods + Telegram.Bot.API.Payments + Telegram.Bot.API.Stickers + Telegram.Bot.API.Types + Telegram.Bot.API.UpdatingMessages + Telegram.Bot.Simple + Telegram.Bot.Simple.BotApp + Telegram.Bot.Simple.BotApp.Internal + Telegram.Bot.Simple.Conversation + Telegram.Bot.Simple.Debug + Telegram.Bot.Simple.Eff + Telegram.Bot.Simple.InlineKeyboard + Telegram.Bot.Simple.Reply + Telegram.Bot.Simple.UpdateParser + other-modules: + Paths_telegram_bot_simple + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson + , aeson-pretty + , base >=4.9 && <5 + , bytestring + , cron + , hashable + , http-api-data + , http-client + , http-client-tls + , monad-control + , mtl + , pretty-show + , profunctors + , servant + , servant-client + , split + , stm + , template-haskell + , text + , time + , transformers + , unordered-containers + default-language: Haskell2010 + +executable example-echo-bot + main-is: examples/EchoBot.hs + other-modules: + Paths_telegram_bot_simple + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-pretty + , base >=4.9 && <5 + , bytestring + , cron + , hashable + , http-api-data + , http-client + , http-client-tls + , monad-control + , mtl + , pretty-show + , profunctors + , servant + , servant-client + , split + , stm + , telegram-bot-simple + , template-haskell + , text + , time + , transformers + , unordered-containers + default-language: Haskell2010 + +executable example-todo-bot + main-is: examples/EchoBot.hs + other-modules: + Paths_telegram_bot_simple + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , aeson-pretty + , base >=4.9 && <5 + , bytestring + , cron + , hashable + , http-api-data + , http-client + , http-client-tls + , monad-control + , mtl + , pretty-show + , profunctors + , servant + , servant-client + , split + , stm + , telegram-bot-simple + , template-haskell + , text + , time + , transformers + , unordered-containers + default-language: Haskell2010