{-# 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 :: forall model action.
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
..} =
  Update -> Handler ()
updateHandler
  where
    updateHandler :: Update -> Handler ()
    updateHandler :: Update -> Handler ()
updateHandler Update
update = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadIO m => Update -> m ()
handleUpdate Update
update
    handleUpdate :: Update -> m ()
handleUpdate Update
update = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
      Maybe action
maction <- Update -> model -> Maybe action
botAction Update
update forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar model
botModelVar
      case Maybe action
maction of
        Maybe action
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just action
action -> forall model action.
BotEnv model action -> Maybe Update -> Maybe action -> IO ()
issueAction BotEnv model action
botEnv (forall a. a -> Maybe a
Just Update
update) (forall a. a -> Maybe a
Just action
action)

webhookAPI :: Proxy WebhookAPI
webhookAPI :: Proxy WebhookAPI
webhookAPI = forall {k} (t :: k). Proxy t
Proxy

app :: BotApp model action -> BotEnv model action -> Application
app :: forall model action.
BotApp model action -> BotEnv model action -> Application
app BotApp model action
botApp BotEnv model action
botEnv = forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy WebhookAPI
webhookAPI forall a b. (a -> b) -> a -> b
$ 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. 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 = 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. 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 = 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" (forall a. HasCallStack => Maybe a -> a
fromJust Maybe InputFile
setWebhookCertificate) (forall tag. [Input] -> [FileData tag] -> MultipartData tag
MultipartData [Input]
fields [])
    where
      fields :: [Input]
fields =
        [Text -> Text -> Input
Input Text
"url" forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
setWebhookUrl]
          forall a. Semigroup a => a -> a -> a
<> forall a. [Maybe a] -> [a]
catMaybes
            [ Maybe String
setWebhookSecretToken forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
t -> Text -> Text -> Input
Input Text
"secret_token" forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
t,
              Maybe String
setWebhookIpAddress forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
t -> Text -> Text -> Input
Input Text
"ip_address" forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
t,
              Maybe Int
setWebhookMaxConnections forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Int
t -> Text -> Text -> Input
Input Text
"max_connections" forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
t,
              Maybe Bool
setWebhookDropPendingUpdates forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
t -> Text -> Text -> Input
Input Text
"drop_pending_updates" (forall a. a -> a -> Bool -> a
bool Text
"false" Text
"true" Bool
t),
              Maybe [String]
setWebhookAllowedUpdates 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
"," (forall a b. (a -> b) -> [a] -> [b]
map (\String
s -> String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. [a] -> [a] -> [a]
++ String
s 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 = (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM (Response Bool)
setUpWebhookRequest
  where
    setUpWebhookRequest :: ClientM (Response Bool)
setUpWebhookRequest =
      if forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ SetWebhookRequest -> Maybe InputFile
setWebhookCertificate SetWebhookRequest
requestData
        then do
          ByteString
boundary <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
genBoundary
          forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (forall {k} (t :: k). Proxy t
Proxy @SetWebhookForm) (ByteString
boundary, SetWebhookRequest
requestData)
        else forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (forall {k} (t :: k). Proxy t
Proxy @SetWebhookJson) SetWebhookRequest
requestData

deleteWebhook :: ClientEnv -> IO (Either ClientError ())
deleteWebhook :: ClientEnv -> IO (Either ClientError ())
deleteWebhook = (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
runClientM ClientM (Response Bool)
deleteWebhookRequest
  where
    requestData :: DeleteWebhookRequest
requestData = DeleteWebhookRequest {deleteWebhookDropPendingUpdates :: Maybe Bool
deleteWebhookDropPendingUpdates = forall a. Maybe a
Nothing}
    deleteWebhookRequest :: ClientM (Response Bool)
deleteWebhookRequest = forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
client (forall {k} (t :: k). Proxy t
Proxy @DeleteWebhook) DeleteWebhookRequest
requestData

webhookApp :: BotApp model action -> BotEnv model action -> Application
webhookApp :: forall model action.
BotApp model action -> BotEnv model action -> Application
webhookApp = forall model action.
BotApp model action -> BotEnv model action -> Application
app