pusher-http-haskell 1.4.0.0 → 1.5.0.0
raw patch · 6 files changed
+394/−4 lines, 6 filesdep +HTTPdep +containersdep +network-uridep ~base16-bytestringdep ~cryptonitedep ~memory
Dependencies added: HTTP, containers, network-uri
Dependency ranges changed: base16-bytestring, cryptonite, memory, time
Files
- pusher-http-haskell.cabal +14/−3
- src/Network/Pusher.hs +28/−0
- src/Network/Pusher/Data.hs +7/−0
- src/Network/Pusher/Webhook.hs +171/−0
- test/Main.hs +5/−1
- test/Webhook.hs +169/−0
pusher-http-haskell.cabal view
@@ -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
src/Network/Pusher.hs view
@@ -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
src/Network/Pusher/Data.hs view
@@ -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
+ src/Network/Pusher/Webhook.hs view
@@ -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+
test/Main.hs view
@@ -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
+ test/Webhook.hs view
@@ -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