{-# 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