diff --git a/pusher-http-haskell.cabal b/pusher-http-haskell.cabal --- a/pusher-http-haskell.cabal +++ b/pusher-http-haskell.cabal @@ -1,5 +1,5 @@ name: pusher-http-haskell -version: 1.4.0.0 +version: 1.5.0.0 cabal-version: >=1.18 build-type: Simple license: MIT @@ -36,15 +36,18 @@ base >=4.7 && <4.11, bytestring ==0.10.*, base16-bytestring ==0.1.*, - cryptonite >= 0.6 && <0.24, + cryptonite >= 0.6 && <0.25, hashable ==1.2.*, http-client >=0.4 && <0.6, http-types >=0.8 && <0.10, memory >= 0.7 && <0.15, text ==1.2.*, - time >=1.5 && <1.7, + time >=1.5 && <1.9, transformers >=0.4 && <0.6, unordered-containers ==0.2.*, + containers, + HTTP, + memory >=0.7, vector >=0.10.0.0 && <0.13 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -53,6 +56,7 @@ Network.Pusher.Data Network.Pusher.Error Network.Pusher.Internal.Util + Network.Pusher.Webhook ghc-options: -Wall test-suite tests @@ -67,14 +71,20 @@ aeson -any, base -any, bytestring -any, + base16-bytestring -any, + cryptonite -any, hspec -any, http-client -any, http-types -any, pusher-http-haskell -any, QuickCheck -any, + time -any, + HTTP -any, + network-uri -any, text -any, transformers -any, unordered-containers -any, + memory -any, vector -any, scientific default-language: Haskell2010 @@ -83,5 +93,6 @@ other-modules: Auth Protocol + Webhook Push ghc-options: -Wall diff --git a/src/Network/Pusher.hs b/src/Network/Pusher.hs --- a/src/Network/Pusher.hs +++ b/src/Network/Pusher.hs @@ -117,6 +117,16 @@ , authenticatePrivate -- * Errors , PusherError(..) + -- * Webhooks + , parseWebhookPayload + , WebhookEv(..) + , WebhookPayload(..) + , Webhooks(..) + , parseAppKeyHdr + , parseAuthSignatureHdr + , parseWebhooksBody + , verifyWebhooksBody + , parseWebhookPayloadWith ) where import Control.Monad.IO.Class (MonadIO, liftIO) @@ -140,6 +150,9 @@ import Network.Pusher.Protocol (ChannelInfoQuery, ChannelsInfo, ChannelsInfoQuery, FullChannelInfo, Users) +import Network.Pusher.Webhook + (Webhooks(..), WebhookEv(..), WebhookPayload(..),parseAppKeyHdr,parseAuthSignatureHdr,parseWebhooksBody,verifyWebhooksBody,parseWebhookPayloadWith) +import qualified Data.ByteString.Char8 as BC -- |Trigger an event to one or more channels. trigger @@ -216,3 +229,18 @@ (requestParams, requestBody) <- ExceptT $ Pusher.mkNotifyRequest pusher notification <$> getTime HTTP.post (pusherConnectionManager pusher) requestParams requestBody + +-- |Parse webhooks from a list of HTTP headers and a HTTP body given their AppKey +-- matches the one in our Pusher credentials and the webhook is correctly +-- encrypted by the corresponding AppSecret. +parseWebhookPayload + :: Pusher + -> [(BC.ByteString,BC.ByteString)] + -> BC.ByteString + -> Maybe WebhookPayload +parseWebhookPayload pusher = + let credentials = pusherCredentials pusher + ourAppKey = credentialsAppKey credentials + ourAppSecret = credentialsAppSecret credentials + lookupKeysSecret whAppKey = if whAppKey == ourAppKey then Just ourAppSecret else Nothing + in parseWebhookPayloadWith lookupKeysSecret diff --git a/src/Network/Pusher/Data.hs b/src/Network/Pusher/Data.hs --- a/src/Network/Pusher/Data.hs +++ b/src/Network/Pusher/Data.hs @@ -202,6 +202,13 @@ instance Hashable Channel +instance A.FromJSON Channel where + parseJSON s = case s of + A.String txt + -> return $ parseChannel txt + + _ -> failExpectStr s + renderChannel :: Channel -> T.Text renderChannel (Channel cType cName) = renderChannelPrefix cType <> cName diff --git a/src/Network/Pusher/Webhook.hs b/src/Network/Pusher/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pusher/Webhook.hs @@ -0,0 +1,171 @@ +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 +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.Maybe (mapMaybe) +import Data.Function (on) +import Data.Char (toLower) +import Data.Text (Text) +import Data.Text.Encoding +import Data.Time (UTCTime(..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Network.Pusher.Data + (Channel(..), SocketID, AppKey, AppSecret) +import Network.Pusher.Internal.Auth (AuthSignature) +import Network.Pusher.Internal.Util +import Network.Pusher.Protocol (User(..)) + +-- | A Webhook is received by POST request from Pusher to notify your server of +-- a number of 'WebhookEv'ents. Multiple events are received under the same +-- timestamp if batch events is enabled. +data Webhooks = Webhooks + { timeMs :: UTCTime + , webhookEvs :: [WebhookEv] + } deriving (Eq, Show) + +instance A.FromJSON Webhooks where + parseJSON o = + case o of + A.Object v -> + Webhooks <$> (_unOurTime <$> A.parseJSON o) <*> (v .: "events") + _ -> failExpectObj o + +-- Exists only so we can define our own FromJSON instance on NominalDiffTime. +-- This is useful because it didnt exist before a certain GHC version that we +-- support and allows us to avoid CPP and orphan instances. +newtype OurTime = OurTime + { _unOurTime :: UTCTime + } + +-- posixSecondsToUTCTime <$> +instance A.FromJSON OurTime where + parseJSON o = + case o of + A.Object v -> + A.withScientific + "NominalDiffTime" + (pure . OurTime . posixSecondsToUTCTime . realToFrac) =<< + v .: "time_ms" + _ -> failExpectObj o + +-- | A 'WebhookEv'ent 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 { onChannel :: Channel} + -- | A Channel has become vacated. There are 0 subscribers. + | ChannelVacatedEv { onChannel :: Channel} + -- | A new user has subscribed to a presence Channel. + | MemberAddedEv { onChannel :: Channel + , withUser :: User} + -- | A user has unsubscribed from a presence Channel. + | MemberRemovedEv { onChannel :: Channel + , withUser :: User} + -- | A client has sent a named client event with some json body. They have a + -- SocketID and a User if they were in a presence Channel. + | ClientEv { onChannel :: Channel + , clientEvName :: Text + , clientEvBody :: Maybe A.Value + , withSocketId :: SocketID + , withPossibleUser :: Maybe User} + deriving (Eq, Show) + +instance A.FromJSON WebhookEv where + parseJSON o = + case o of + A.Object v -> do + name <- v .: "name" + case name :: 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 $ o + _ -> failExpectObj o + +data WebhookPayload = WebhookPayload + -- | Authentication header. The oldest active token is used, identified by + -- this key. + { xPusherKey :: AppKey + -- | A HMAC SHA256 formed by signing the payload with the tokens secret. + , xPusherSignature :: AuthSignature + , webhooks :: Webhooks + } deriving (Eq, Show) + +-- | Given a HTTP Header and its associated value, parse a AppKey. +parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe AppKey +parseAppKeyHdr key value + | on (==) (BC.map toLower) key "X-Pusher-Key" = Just value + | otherwise = Nothing + +-- | Given a HTTP Header and its associated value, parse a AuthSignature. +parseAuthSignatureHdr :: BC.ByteString -> BC.ByteString -> Maybe AuthSignature +parseAuthSignatureHdr key value + | on (==) (BC.map toLower) key "X-Pusher-Signature" = Just value + | otherwise = Nothing + +-- | Given a HTTP body, parse the contained webhooks +parseWebhooksBody :: BC.ByteString -> Maybe Webhooks +parseWebhooksBody = A.decode . fromStrict + +-- Does a webhook body hash with our secret key to the given signature? +verifyWebhooksBody :: AppSecret -> AuthSignature -> BC.ByteString -> Bool +verifyWebhooksBody appSecret authSignature body = + let actualSignature = + B16.encode $ + convert (HMAC.hmac appSecret body :: HMAC.HMAC HASH.SHA256) + in authSignature == actualSignature + +safeHead :: [a] -> Maybe a +safeHead (x:_) = Just x +safeHead _ = Nothing + +-- 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 + :: (AppKey -> Maybe AppSecret) + -> [(BC.ByteString,BC.ByteString)] + -> BC.ByteString + -> Maybe WebhookPayload +parseWebhookPayloadWith lookupKeysSecret headers body = do + appKey <- safeHead + . mapMaybe (uncurry parseAppKeyHdr) + $ headers + + authSignature <- safeHead + . mapMaybe (uncurry parseAuthSignatureHdr) + $ headers + + appSecret <- lookupKeysSecret appKey + + () <- if verifyWebhooksBody appSecret authSignature body + then Just () + else Nothing + + whs <- parseWebhooksBody body + Just $ WebhookPayload appKey authSignature whs + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,6 +5,10 @@ import qualified Auth import qualified Protocol import qualified Push +import qualified Webhook main :: IO () -main = hspec $ Auth.test >> Protocol.test >> Push.test +main = hspec $ Auth.test + >> Protocol.test + >> Push.test + >> Webhook.test diff --git a/test/Webhook.hs b/test/Webhook.hs new file mode 100644 --- /dev/null +++ b/test/Webhook.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Webhook where + +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as B +import qualified Data.HashMap.Strict as HM +import Data.Time.Clock.POSIX +import Network.Pusher + (parseChannel, AppKey, AppSecret, WebhookPayload(..), Webhooks(..), + WebhookEv(..), AuthSignature,parseWebhookPayloadWith) +import Network.Pusher.Protocol (User(..)) +import Test.Hspec (Spec, describe, it) +import Test.QuickCheck (property) + +data TestWebhookPayload = TestWebhookPayload + { _webhookRequest :: ([(B.ByteString,B.ByteString)],B.ByteString) -- ^ A Request recieved from Pusher + , _hasKey :: AppKey -- ^ Must have this key + , _hasSecret :: AppSecret -- ^ Which must correspond to this secret + , _payload :: Maybe WebhookPayload -- ^ And which must parse to this Payload + } + +-- | Attempt to parse the contained req. +-- - It must use our appKey which must correspond to our secret. +-- - The body must be correctly signed by our secret. +-- - The parsed payload must then further be identical to the one we expect. +testWebhookPayloadParses :: TestWebhookPayload -> Bool +testWebhookPayloadParses (TestWebhookPayload (headers,body) hasKey correspondingSecret expectedPayload) = + let parseResult = parseWebhookPayloadWith + (\k -> if k == hasKey + then Just correspondingSecret + else Nothing + ) + headers + body + + in parseResult == expectedPayload + +-- Build a _simple_ TestWebhookPayload which contains: +-- - A HTTP POST request with key and signature headers and a bytestring body +-- - A mapping from the same key to the secret used to sign the body to produce the signature. +-- - A list of webhook events we expect to have in the body. +-- +-- The caller can deliberately pass incorrect timestamps, bodys, secrets, +-- signatures and event combinations to test whether parsing fails as expected. +-- +-- Parsing of values generated by this function should only succeed when: +-- - The timestamp is the same as the one in the message body +-- - The message body contains exactly the same list of events +-- - The body is encrypted by the given key to produce the given signature +-- +-- The word _simple_ excludes cases where: +-- - The HTTP request doesnt have the required headers +-- - The HTTP headers are different to the expected payload +-- - The HTTP requests key is unknown or doesnt match our secret +mkSimpleTestWebhookPayload + :: AppKey + -> AppSecret + -> POSIXTime + -> B.ByteString + -> AuthSignature + -> [WebhookEv] + -> TestWebhookPayload +mkSimpleTestWebhookPayload key secret unixTime body signature whs = + TestWebhookPayload + { _webhookRequest = ([("X-Pusher-Key",key),("X-Pusher-Signature",signature)],body) + , _hasKey = key + , _hasSecret = secret + , _payload = + Just + WebhookPayload + { xPusherKey = key + , xPusherSignature = signature + , webhooks = + Webhooks {timeMs = posixSecondsToUTCTime unixTime, webhookEvs = whs} + } + } + +channelOccupiedPayload :: TestWebhookPayload +channelOccupiedPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1502790365001 + "{\"time_ms\":1502790365001,\"events\":[{\"channel\":\"foo\",\"name\":\"channel_occupied\"}]}" + "4b3d29966e4930d875ec01012e37c18070f4b779b09f71af99d1f0baaffabc98" + [ChannelOccupiedEv {onChannel = parseChannel "foo"}] + +channelVacatedPayload :: TestWebhookPayload +channelVacatedPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1502790363928 + "{\"time_ms\":1502790363928,\"events\":[{\"channel\":\"foo\",\"name\":\"channel_vacated\"}]}" + "c9c70dcf19e011912ecdabe8997b451a95667157d00e37c7476491e7f233c416" + [ChannelVacatedEv {onChannel = parseChannel "foo"}] + +memberAddedPayload :: TestWebhookPayload +memberAddedPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1503394956847 + "{\"time_ms\":1503394956847,\"events\":[{\"channel\":\"presence-foo\",\"user_id\":\"42\",\"name\":\"member_added\"}]}" + "392bd546e8a33a826d7870bd6432f6c7dcf11ca31565575d8c72f9b02f5b0736" + [ MemberAddedEv + {onChannel = parseChannel "presence-foo", withUser = User "42"} + ] + +memberRemovedPayload :: TestWebhookPayload +memberRemovedPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1503394971554 + "{\"time_ms\":1503394971554,\"events\":[{\"channel\":\"presence-foo\",\"user_id\":\"42\",\"name\":\"member_removed\"}]}" + "9a344e8aeb2c6339999e84bacb4d50b3674599e297d01655eb2cec3f9c655763" + [ MemberRemovedEv + {onChannel = parseChannel "presence-foo", withUser = User "42"} + ] + +clientEventPayload :: TestWebhookPayload +clientEventPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1503397271011 + "{\"time_ms\":1503397271011,\"events\":[{\"name\":\"client_event\",\"channel\":\"presence-foo\",\"event\":\"client-event\",\"data\":\"{\\\"name\\\":\\\"John\\\",\\\"message\\\":\\\"Hello\\\"}\",\"socket_id\":\"219049.596715\",\"user_id\":\"sturdy-window-821\"}]}" + "e5ef8964e8c87c91dde0555e46fa921163aff262395c9e36c1755ffe206be547" + [ ClientEv + { onChannel = parseChannel "presence-foo" + , clientEvName = "client-event" + , clientEvBody = + Just $ + A.Object $ + HM.fromList [("name", A.String "John"), ("message", A.String "Hello")] + , withSocketId = "219049.596715" + , withPossibleUser = Just . User $ "sturdy-window-821" + } + ] + +batchEventPayload :: TestWebhookPayload +batchEventPayload = + mkSimpleTestWebhookPayload + "ebc2cca5d18f3cf01d99" + "6f87cba29d7b8f6f4a36" + 1503397088953 + "{\"time_ms\":1503397088953,\"events\":[{\"channel\":\"private-foo\",\"name\":\"channel_occupied\"},{\"channel\":\"presence-foo\",\"name\":\"channel_occupied\"}]}" + "7a9803e1ca598dac4750a60fbb017d4f34fc44eaf0aea26c694ca0d7060e6477" + [ ChannelOccupiedEv {onChannel = parseChannel "private-foo"} + , ChannelOccupiedEv {onChannel = parseChannel "presence-foo"} + ] + +test :: Spec +test = + describe "Webhook.parseWebhookPayloadWith" $ do + it "parses and validates a channel_occupied event" $ + property $ testWebhookPayloadParses channelOccupiedPayload + it "parses and validates a Channel_vacated event" $ + property $ testWebhookPayloadParses channelVacatedPayload + it "parses and validates a member_added event" $ + property $ testWebhookPayloadParses memberAddedPayload + it "parses and validates a member_removed event" $ + property $ testWebhookPayloadParses memberRemovedPayload + it "parses and validates a client event" $ + property $ testWebhookPayloadParses clientEventPayload + it "parses and validates multiple batched events" $ + property $ testWebhookPayloadParses batchEventPayload