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
{ timeMs :: Word64,
webhookEvs :: [WebhookEv]
}
deriving (Eq, Show)
instance A.FromJSON Webhooks where
parseJSON =
A.withObject "Webhooks" $ \v ->
Webhooks <$> v .: "time_ms" <*> v .: "events"
data WebhookEv
=
ChannelOccupiedEv {onChannel :: T.Text}
|
ChannelVacatedEv {onChannel :: T.Text}
|
MemberAddedEv
{ onChannel :: T.Text,
withUser :: User
}
|
MemberRemovedEv
{ onChannel :: T.Text,
withUser :: User
}
|
ClientEv
{ onChannel :: T.Text,
clientEvName :: T.Text,
clientEvBody :: Maybe A.Value,
withSocketId :: T.Text,
withPossibleUser :: Maybe User
}
deriving (Eq, Show)
instance A.FromJSON WebhookEv where
parseJSON =
A.withObject "Webhooks" $ \v -> do
name <- v .: "name"
case name :: T.Text of
"channel_occupied" -> ChannelOccupiedEv <$> v .: "channel"
"channel_vacated" -> ChannelVacatedEv <$> v .: "channel"
"member_added" ->
MemberAddedEv <$> v .: "channel" <*> (User <$> v .: "user_id")
"member_removed" ->
MemberRemovedEv <$> v .: "channel" <*> (User <$> v .: "user_id")
"client_event" ->
ClientEv <$> v .: "channel" <*> v .: "event"
<*> (A.decode . LB.fromStrict . encodeUtf8 <$> v .: "data")
<*> v .: "socket_id"
<*> (fmap User <$> v .: "user_id")
_ -> fail . ("Unknown client event. Got: " ++) . show $ v
data WebhookPayload
= WebhookPayload
{
xPusherKey :: B.ByteString,
xPusherSignature :: B.ByteString,
webhooks :: Webhooks
}
deriving (Eq, Show)
parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString
parseAppKeyHdr key value
| on (==) (BC.map toLower) key "X-Pusher-Key" = Just value
| otherwise = Nothing
parseAuthSignatureHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString
parseAuthSignatureHdr key value
| on (==) (BC.map toLower) key "X-Pusher-Signature" = Just value
| otherwise = Nothing
parseWebhooksBody :: BC.ByteString -> Maybe Webhooks
parseWebhooksBody = A.decode . fromStrict
verifyWebhooksBody :: B.ByteString -> B.ByteString -> BC.ByteString -> Bool
verifyWebhooksBody appSecret authSignature body =
let actualSignature =
B16.encode $ convert (HMAC.hmac appSecret body :: HMAC.HMAC HASH.SHA256)
in authSignature == actualSignature
parseWebhookPayloadWith ::
(B.ByteString -> Maybe B.ByteString) ->
[(BC.ByteString, BC.ByteString)] ->
BC.ByteString ->
Maybe WebhookPayload
parseWebhookPayloadWith lookupKeysSecret headers body = do
appKey <- listToMaybe . mapMaybe (uncurry parseAppKeyHdr) $ headers
authSignature <- listToMaybe . mapMaybe (uncurry parseAuthSignatureHdr) $ headers
appSecret <- lookupKeysSecret appKey
() <-
if verifyWebhooksBody appSecret authSignature body
then Just ()
else Nothing
whs <- parseWebhooksBody body
Just $ WebhookPayload appKey authSignature whs