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
(Webhooks -> Webhooks -> Bool)
-> (Webhooks -> Webhooks -> Bool) -> Eq Webhooks
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
(Int -> Webhooks -> ShowS)
-> (Webhooks -> String) -> ([Webhooks] -> ShowS) -> Show Webhooks
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 =
    String -> (Object -> Parser Webhooks) -> Value -> Parser Webhooks
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Webhooks" ((Object -> Parser Webhooks) -> Value -> Parser Webhooks)
-> (Object -> Parser Webhooks) -> Value -> Parser Webhooks
forall a b. (a -> b) -> a -> b
$ \Object
v ->
      Word64 -> [WebhookEv] -> Webhooks
Webhooks (Word64 -> [WebhookEv] -> Webhooks)
-> Parser Word64 -> Parser ([WebhookEv] -> Webhooks)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"time_ms" Parser ([WebhookEv] -> Webhooks)
-> Parser [WebhookEv] -> Parser Webhooks
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser [WebhookEv]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"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
(WebhookEv -> WebhookEv -> Bool)
-> (WebhookEv -> WebhookEv -> Bool) -> Eq WebhookEv
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
(Int -> WebhookEv -> ShowS)
-> (WebhookEv -> String)
-> ([WebhookEv] -> ShowS)
-> Show WebhookEv
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 =
    String -> (Object -> Parser WebhookEv) -> Value -> Parser WebhookEv
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Webhooks" ((Object -> Parser WebhookEv) -> Value -> Parser WebhookEv)
-> (Object -> Parser WebhookEv) -> Value -> Parser WebhookEv
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
      Text
name <- Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name"
      case Text
name :: T.Text of
        Text
"channel_occupied" -> Text -> WebhookEv
ChannelOccupiedEv (Text -> WebhookEv) -> Parser Text -> Parser WebhookEv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"channel"
        Text
"channel_vacated" -> Text -> WebhookEv
ChannelVacatedEv (Text -> WebhookEv) -> Parser Text -> Parser WebhookEv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"channel"
        Text
"member_added" ->
          Text -> User -> WebhookEv
MemberAddedEv (Text -> User -> WebhookEv)
-> Parser Text -> Parser (User -> WebhookEv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"channel" Parser (User -> WebhookEv) -> Parser User -> Parser WebhookEv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> User
User (Text -> User) -> Parser Text -> Parser User
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"user_id")
        Text
"member_removed" ->
          Text -> User -> WebhookEv
MemberRemovedEv (Text -> User -> WebhookEv)
-> Parser Text -> Parser (User -> WebhookEv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"channel" Parser (User -> WebhookEv) -> Parser User -> Parser WebhookEv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> User
User (Text -> User) -> Parser Text -> Parser User
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"user_id")
        Text
"client_event" ->
          Text -> Text -> Maybe Value -> Text -> Maybe User -> WebhookEv
ClientEv (Text -> Text -> Maybe Value -> Text -> Maybe User -> WebhookEv)
-> Parser Text
-> Parser (Text -> Maybe Value -> Text -> Maybe User -> WebhookEv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"channel" Parser (Text -> Maybe Value -> Text -> Maybe User -> WebhookEv)
-> Parser Text
-> Parser (Maybe Value -> Text -> Maybe User -> WebhookEv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"event"
            Parser (Maybe Value -> Text -> Maybe User -> WebhookEv)
-> Parser (Maybe Value) -> Parser (Text -> Maybe User -> WebhookEv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> Maybe Value)
-> (Text -> ByteString) -> Text -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Maybe Value) -> Parser Text -> Parser (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"data")
            Parser (Text -> Maybe User -> WebhookEv)
-> Parser Text -> Parser (Maybe User -> WebhookEv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"socket_id"
            Parser (Maybe User -> WebhookEv)
-> Parser (Maybe User) -> Parser WebhookEv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> User) -> Maybe Text -> Maybe User
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> User
User (Maybe Text -> Maybe User)
-> Parser (Maybe Text) -> Parser (Maybe User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"user_id")
        Text
_ -> String -> Parser WebhookEv
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser WebhookEv)
-> (Object -> String) -> Object -> Parser WebhookEv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Unknown client event. Got: " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Object -> String) -> Object -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> String
forall a. Show a => a -> String
show (Object -> Parser WebhookEv) -> Object -> Parser WebhookEv
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
(WebhookPayload -> WebhookPayload -> Bool)
-> (WebhookPayload -> WebhookPayload -> Bool) -> Eq WebhookPayload
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
(Int -> WebhookPayload -> ShowS)
-> (WebhookPayload -> String)
-> ([WebhookPayload] -> ShowS)
-> Show WebhookPayload
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
  | (ByteString -> ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> ByteString -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower) ByteString
key ByteString
"X-Pusher-Key" = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
value
  | Bool
otherwise = Maybe ByteString
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
  | (ByteString -> ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> ByteString -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Char -> Char) -> ByteString -> ByteString
BC.map Char -> Char
toLower) ByteString
key ByteString
"X-Pusher-Signature" = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
value
  | Bool
otherwise = Maybe ByteString
forall a. Maybe a
Nothing

-- | Given a HTTP body, parse the contained webhooks.
parseWebhooksBody :: BC.ByteString -> Maybe Webhooks
parseWebhooksBody :: ByteString -> Maybe Webhooks
parseWebhooksBody = ByteString -> Maybe Webhooks
forall a. FromJSON a => ByteString -> Maybe a
A.decode (ByteString -> Maybe Webhooks)
-> (ByteString -> ByteString) -> ByteString -> Maybe Webhooks
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 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ByteString -> ByteString -> HMAC SHA256
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 ByteString -> ByteString -> Bool
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 <- [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)]
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> Maybe ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ByteString -> ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> Maybe ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Maybe ByteString
parseAppKeyHdr) ([(ByteString, ByteString)] -> Maybe ByteString)
-> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)]
headers
  ByteString
authSignature <- [ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
listToMaybe ([ByteString] -> Maybe ByteString)
-> ([(ByteString, ByteString)] -> [ByteString])
-> [(ByteString, ByteString)]
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> Maybe ByteString)
-> [(ByteString, ByteString)] -> [ByteString]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ByteString -> ByteString -> Maybe ByteString)
-> (ByteString, ByteString) -> Maybe ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Maybe ByteString
parseAuthSignatureHdr) ([(ByteString, ByteString)] -> Maybe ByteString)
-> [(ByteString, ByteString)] -> Maybe ByteString
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 () -> Maybe ()
forall a. a -> Maybe a
Just ()
      else Maybe ()
forall a. Maybe a
Nothing
  Webhooks
whs <- ByteString -> Maybe Webhooks
parseWebhooksBody ByteString
body
  WebhookPayload -> Maybe WebhookPayload
forall a. a -> Maybe a
Just (WebhookPayload -> Maybe WebhookPayload)
-> WebhookPayload -> Maybe WebhookPayload
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> Webhooks -> WebhookPayload
WebhookPayload ByteString
appKey ByteString
authSignature Webhooks
whs