module Network.Pusher.Webhook
  ( Webhooks (..),
    WebhookEv (..),
    WebhookPayload (..),
    parseAppKeyHdr,
    parseAuthSignatureHdr,
    parseWebhooksBody,
    verifyWebhooksBody,
    parseWebhookPayloadWith,
  )
where

import qualified Crypto.Hash as HASH
import qualified Crypto.MAC.HMAC as HMAC
import Data.Aeson ((.:))
import qualified Data.Aeson as A
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BC
import Data.ByteString.Lazy (fromStrict)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (toLower)
import Data.Function (on)
import Data.Maybe (listToMaybe, mapMaybe)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word64)
import Network.Pusher.Protocol (User (..))

-- | A Webhook is received by POST request from Pusher to notify your server of
--  a number of 'WebhookEv's. Multiple events are received under the same
--  timestamp if batch events is enabled.
data Webhooks
  = Webhooks
      { Webhooks -> Word64
timeMs :: Word64,
        Webhooks -> [WebhookEv]
webhookEvs :: [WebhookEv]
      }
  deriving (Webhooks -> Webhooks -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Webhooks -> Webhooks -> Bool
$c/= :: Webhooks -> Webhooks -> Bool
== :: Webhooks -> Webhooks -> Bool
$c== :: Webhooks -> Webhooks -> Bool
Eq, Int -> Webhooks -> ShowS
[Webhooks] -> ShowS
Webhooks -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Webhooks] -> ShowS
$cshowList :: [Webhooks] -> ShowS
show :: Webhooks -> String
$cshow :: Webhooks -> String
showsPrec :: Int -> Webhooks -> ShowS
$cshowsPrec :: Int -> Webhooks -> ShowS
Show)

instance A.FromJSON Webhooks where
  parseJSON :: Value -> Parser Webhooks
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Webhooks" forall a b. (a -> b) -> a -> b
$ \Object
v ->
      Word64 -> [WebhookEv] -> Webhooks
Webhooks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"time_ms" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"events"

-- | A 'WebhookEv' is one of several events Pusher may send to your server in
--  response to events your users may trigger.
data WebhookEv
  = -- | A channel has become occupied. There is > 1 subscriber.
    ChannelOccupiedEv {WebhookEv -> Text
onChannel :: T.Text}
  | -- | A channel has become vacated. There are 0 subscribers.
    ChannelVacatedEv {onChannel :: T.Text}
  | -- | A new user has subscribed to a presence channel.
    MemberAddedEv
      { onChannel :: T.Text,
        WebhookEv -> User
withUser :: User
      }
  | -- | A user has unsubscribed from a presence channel.
    MemberRemovedEv
      { onChannel :: T.Text,
        withUser :: User
      }
  | -- | A client has sent a named client event with some json body. They have a
    --  socket_id and a 'User' if they were in a presence channel.
    ClientEv
      { onChannel :: T.Text,
        WebhookEv -> Text
clientEvName :: T.Text,
        WebhookEv -> Maybe Value
clientEvBody :: Maybe A.Value,
        WebhookEv -> Text
withSocketId :: T.Text,
        WebhookEv -> Maybe User
withPossibleUser :: Maybe User
      }
  deriving (WebhookEv -> WebhookEv -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WebhookEv -> WebhookEv -> Bool
$c/= :: WebhookEv -> WebhookEv -> Bool
== :: WebhookEv -> WebhookEv -> Bool
$c== :: WebhookEv -> WebhookEv -> Bool
Eq, Int -> WebhookEv -> ShowS
[WebhookEv] -> ShowS
WebhookEv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebhookEv] -> ShowS
$cshowList :: [WebhookEv] -> ShowS
show :: WebhookEv -> String
$cshow :: WebhookEv -> String
showsPrec :: Int -> WebhookEv -> ShowS
$cshowsPrec :: Int -> WebhookEv -> ShowS
Show)

instance A.FromJSON WebhookEv where
  parseJSON :: Value -> Parser WebhookEv
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Webhooks" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
      Text
name <- Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
      case Text
name :: T.Text of
        Text
"channel_occupied" -> Text -> WebhookEv
ChannelOccupiedEv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"channel"
        Text
"channel_vacated" -> Text -> WebhookEv
ChannelVacatedEv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"channel"
        Text
"member_added" ->
          Text -> User -> WebhookEv
MemberAddedEv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"channel" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> User
User forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_id")
        Text
"member_removed" ->
          Text -> User -> WebhookEv
MemberRemovedEv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"channel" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> User
User forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_id")
        Text
"client_event" ->
          Text -> Text -> Maybe Value -> Text -> Maybe User -> WebhookEv
