{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} module Telegram.Bot.API.Webhook ( setUpWebhook, webhookApp, deleteWebhook, SetWebhookRequest (..), ) where import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Monad.IO.Class (MonadIO (liftIO)) import Data.Aeson (ToJSON (toJSON)) import Data.Bool (bool) import Data.Functor (void, (<&>)) import Data.Maybe (catMaybes, fromJust, isJust) import qualified Data.Text as Text import GHC.Generics (Generic) import Servant import Servant.Client (ClientEnv, ClientError, client, runClientM) import Servant.Multipart.API import Servant.Multipart.Client (genBoundary) import Telegram.Bot.API.GettingUpdates (Update) import Telegram.Bot.API.Internal.Utils (gtoJSON) import Telegram.Bot.API.MakingRequests (Response) import Telegram.Bot.API.Types (InputFile, makeFile) import Telegram.Bot.Simple.BotApp.Internal type WebhookAPI = ReqBody '[JSON] Update :> Post '[JSON] () server :: BotApp model action -> BotEnv model action -> Server WebhookAPI server :: BotApp model action -> BotEnv model action -> Server WebhookAPI server BotApp {model [BotJob model action] action -> model -> Eff action model Update -> model -> Maybe action botJobs :: forall model action. BotApp model action -> [BotJob model action] botHandler :: forall model action. BotApp model action -> action -> model -> Eff action model botAction :: forall model action. BotApp model action -> Update -> model -> Maybe action botInitialModel :: forall model action. BotApp model action -> model botJobs :: [BotJob model action] botHandler :: action -> model -> Eff action model botAction :: Update -> model -> Maybe action botInitialModel :: model ..} botEnv :: BotEnv model action botEnv@BotEnv {TVar model TQueue (Maybe Update, action) User ClientEnv botUser :: forall model action. BotEnv model action -> User botClientEnv :: forall model action. BotEnv model action -> ClientEnv botActionsQueue :: forall model action. BotEnv model action -> TQueue (Maybe Update, action) botModelVar :: forall model action. BotEnv model action -> TVar model botUser :: User botClientEnv :: ClientEnv botActionsQueue :: TQueue (Maybe Update, action) botModelVar :: TVar model ..} = Server WebhookAPI Update -> Handler () updateHandler where updateHandler :: Update -> Handler () updateHandler :: Update -> Handler () updateHandler Update update = IO () -> Handler () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> Handler ()) -> IO () -> Handler () forall a b. (a -> b) -> a -> b $ Update -> IO () forall (m :: * -> *). MonadIO m => Update -> m () handleUpdate Update update handleUpdate :: Update -> m () handleUpdate Update update = IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . IO ThreadId -> IO () forall (f :: * -> *) a. Functor f => f a -> f () void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . IO () -> IO ThreadId forkIO (IO () -> m ()) -> IO () -> m () forall a b. (a -> b) -> a -> b $ do Maybe action maction <- Update -> model -> Maybe action botAction Update update (model -> Maybe action) -> IO model -> IO (Maybe action) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> TVar model -> IO model forall a. TVar a -> IO a readTVarIO TVar model botModelVar case Maybe action maction of Maybe action Nothing -> () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () Just action action -> BotEnv model action -> Maybe Update -> Maybe action -> IO () forall model action. BotEnv model action -> Maybe Update -> Maybe action -> IO () issueAction BotEnv model action botEnv (Update -> Maybe Update forall a. a -> Maybe a Just Update update) (action -> Maybe action forall a. a -> Maybe a Just action action) webhookAPI :: Proxy WebhookAPI webhookAPI :: Proxy WebhookAPI webhookAPI = Proxy WebhookAPI forall k (t :: k). Proxy t Proxy app :: BotApp model action -> BotEnv model action -> Application app :: BotApp model action -> BotEnv model action -> Application app BotApp model action botApp BotEnv model action botEnv = Proxy WebhookAPI -> Server WebhookAPI -> Application forall api. HasServer api '[] => Proxy api -> Server api -> Application serve Proxy WebhookAPI webhookAPI (Server WebhookAPI -> Application) -> Server WebhookAPI -> Application forall a b. (a -> b) -> a -> b $ BotApp model action -> BotEnv model action -> Server WebhookAPI forall model action. BotApp model action -> BotEnv model action -> Server WebhookAPI server BotApp model action botApp BotEnv model action botEnv data SetWebhookRequest = SetWebhookRequest { SetWebhookRequest -> String setWebhookUrl :: String, SetWebhookRequest -> Maybe InputFile setWebhookCertificate :: Maybe InputFile, SetWebhookRequest -> Maybe String setWebhookIpAddress :: Maybe String, SetWebhookRequest -> Maybe Int setWebhookMaxConnections :: Maybe Int, SetWebhookRequest -> Maybe [String] setWebhookAllowedUpdates :: Maybe [String], SetWebhookRequest -> Maybe Bool setWebhookDropPendingUpdates :: Maybe Bool, SetWebhookRequest -> Maybe String setWebhookSecretToken :: Maybe String } deriving ((forall x. SetWebhookRequest -> Rep SetWebhookRequest x) -> (forall x. Rep SetWebhookRequest x -> SetWebhookRequest) -> Generic SetWebhookRequest forall x. Rep SetWebhookRequest x -> SetWebhookRequest forall x. SetWebhookRequest -> Rep SetWebhookRequest x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep SetWebhookRequest x -> SetWebhookRequest $cfrom :: forall x. SetWebhookRequest -> Rep SetWebhookRequest x Generic) instance ToJSON SetWebhookRequest where toJSON :: SetWebhookRequest -> Value toJSON = SetWebhookRequest -> Value forall a (d :: Meta) (f :: * -> *). (Generic a, GToJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) => a -> Value gtoJSON newtype DeleteWebhookRequest = DeleteWebhookRequest { DeleteWebhookRequest -> Maybe Bool deleteWebhookDropPendingUpdates :: Maybe Bool } deriving ((forall x. DeleteWebhookRequest -> Rep DeleteWebhookRequest x) -> (forall x. Rep DeleteWebhookRequest x -> DeleteWebhookRequest) -> Generic DeleteWebhookRequest forall x. Rep DeleteWebhookRequest x -> DeleteWebhookRequest forall x. DeleteWebhookRequest -> Rep DeleteWebhookRequest x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep DeleteWebhookRequest x -> DeleteWebhookRequest $cfrom :: forall x. DeleteWebhookRequest -> Rep DeleteWebhookRequest x Generic) instance ToJSON DeleteWebhookRequest where toJSON :: DeleteWebhookRequest -> Value toJSON = DeleteWebhookRequest -> Value forall a (d :: Meta) (f :: * -> *). (Generic a, GToJSON Zero (Rep a), Rep a ~ D1 d f, Datatype d) => a -> Value gtoJSON instance ToMultipart Tmp SetWebhookRequest where toMultipart :: SetWebhookRequest -> MultipartData Tmp toMultipart SetWebhookRequest {String Maybe Bool Maybe Int Maybe String Maybe [String] Maybe InputFile setWebhookSecretToken :: Maybe String setWebhookDropPendingUpdates :: Maybe Bool setWebhookAllowedUpdates :: Maybe [String] setWebhookMaxConnections :: Maybe Int setWebhookIpAddress :: Maybe String setWebhookCertificate :: Maybe InputFile setWebhookUrl :: String setWebhookSecretToken :: SetWebhookRequest -> Maybe String setWebhookDropPendingUpdates :: SetWebhookRequest -> Maybe Bool setWebhookAllowedUpdates :: SetWebhookRequest -> Maybe [String] setWebhookMaxConnections :: SetWebhookRequest -> Maybe Int setWebhookIpAddress :: SetWebhookRequest -> Maybe String setWebhookCertificate :: SetWebhookRequest -> Maybe InputFile setWebhookUrl :: SetWebhookRequest -> String ..} = Text -> InputFile -> MultipartData Tmp -> MultipartData Tmp makeFile Text "certificate" (Maybe InputFile -> InputFile forall a. HasCallStack => Maybe a -> a fromJust Maybe InputFile setWebhookCertificate) ([Input] -> [FileData Tmp] -> MultipartData Tmp forall tag. [Input] -> [FileData tag] -> MultipartData tag MultipartData [Input] fields []) where fields :: [Input] fields = [Text -> Text -> Input Input Text "url" (Text -> Input) -> Text -> Input forall a b. (a -> b) -> a -> b $ String -> Text Text.pack String setWebhookUrl] [Input] -> [Input] -> [Input] forall a. Semigroup a => a -> a -> a <> [Maybe Input] -> [Input] forall a. [Maybe a] -> [a] catMaybes [ Maybe String setWebhookSecretToken Maybe String -> (String -> Input) -> Maybe Input forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \String t -> Text -> Text -> Input Input Text "secret_token" (Text -> Input) -> Text -> Input forall a b. (a -> b) -> a -> b $ String -> Text Text.pack String t, Maybe String setWebhookIpAddress Maybe String -> (String -> Input) -> Maybe Input forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \String t -> Text -> Text -> Input Input Text "ip_address" (Text -> Input) -> Text -> Input forall a b. (a -> b) -> a -> b $ String -> Text Text.pack String t, Maybe Int setWebhookMaxConnections Maybe Int -> (Int -> Input) -> Maybe Input forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \Int t -> Text -> Text -> Input Input Text "max_connections" (Text -> Input) -> Text -> Input forall a b. (a -> b) -> a -> b $ String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ Int -> String forall a. Show a => a -> String show Int t, Maybe Bool setWebhookDropPendingUpdates Maybe Bool -> (Bool -> Input) -> Maybe Input forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \Bool t -> Text -> Text -> Input Input Text "drop_pending_updates" (Text -> Text -> Bool -> Text forall a. a -> a -> Bool -> a bool Text "false" Text "true" Bool t), Maybe [String] setWebhookAllowedUpdates Maybe [String] -> ([String] -> Input) -> Maybe Input forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \[String] t -> Text -> Text -> Input Input Text "allowed_updates" ([String] -> Text arrToJson [String] t) ] arrToJson :: [String] -> Text arrToJson [String] arr = Text -> [Text] -> Text Text.intercalate Text "" [Text "[", Text -> [Text] -> Text Text.intercalate Text "," ((String -> Text) -> [String] -> [Text] forall a b. (a -> b) -> [a] -> [b] map (\String s -> String -> Text Text.pack (String -> Text) -> String -> Text forall a b. (a -> b) -> a -> b $ String "\"" String -> String -> String forall a. [a] -> [a] -> [a] ++ String s String -> String -> String forall a. [a] -> [a] -> [a] ++ String "\"") [String] arr), Text "]"] type SetWebhookForm = "setWebhook" :> MultipartForm Tmp SetWebhookRequest :> Get '[JSON] (Response Bool) type SetWebhookJson = "setWebhook" :> ReqBody '[JSON] SetWebhookRequest :> Get '[JSON] (Response Bool) type DeleteWebhook = "deleteWebhook" :> ReqBody '[JSON] DeleteWebhookRequest :> Get '[JSON] (Response Bool) setUpWebhook :: SetWebhookRequest -> ClientEnv -> IO (Either ClientError ()) setUpWebhook :: SetWebhookRequest -> ClientEnv -> IO (Either ClientError ()) setUpWebhook SetWebhookRequest requestData = (Either ClientError (Response Bool) -> Either ClientError () forall (f :: * -> *) a. Functor f => f a -> f () void (Either ClientError (Response Bool) -> Either ClientError ()) -> IO (Either ClientError (Response Bool)) -> IO (Either ClientError ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) (IO (Either ClientError (Response Bool)) -> IO (Either ClientError ())) -> (ClientEnv -> IO (Either ClientError (Response Bool))) -> ClientEnv -> IO (Either ClientError ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ClientM (Response Bool) -> ClientEnv -> IO (Either ClientError (Response Bool)) forall a. ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM ClientM (Response Bool) setUpWebhookRequest where setUpWebhookRequest :: ClientM (Response Bool) setUpWebhookRequest = if Maybe InputFile -> Bool forall a. Maybe a -> Bool isJust (Maybe InputFile -> Bool) -> Maybe InputFile -> Bool forall a b. (a -> b) -> a -> b $ SetWebhookRequest -> Maybe InputFile setWebhookCertificate SetWebhookRequest requestData then do ByteString boundary <- IO ByteString -> ClientM ByteString forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO IO ByteString genBoundary Proxy SetWebhookForm -> (ByteString, SetWebhookRequest) -> ClientM (Response Bool) forall api. HasClient ClientM api => Proxy api -> Client ClientM api client (Proxy SetWebhookForm forall k (t :: k). Proxy t Proxy @SetWebhookForm) (ByteString boundary, SetWebhookRequest requestData) else Proxy SetWebhookJson -> SetWebhookRequest -> ClientM (Response Bool) forall api. HasClient ClientM api => Proxy api -> Client ClientM api client (Proxy SetWebhookJson forall k (t :: k). Proxy t Proxy @SetWebhookJson) SetWebhookRequest requestData deleteWebhook :: ClientEnv -> IO (Either ClientError ()) deleteWebhook :: ClientEnv -> IO (Either ClientError ()) deleteWebhook = (Either ClientError (Response Bool) -> Either ClientError () forall (f :: * -> *) a. Functor f => f a -> f () void (Either ClientError (Response Bool) -> Either ClientError ()) -> IO (Either ClientError (Response Bool)) -> IO (Either ClientError ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$>) (IO (Either ClientError (Response Bool)) -> IO (Either ClientError ())) -> (ClientEnv -> IO (Either ClientError (Response Bool))) -> ClientEnv -> IO (Either ClientError ()) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ClientM (Response Bool) -> ClientEnv -> IO (Either ClientError (Response Bool)) forall a. ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM ClientM (Response Bool) deleteWebhookRequest where requestData :: DeleteWebhookRequest requestData = DeleteWebhookRequest :: Maybe Bool -> DeleteWebhookRequest DeleteWebhookRequest {deleteWebhookDropPendingUpdates :: Maybe Bool deleteWebhookDropPendingUpdates = Maybe Bool forall a. Maybe a Nothing} deleteWebhookRequest :: ClientM (Response Bool) deleteWebhookRequest = Proxy DeleteWebhook -> DeleteWebhookRequest -> ClientM (Response Bool) forall api. HasClient ClientM api => Proxy api -> Client ClientM api client (Proxy DeleteWebhook forall k (t :: k). Proxy t Proxy @DeleteWebhook) DeleteWebhookRequest requestData webhookApp :: BotApp model action -> BotEnv model action -> Application webhookApp :: BotApp model action -> BotEnv model action -> Application webhookApp = BotApp model action -> BotEnv model action -> Application forall model action. BotApp model action -> BotEnv model action -> Application app