{-# 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, deleteWebhook, SetWebhookRequest (..), defSetWebhook, defDeleteWebhook ) where 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.Internal.Utils (gtoJSON) import Telegram.Bot.API.MakingRequests (Response) import Telegram.Bot.API.Types (InputFile, makeFile) import Telegram.Bot.API.Internal.TH (makeDefault) data SetWebhookRequest = SetWebhookRequest { setWebhookUrl :: String, setWebhookCertificate :: Maybe InputFile, setWebhookIpAddress :: Maybe String, setWebhookMaxConnections :: Maybe Int, setWebhookAllowedUpdates :: Maybe [String], setWebhookDropPendingUpdates :: Maybe Bool, setWebhookSecretToken :: Maybe String } deriving (Generic) instance ToJSON SetWebhookRequest where toJSON = gtoJSON newtype DeleteWebhookRequest = DeleteWebhookRequest { deleteWebhookDropPendingUpdates :: Maybe Bool } deriving (Generic) instance ToJSON DeleteWebhookRequest where toJSON = gtoJSON instance ToMultipart Tmp SetWebhookRequest where toMultipart SetWebhookRequest {..} = makeFile "certificate" (fromJust setWebhookCertificate) (MultipartData fields []) where fields = [Input "url" $ Text.pack setWebhookUrl] <> catMaybes [ setWebhookSecretToken <&> \t -> Input "secret_token" $ Text.pack t, setWebhookIpAddress <&> \t -> Input "ip_address" $ Text.pack t, setWebhookMaxConnections <&> \t -> Input "max_connections" $ Text.pack $ show t, setWebhookDropPendingUpdates <&> \t -> Input "drop_pending_updates" (bool "false" "true" t), setWebhookAllowedUpdates <&> \t -> Input "allowed_updates" (arrToJson t) ] arrToJson arr = Text.intercalate "" ["[", Text.intercalate "," (map (\s -> Text.pack $ "\"" ++ s ++ "\"") arr), "]"] 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 requestData = (void <$>) <$> runClientM setUpWebhookRequest where setUpWebhookRequest = if isJust $ setWebhookCertificate requestData then do boundary <- liftIO genBoundary client (Proxy @SetWebhookForm) (boundary, requestData) else client (Proxy @SetWebhookJson) requestData deleteWebhook :: ClientEnv -> IO (Either ClientError ()) deleteWebhook = (void <$>) <$> runClientM deleteWebhookRequest where requestData = DeleteWebhookRequest {deleteWebhookDropPendingUpdates = Nothing} deleteWebhookRequest = client (Proxy @DeleteWebhook) requestData foldMap makeDefault [ ''SetWebhookRequest , ''DeleteWebhookRequest ]