ClientEv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"channel" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. FromJSON a => ByteString -> Maybe a
A.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data")
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"socket_id"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> User
User forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"user_id")
        Text
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Unknown client event. Got: " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Object
v

data WebhookPayload
  = WebhookPayload
      { -- | Authentication header. The oldest active token is used, identified by
        --  this key.
        WebhookPayload -> ByteString
xPusherKey :: B.ByteString,
        -- | A HMAC SHA256 formed by signing the payload with the tokens secret.
        WebhookPayload -> ByteString
xPusherSignature :: B.ByteString,
        WebhookPayload -> Webhooks
webhooks :: Webhooks
      }
  deriving (WebhookPayload -> WebhookPayload -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WebhookPayload -> WebhookPayload -> Bool
$c/= :: WebhookPayload -> WebhookPayload -> Bool
== :: WebhookPayload -> WebhookPayload -> Bool
$c== :: WebhookPayload -> WebhookPayload -> Bool
Eq, Int -> WebhookPayload -> ShowS
[WebhookPayload] -> ShowS
WebhookPayload -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WebhookPayload] -> ShowS
$cshowList :: [WebhookPayload] -> ShowS
show :: WebhookPayload -> String
$cshow :: WebhookPayload -> String
showsPrec :: Int -> WebhookPayload -> ShowS
$cshowsPrec :: Int -> WebhookPayload -> ShowS
Show)

-- | Given a HTTP Header and its associated value, parse an app key.
parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString
parseAppKeyHdr :: ByteString -> ByteString -> Maybe ByteString
parseAppKeyHdr ByteString
key ByteString
value
  | forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) ((Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower) ByteString
key ByteString
"X-Pusher-Key" = forall a. a -> Maybe a
Just ByteString
value
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Given a HTTP Header and its associated value, parse an auth signature.
parseAuthSignatureHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString
parseAuthSignatureHdr :: ByteString -> ByteString -> Maybe ByteString
parseAuthSignatureHdr ByteString
key ByteString
value
  | forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on forall a. Eq a => a -> a -> Bool
(==) ((Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower) ByteString
key ByteString
"X-Pusher-Signature" = forall a. a -> Maybe a
Just ByteString
value
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Given a HTTP body, parse the contained webhooks.
parseWebhooksBody :: BC.ByteString -> Maybe Webhooks
parseWebhooksBody :: ByteString -> Maybe Webhooks
parseWebhooksBody = forall a. FromJSON a => ByteString -> Maybe a
A.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict

-- | Does a webhook body hash with our secret key to the given signature?
verifyWebhooksBody :: B.ByteString -> B.ByteString -> BC.ByteString -> Bool
verifyWebhooksBody :: ByteString -> ByteString -> ByteString -> Bool
verifyWebhooksBody ByteString
appSecret ByteString
authSignature ByteString
body =
  let actualSignature :: ByteString
actualSignature =
        ByteString -> ByteString
B16.encode forall a b. (a -> b) -> a -> b
$ forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac ByteString
appSecret ByteString
body :: HMAC.HMAC HASH.SHA256)
   in ByteString
authSignature forall a. Eq a => a -> a -> Bool
== ByteString
actualSignature

-- | Given a list of http header key:values, a http body and a lookup function
--  for an apps secret, parse and validate a  potential webhook payload.
parseWebhookPayloadWith ::
  (B.ByteString -> Maybe B.ByteString) ->
  [(BC.ByteString, BC.ByteString)] ->
  BC.ByteString ->
  Maybe WebhookPayload
parseWebhookPayloadWith :: (ByteString -> Maybe ByteString)
-> [(ByteString, ByteString)] -> ByteString -> Maybe WebhookPayload
parseWebhookPayloadWith ByteString -> Maybe ByteString
lookupKeysSecret [(ByteString, ByteString)]
headers ByteString
body = do
  ByteString
appKey <- forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Maybe ByteString
parseAppKeyHdr) forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)]
headers
  ByteString
authSignature <- forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Maybe ByteString
parseAuthSignatureHdr) forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)]
headers
  ByteString
appSecret <- ByteString -> Maybe ByteString
lookupKeysSecret ByteString
appKey
  () <-
    if ByteString -> ByteString -> ByteString -> Bool
verifyWebhooksBody ByteString
appSecret ByteString
authSignature ByteString
body
      then forall a. a -> Maybe a
Just ()
      else forall a. Maybe a
Nothing
  Webhooks
whs <- ByteString -> Maybe Webhooks
parseWebhooksBody ByteString
body
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Webhooks -> WebhookPayload
WebhookPayload ByteString
appKey ByteString
authSignature Webhooks
whs