{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- |
-- Module      : Line.Bot.Webhook
-- Copyright   : (c) Alexandre Moreno, 2019-2021
-- License     : BSD-3-Clause
-- Maintainer  : alexmorenocano@gmail.com
-- Stability   : experimental

module Line.Bot.Webhook
  ( Webhook
  , webhook
  , LineReqBody
  , module Events
  )
where

import           Control.Monad            (forM_)
import           Control.Monad.IO.Class   (MonadIO, liftIO)
import qualified Crypto.Hash.SHA256       as SHA256
import qualified Data.ByteString          as B
import qualified Data.ByteString.Base64   as Base64
import qualified Data.ByteString.Lazy     as BL
import           Data.Maybe               (fromMaybe)
import           Data.Proxy
import           Data.String.Conversions  (cs)
import           Data.Typeable            (Typeable)
import           Line.Bot.Types           (ChannelSecret (..))
import           Line.Bot.Webhook.Events  as Events
import           Network.HTTP.Types       (HeaderName, hContentType)
import           Network.Wai              (lazyRequestBody,
                                           requestHeaders)
import           Servant
import           Servant.API.ContentTypes
import           Servant.Server.Internal

-- | This type alias just specifies how webhook requests should be handled
type Webhook = LineReqBody '[JSON] Events :> Post '[JSON] NoContent

-- | Helper function that takes a handler to process 'Webhook' events:
--
-- > server :: Server Webhook
-- > server = webhook $ \case
-- >   EventMessage { message, replyToken } = handleMessage message replyToken
-- >   _                                    = return ()
webhook :: MonadIO m => (Event -> m a) -> Events -> m NoContent
webhook :: (Event -> m a) -> Events -> m NoContent
webhook Event -> m a
k Events{[Event]
Id 'User
$sel:events:Events :: Events -> [Event]
$sel:destination:Events :: Events -> Id 'User
events :: [Event]
destination :: Id 'User
..} = [Event] -> (Event -> m a) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Event]
events Event -> m a
k m () -> m NoContent -> m NoContent
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NoContent -> m NoContent
forall (m :: * -> *) a. Monad m => a -> m a
return NoContent
NoContent

-- | A Servant combinator that extracts the request body as a value of type a
-- and performs signature valiadation
data LineReqBody (contentTypes :: [*]) (a :: *)
  deriving (Typeable)

instance (AllCTUnrender list a, HasServer api context, HasContextEntry context ChannelSecret)
  => HasServer (LineReqBody list a :> api) context where

  type ServerT (LineReqBody list a :> api) m = a -> ServerT api m

  hoistServerWithContext :: Proxy (LineReqBody list a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (LineReqBody list a :> api) m
-> ServerT (LineReqBody list a :> api) n
hoistServerWithContext Proxy (LineReqBody list a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (LineReqBody list a :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (a -> ServerT api m) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (LineReqBody list a :> api) m
a -> ServerT api m
s

  route :: Proxy (LineReqBody list a :> api)
-> Context context
-> Delayed env (Server (LineReqBody list a :> api))
-> Router env
route Proxy (LineReqBody list a :> api)
Proxy Context context
context Delayed env (Server (LineReqBody list a :> api))
subserver
      = Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
          Delayed env (a -> Server api)
-> DelayedIO (ByteString -> Either String a)
-> ((ByteString -> Either String a) -> DelayedIO a)
-> Delayed env (Server api)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (LineReqBody list a :> api))
Delayed env (a -> Server api)
subserver DelayedIO (ByteString -> Either String a)
ctCheck (ByteString -> Either String a) -> DelayedIO a
forall a a.
ConvertibleStrings a ByteString =>
(ByteString -> Either a a) -> DelayedIO a
bodyCheck
    where
      ctCheck :: DelayedIO (ByteString -> Either String a)
ctCheck = (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (ByteString -> Either String a))
 -> DelayedIO (ByteString -> Either String a))
-> (Request -> DelayedIO (ByteString -> Either String a))
-> DelayedIO (ByteString -> Either String a)
forall a b. (a -> b) -> a -> b
$ \Request
request -> do
        let contentTypeH :: ByteString
contentTypeH = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octet-stream"
                         (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
request
        case Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
forall (list :: [*]) a.
AllCTUnrender list a =>
Proxy list -> ByteString -> Maybe (ByteString -> Either String a)
canHandleCTypeH (Proxy list
forall k (t :: k). Proxy t
Proxy :: Proxy list) (ByteString -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
contentTypeH) :: Maybe (BL.ByteString -> Either String a) of
          Maybe (ByteString -> Either String a)
Nothing -> ServerError -> DelayedIO (ByteString -> Either String a)
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just ByteString -> Either String a
f  -> (ByteString -> Either String a)
-> DelayedIO (ByteString -> Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString -> Either String a
f

      bodyCheck :: (ByteString -> Either a a) -> DelayedIO a
bodyCheck ByteString -> Either a a
f = (Request -> DelayedIO a) -> DelayedIO a
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO a) -> DelayedIO a)
-> (Request -> DelayedIO a) -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ \ Request
request -> do
        ByteString
rawBody <- IO ByteString -> DelayedIO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> DelayedIO ByteString)
-> IO ByteString -> DelayedIO ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
lazyRequestBody Request
request
        let signatureH :: Maybe ByteString
signatureH = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hSignature ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
request

        if Maybe ByteString -> ByteString -> Bool
validateReqBody Maybe ByteString
signatureH ByteString
rawBody
          then case ByteString -> Either a a
f ByteString
rawBody of
             Left a
e  -> ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err400 { errBody :: ByteString
errBody = a -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs a
e }
             Right a
v -> a -> DelayedIO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
          else ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal ServerError
err401

      channelSecret :: ChannelSecret
      channelSecret :: ChannelSecret
channelSecret = Context context -> ChannelSecret
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context context
context

      hSignature :: HeaderName
      hSignature :: HeaderName
hSignature = HeaderName
"X-Line-Signature"

      validateReqBody :: Maybe B.ByteString -> BL.ByteString -> Bool
      validateReqBody :: Maybe ByteString -> ByteString -> Bool
validateReqBody Maybe ByteString
digest ByteString
body = Maybe ByteString
digest' Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString -> ByteString
SHA256.hmaclazy ByteString
secret ByteString
body)
        where
          digest' :: Maybe ByteString
digest' = ByteString -> ByteString
Base64.decodeLenient (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ByteString
digest
          secret :: ByteString
secret  = ChannelSecret -> ByteString
unChannelSecret ChannelSecret
channelSecret