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 (..))
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"
data WebhookEv
=
ChannelOccupiedEv {WebhookEv -> Text
onChannel :: T.Text}
|
ChannelVacatedEv {onChannel :: T.Text}
|
MemberAddedEv
{ onChannel :: T.Text,
WebhookEv -> User
withUser :: User
}
|
MemberRemovedEv
{ onChannel :: T.Text,
withUser :: User
}
|
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
{
WebhookPayload -> ByteString
xPusherKey :: B.ByteString,
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)
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
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
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
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
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