pusher-http-haskell 1.5.0.1 → 1.5.1.0
raw patch · 13 files changed
+243/−266 lines, 13 filesdep −HTTPdep −containersdep −network-uridep ~http-typesdep ~memory
Dependencies removed: HTTP, containers, network-uri
Dependency ranges changed: http-types, memory
Files
- pusher-http-haskell.cabal +3/−9
- src/Network/Pusher.hs +54/−54
- src/Network/Pusher/Data.hs +36/−44
- src/Network/Pusher/Error.hs +3/−3
- src/Network/Pusher/Internal.hs +38/−38
- src/Network/Pusher/Internal/Auth.hs +4/−4
- src/Network/Pusher/Internal/HTTP.hs +15/−13
- src/Network/Pusher/Internal/Util.hs +2/−4
- src/Network/Pusher/Protocol.hs +5/−6
- src/Network/Pusher/Webhook.hs +50/−61
- test/Main.hs +1/−4
- test/Push.hs +6/−6
- test/Webhook.hs +26/−20
pusher-http-haskell.cabal view
@@ -1,5 +1,5 @@ name: pusher-http-haskell-version: 1.5.0.1+version: 1.5.1.0 cabal-version: >=1.18 build-type: Simple license: MIT@@ -39,15 +39,12 @@ cryptonite >= 0.6 && <0.25, hashable ==1.2.*, http-client >=0.4 && <0.6,- http-types >=0.8 && <0.11,+ http-types >=0.8 && <0.12, memory >= 0.7 && <0.15, text ==1.2.*, 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@@ -79,14 +76,11 @@ 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+ scientific -any default-language: Haskell2010 default-extensions: OverloadedStrings hs-source-dirs: test
src/Network/Pusher.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}- {-| Module : Network.Pusher Description : Haskell interface to the Pusher HTTP API@@ -23,16 +22,16 @@ @ let- credentials = Credentials- { credentialsAppID = 123- , credentialsAppKey = wrd12344rcd234- , credentialsAppSecret = 124df34d545v- , credentialsCluster = Nothing+ credentials = 'Credentials'+ { 'credentialsAppID' = 123+ , 'credentialsAppKey' = "wrd12344rcd234"+ , 'credentialsAppSecret' = "124df34d545v"+ , 'credentialsCluster' = Nothing }- pusher <- getPusher credentials+ pusher <- 'getPusher' credentials triggerRes <-- trigger pusher [Channel Public "my-channel"] "my-event" "my-data" Nothing+ 'trigger' pusher ['Channel' 'Public' "my-channel"] "my-event" "my-data" Nothing case triggerRes of Left e -> putStrLn $ displayException e@@ -43,24 +42,24 @@ let -- A Firebase Cloud Messaging notification payload fcmObject = H.fromList [("notification", A.Object $ H.fromList- [("title", A.String "TITLE")- ,("body" , A.String "BODY")+ [("title", A.String "a title")+ ,("body" , A.String "some text") ,("icon" , A.String "logo.png") ] )]- Just interest = mkInterest "INTEREST"+ Just interest = 'mkInterest' "some-interest" -- A Pusher notification- notification = Notification- { notificationInterest = interest- , notificationWebhookURL = Nothing- , notificationWebhookLevel = Nothing- , notificationAPNSPayload = Nothing- , notificationGCMPayload = Nothing- , notificationFCMPayload = Just $ FCMPayload fcmObject+ notification = 'Notification'+ { 'notificationInterest' = interest+ , 'notificationWebhookURL' = Nothing+ , 'notificationWebhookLevel' = Nothing+ , 'notificationAPNSPayload' = Nothing+ , 'notificationGCMPayload' = Nothing+ , 'notificationFCMPayload' = Just $ 'FCMPayload' fcmObject } - notifyRes <- notify pusher notification+ notifyRes <- 'notify' pusher notification @ @@ -69,10 +68,10 @@ See https://pusher.com/docs/rest_api for more detail on the HTTP requests. -}-module Network.Pusher+module Network.Pusher ( -- * Data types -- ** Pusher config type- ( Pusher(..)+ Pusher(..) , Credentials(..) , Cluster(..) , AppID@@ -133,9 +132,10 @@ import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BC import Network.Pusher.Data- (AppID, APNSPayload(..), AppKey, AppSecret, Channel(..),- ChannelName, ChannelType(..), Credentials(..), Cluster(..), Event,+ (APNSPayload(..), AppID, AppKey, AppSecret, Channel(..),+ ChannelName, ChannelType(..), Cluster(..), Credentials(..), Event, EventData, FCMPayload(..), GCMPayload(..), Interest, Notification(..), Pusher(..), SocketID, WebhookLevel(..), WebhookURL, getPusher, getPusherWithConnManager, getPusherWithHost,@@ -151,20 +151,21 @@ (ChannelInfoQuery, ChannelsInfo, ChannelsInfoQuery, FullChannelInfo, Users) import Network.Pusher.Webhook- (Webhooks(..), WebhookEv(..), WebhookPayload(..),parseAppKeyHdr,parseAuthSignatureHdr,parseWebhooksBody,verifyWebhooksBody,parseWebhookPayloadWith)-import qualified Data.ByteString.Char8 as BC+ (WebhookEv(..), WebhookPayload(..), Webhooks(..), parseAppKeyHdr,+ parseAuthSignatureHdr, parseWebhookPayloadWith, parseWebhooksBody,+ verifyWebhooksBody) -- |Trigger an event to one or more channels.-trigger- :: MonadIO m+trigger ::+ MonadIO m => Pusher -> [Channel]- -- ^The list of channels to trigger to+ -- ^The list of channels to trigger to. -> Event -> EventData- -- ^Often encoded JSON+ -- ^Often encoded JSON. -> Maybe SocketID- -- ^An optional socket ID of a connection you wish to exclude+ -- ^An optional socket ID of a connection you wish to exclude. -> m (Either PusherError ()) trigger pusher chans event dat socketId = liftIO $@@ -175,16 +176,16 @@ HTTP.post (pusherConnectionManager pusher) requestParams requestBody -- |Query a list of channels for information.-channels- :: MonadIO m+channels ::+ MonadIO m => Pusher -> Maybe ChannelType- -- ^Filter by the type of channel+ -- ^Filter by the type of channel. -> T.Text- -- ^A channel prefix you wish to filter on+ -- ^A channel prefix you wish to filter on. -> ChannelsInfoQuery- -- ^Data you wish to query for, currently just the user count- -> m (Either PusherError ChannelsInfo) -- ^The returned data+ -- ^Data you wish to query for, currently just the user count.+ -> m (Either PusherError ChannelsInfo) -- ^The returned data. channels pusher channelTypeFilter prefixFilter attributes = liftIO $ runExceptT $ do@@ -195,12 +196,12 @@ HTTP.get (pusherConnectionManager pusher) requestParams -- |Query for information on a single channel.-channel- :: MonadIO m+channel ::+ MonadIO m => Pusher -> Channel -> ChannelInfoQuery- -- ^Can query user count and also subscription count (if enabled)+ -- ^Can query user count and also subscription count (if enabled). -> m (Either PusherError FullChannelInfo) channel pusher chan attributes = liftIO $@@ -210,19 +211,15 @@ HTTP.get (pusherConnectionManager pusher) requestParams -- |Get a list of users in a presence channel.-users- :: MonadIO m- => Pusher -> Channel -> m (Either PusherError Users)+users :: MonadIO m => Pusher -> Channel -> m (Either PusherError Users) users pusher chan = liftIO $ runExceptT $ do requestParams <- liftIO $ Pusher.mkUsersRequest pusher chan <$> getTime HTTP.get (pusherConnectionManager pusher) requestParams --- |Send a push notification-notify- :: MonadIO m- => Pusher -> Notification -> m (Either PusherError ())+-- |Send a push notification.+notify :: MonadIO m => Pusher -> Notification -> m (Either PusherError ()) notify pusher notification = liftIO $ runExceptT $ do@@ -230,17 +227,20 @@ 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)]+-- |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+ lookupKeysSecret whAppKey =+ if whAppKey == ourAppKey+ then Just ourAppSecret+ else Nothing+ in parseWebhookPayloadWith lookupKeysSecret
src/Network/Pusher/Data.hs view
@@ -13,9 +13,9 @@ The other types represent Pusher channels and Pusher event fields. -}-module Network.Pusher.Data+module Network.Pusher.Data ( -- * Pusher config data type- ( AppID+ AppID , AppKey , AppSecret , Pusher(..)@@ -54,7 +54,7 @@ import Data.Aeson ((.:), (.:?), (.=)) import qualified Data.Aeson as A import qualified Data.ByteString as B-import Data.Char+import Data.Char (isAlphaNum) import Data.Foldable (asum) import qualified Data.HashSet as HS import Data.Hashable (Hashable)@@ -68,7 +68,7 @@ (Manager, defaultManagerSettings, newManager) import Network.Pusher.Internal.Util- (failExpectObj, failExpectSingletonArray, failExpectArray,+ (failExpectArray, failExpectObj, failExpectSingletonArray, failExpectStr, show') type AppID = Integer@@ -102,7 +102,8 @@ v .:? "app-cluster" parseJSON v2 = failExpectObj v2 --- | The cluster the current app resides on. Common clusters include: mt1,eu,ap1,ap2+-- |The cluster the current app resides on. Common clusters include:+-- mt1,eu,ap1,ap2. newtype Cluster = Cluster { clusterName :: T.Text }@@ -128,17 +129,13 @@ -- |Use this to get an instance Pusher. This will fill in the host and path -- automatically.-getPusher- :: MonadIO m- => Credentials -> m Pusher+getPusher :: MonadIO m => Credentials -> m Pusher getPusher cred = do connManager <- getConnManager return $ getPusherWithConnManager connManager Nothing Nothing cred -- |Get a Pusher instance that uses a specific API endpoint.-getPusherWithHost- :: MonadIO m- => T.Text -> T.Text -> Credentials -> m Pusher+getPusherWithHost :: MonadIO m => T.Text -> T.Text -> Credentials -> m Pusher getPusherWithHost apiHost notifyHost cred = do connManager <- getConnManager return $@@ -146,11 +143,8 @@ -- |Get a Pusher instance with a given connection manager. This can be useful -- if you want to share a connection with your application code.-getPusherWithConnManager :: Manager- -> Maybe T.Text- -> Maybe T.Text- -> Credentials- -> Pusher+getPusherWithConnManager ::+ Manager -> Maybe T.Text -> Maybe T.Text -> Credentials -> Pusher getPusherWithConnManager connManager apiHost notifyAPIHost cred = let path = "/apps/" <> show' (credentialsAppID cred) <> "/" mCluster = credentialsCluster cred@@ -166,16 +160,14 @@ , pusherConnectionManager = connManager } --- |Given a possible cluster, return the corresponding host+-- |Given a possible cluster, return the corresponding host. mkHost :: Maybe Cluster -> T.Text mkHost mCluster = case mCluster of Nothing -> "http://api.pusherapp.com" Just c -> "http://api" <> renderClusterSuffix c <> ".pusher.com" -getConnManager- :: MonadIO m- => m Manager+getConnManager :: MonadIO m => m Manager getConnManager = liftIO $ newManager defaultManagerSettings type ChannelName = T.Text@@ -203,16 +195,15 @@ instance Hashable Channel instance A.FromJSON Channel where- parseJSON s = case s of- A.String txt- -> return $ parseChannel txt-- _ -> failExpectStr s+ parseJSON s =+ case s of+ A.String txt -> return $ parseChannel txt+ _ -> failExpectStr s renderChannel :: Channel -> T.Text renderChannel (Channel cType cName) = renderChannelPrefix cType <> cName --- |Convert string representation, e.g. private-chan into the datatype+-- |Convert string representation, e.g. private-chan into the datatype. parseChannel :: T.Text -> Channel parseChannel chan -- Attempt to parse it as a private or presence channel; default to public@@ -234,17 +225,19 @@ type SocketID = T.Text --- | Up to 164 characters where each character is ASCII upper or lower case, a+-- |Up to 164 characters where each character is ASCII upper or lower case, a -- number or one of _=@,.;+-- -- Note: hyphen - is NOT valid as it is reserved for the possibility of marking--- interest names with prefixes such as private- or presence-+-- interest names with prefixes such as private- or presence-. newtype Interest = Interest T.Text- deriving (Eq,Show)+ deriving (Eq, Show) mkInterest :: T.Text -> Maybe Interest mkInterest txt- | 0 < T.length txt && T.length txt <= 164 &&+ | 0 < T.length txt &&+ T.length txt <= 164 && T.all (\c -> isAlphaNum c || HS.member c permitted) txt = Just . Interest $ txt | otherwise = Nothing@@ -265,14 +258,14 @@ instance A.ToJSON Interest where toJSON (Interest txt) = A.String txt --- | URL to which pusher will send information about sent push notifications+-- |URL to which pusher will send information about sent push notifications. type WebhookURL = T.Text --- | Level of detail sent to WebhookURL. Defaults to Info+-- |Level of detail sent to WebhookURL. Defaults to Info. data WebhookLevel = Info -- ^ Errors only | Debug -- ^ Everything- deriving (Eq,Show)+ deriving (Eq, Show) instance A.FromJSON WebhookLevel where parseJSON v =@@ -289,11 +282,11 @@ Info -> "INFO" Debug -> "DEBUG" --- | Apple push notification service payload--- TODO: Replace JSON object with a stronger encoding.+-- |Apple push notification service payload. data APNSPayload =+ -- TODO: Replace JSON object with a stronger encoding APNSPayload A.Object- deriving (Eq,Show)+ deriving (Eq, Show) instance A.FromJSON APNSPayload where parseJSON v =@@ -304,11 +297,11 @@ instance A.ToJSON APNSPayload where toJSON (APNSPayload o) = A.Object o --- | Google Cloud Messaging payload--- TODO: Replace JSON object with a stronger encoding.+-- |Google Cloud Messaging payload. data GCMPayload =+ -- TODO: Replace JSON object with a stronger encoding GCMPayload A.Object- deriving (Eq,Show)+ deriving (Eq, Show) instance A.FromJSON GCMPayload where parseJSON v =@@ -319,11 +312,11 @@ instance A.ToJSON GCMPayload where toJSON (GCMPayload o) = A.Object o --- | Firebase Cloud Messaging payload--- TODO: Replace JSON object with a stronger encoding.+-- |Firebase Cloud Messaging payload. data FCMPayload =+ -- TODO: Replace JSON object with a stronger encoding FCMPayload A.Object- deriving (Eq,Show)+ deriving (Eq, Show) instance A.FromJSON FCMPayload where parseJSON v =@@ -341,8 +334,7 @@ , notificationAPNSPayload :: Maybe APNSPayload , notificationGCMPayload :: Maybe GCMPayload , notificationFCMPayload :: Maybe FCMPayload- }- deriving (Eq,Show)+ } deriving (Eq, Show) instance A.FromJSON Notification where parseJSON (A.Object v) =
src/Network/Pusher/Error.hs view
@@ -6,12 +6,12 @@ import qualified Data.Text as T data PusherError- -- |Data from the caller is not valid. = PusherArgumentError T.Text- -- |Received non 200 response code from Pusher.+ -- ^Data from the caller is not valid. | PusherNon200ResponseError T.Text- -- |Received unexpected data from Pusher.+ -- ^Received non 200 response code from Pusher. | PusherInvalidResponseError T.Text+ -- ^Received unexpected data from Pusher. deriving (Show) instance Exception PusherError
src/Network/Pusher/Internal.hs view
@@ -25,7 +25,7 @@ import Network.Pusher.Data (Channel, ChannelType, Credentials(..), Event, EventData,- Pusher(..), SocketID, Notification(..), renderChannel,+ Notification(..), Pusher(..), SocketID, renderChannel, renderChannelPrefix) import Network.Pusher.Error (PusherError(..)) import Network.Pusher.Internal.Auth (makeQS)@@ -34,8 +34,8 @@ import Network.Pusher.Protocol (ChannelInfoQuery, ChannelsInfoQuery, toURLParam) -mkTriggerRequest- :: Pusher+mkTriggerRequest ::+ Pusher -> [Channel] -> Event -> EventData@@ -56,11 +56,11 @@ bodyBS = BL.toStrict $ A.encode body when (B.length bodyBS > 10000)- (Left $ PusherArgumentError "Body must be less than 10000KB")+ (Left $ PusherArgumentError "Body must be less than 10000 bytes long") return (mkPostRequest pusher "events" [] bodyBS time, body) -mkChannelsRequest- :: Pusher+mkChannelsRequest ::+ Pusher -> Maybe ChannelType -> T.Text -> ChannelsInfoQuery@@ -74,11 +74,8 @@ ] in mkGetRequest pusher "channels" params time -mkChannelRequest :: Pusher- -> Channel- -> ChannelInfoQuery- -> Int- -> RequestParams+mkChannelRequest ::+ Pusher -> Channel -> ChannelInfoQuery -> Int -> RequestParams mkChannelRequest pusher chan attributes time = let params = [("info", encodeUtf8 $ toURLParam attributes)] subPath = "channels/" <> renderChannel chan@@ -89,10 +86,11 @@ let subPath = "channels/" <> renderChannel chan <> "/users" in mkGetRequest pusher subPath [] time -mkNotifyRequest :: Pusher- -> Notification- -> Int- -> Either PusherError (RequestParams, RequestBody)+mkNotifyRequest ::+ Pusher+ -> Notification+ -> Int+ -> Either PusherError (RequestParams, RequestBody) mkNotifyRequest pusher notification time = do let body = A.toJSON notification bodyBS = BL.toStrict $ A.encode body@@ -106,51 +104,53 @@ qs = mkQS pusher "GET" fullPath params "" time in RequestParams ep qs -mkPostRequest :: Pusher- -> T.Text- -> RequestQueryString- -> B.ByteString- -> Int- -> RequestParams+mkPostRequest ::+ Pusher+ -> T.Text+ -> RequestQueryString+ -> B.ByteString+ -> Int+ -> RequestParams mkPostRequest pusher subPath params bodyBS time = let (ep, fullPath) = mkEndpoint pusher subPath qs = mkQS pusher "POST" fullPath params bodyBS time in RequestParams ep qs -mkNotifyPostRequest :: Pusher- -> T.Text- -> RequestQueryString- -> B.ByteString- -> Int- -> RequestParams+mkNotifyPostRequest ::+ Pusher+ -> T.Text+ -> RequestQueryString+ -> B.ByteString+ -> Int+ -> RequestParams mkNotifyPostRequest pusher subPath params bodyBS time = let (ep, fullPath) = mkNotifyEndpoint pusher subPath qs = mkQS pusher "POST" fullPath params bodyBS time in RequestParams ep qs -- |Build a full endpoint from the details in Pusher and the subPath.-mkEndpoint- :: Pusher- -> T.Text -- ^The subpath of the specific request, e.g "events/channel-name"- -> (T.Text, T.Text) -- ^The full endpoint, and just the path component+mkEndpoint ::+ Pusher+ -> T.Text -- ^The subpath of the specific request, e.g "events/channel-name".+ -> (T.Text, T.Text) -- ^The full endpoint, and just the path component. mkEndpoint pusher subPath = let fullPath = pusherPath pusher <> subPath endpoint = pusherHost pusher <> fullPath in (endpoint, fullPath) -- |Build a full endpoint for push notifications from the details in Pusher and--- the subPath-mkNotifyEndpoint- :: Pusher- -> T.Text -- ^ The subpath of the specific request- -> (T.Text, T.Text) -- ^ The full endpoint and just the path component+-- the subPath.+mkNotifyEndpoint ::+ Pusher+ -> T.Text -- ^ The subpath of the specific request.+ -> (T.Text, T.Text) -- ^ The full endpoint and just the path component. mkNotifyEndpoint pusher subPath = let fullPath = pusherNotifyPath pusher <> subPath endpoint = pusherNotifyHost pusher <> fullPath in (endpoint, fullPath) -mkQS- :: Pusher+mkQS ::+ Pusher -> T.Text -> T.Text -> RequestQueryString
src/Network/Pusher/Internal/Auth.hs view
@@ -55,9 +55,9 @@ -> AppSecret -> T.Text -> T.Text- -> RequestQueryString -- ^Any additional parameters+ -> RequestQueryString -- ^Any additional parameters. -> B.ByteString- -> Int -- ^Current UNIX timestamp+ -> Int -- ^Current UNIX timestamp. -> RequestQueryString makeQS appKey appSecret method fullPath params body ts -- Generate all required parameters and add them to the list of existing ones@@ -93,10 +93,10 @@ formQueryString :: RequestQueryString -> B.ByteString formQueryString = B.intercalate "&" . map (\(a, b) -> a <> "=" <> b) --- | The bytestring to sign with the app secret to create a signature from.+-- |The bytestring to sign with the app secret to create a signature from. type AuthString = B.ByteString --- | A Pusher auth signature.+-- |A Pusher auth signature. type AuthSignature = B.ByteString -- |Create a Pusher auth signature of a string using the provided credentials.
src/Network/Pusher/Internal/HTTP.hs view
@@ -41,9 +41,9 @@ data RequestParams = RequestParams { requestEndpoint :: T.Text- -- ^The API endpoint, for example http://api.pusherapp.com/apps/123/events+ -- ^The API endpoint, for example http://api.pusherapp.com/apps/123/events. , requestQueryString :: RequestQueryString- -- ^List of query string parameters as key-value tuples+ -- ^List of query string parameters as key-value tuples. } deriving (Show) type RequestQueryString = [(B.ByteString, B.ByteString)]@@ -52,11 +52,11 @@ -- |Issue an HTTP GET request. On a 200 response, the response body is returned. -- On failure, an error will be thrown into the MonadError instance.-get- :: A.FromJSON a+get ::+ A.FromJSON a => HTTP.Client.Manager -> RequestParams- -> ExceptT PusherError IO a -- ^The body of the response+ -> ExceptT PusherError IO a -- ^The body of the response. get connManager (RequestParams ep qs) = do req <- ExceptT $ return $ mkRequest ep qs resp <- doRequest connManager req@@ -66,17 +66,19 @@ (A.eitherDecode resp) -- |Issue an HTTP POST request.-post- :: A.ToJSON a- => HTTP.Client.Manager -> RequestParams -> a -> ExceptT PusherError IO ()+post ::+ A.ToJSON a+ => HTTP.Client.Manager+ -> RequestParams+ -> a+ -> ExceptT PusherError IO () post connManager (RequestParams ep qs) body = do req <- ExceptT $ return $ mkPost (A.encode body) <$> mkRequest ep qs _ <- doRequest connManager req return () -mkRequest :: T.Text- -> RequestQueryString- -> Either PusherError HTTP.Client.Request+mkRequest ::+ T.Text -> RequestQueryString -> Either PusherError HTTP.Client.Request mkRequest ep qs = case parseRequest $ T.unpack ep of Nothing -> Left $ PusherArgumentError $ "failed to parse url: " <> ep@@ -96,8 +98,8 @@ , HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS body } -doRequest- :: HTTP.Client.Manager+doRequest ::+ HTTP.Client.Manager -> HTTP.Client.Request -> ExceptT PusherError IO BL.ByteString doRequest connManager req = do
src/Network/Pusher/Internal/Util.hs view
@@ -46,8 +46,6 @@ failExpectStr :: A.Value -> A.Parser a failExpectStr = fail . ("Expected JSON string, got " ++) . show --- | Generalised version of show-show'- :: (Show a, IsString b)- => a -> b+-- |Generalised version of show.+show' :: (Show a, IsString b) => a -> b show' = fromString . show
src/Network/Pusher/Protocol.hs view
@@ -53,7 +53,7 @@ instance Hashable ChannelsInfoAttributes --- |A set of requested ChannelsInfoAttributes.+-- |A set of requested 'ChannelsInfoAttributes'. newtype ChannelsInfoQuery = ChannelsInfoQuery (HS.HashSet ChannelsInfoAttributes) deriving (ToURLParam)@@ -70,16 +70,15 @@ instance Hashable ChannelInfoAttributes --- |A set of requested ChannelInfoAttributes.+-- |A set of requested 'ChannelInfoAttributes'. newtype ChannelInfoQuery = ChannelInfoQuery (HS.HashSet ChannelInfoAttributes) deriving (ToURLParam) -instance ToURLParam a =>- ToURLParam (HS.HashSet a) where+instance ToURLParam a => ToURLParam (HS.HashSet a) where toURLParam hs = T.intercalate "," $ toURLParam <$> HS.toList hs --- |A map of channels to their ChannelInfo. The result of querying channel+-- |A map of channels to their 'ChannelInfo'. The result of querying channel -- info from multuple channels. newtype ChannelsInfo = ChannelsInfo (HM.HashMap Channel ChannelInfo)@@ -109,7 +108,7 @@ parseJSON (A.Object v) = ChannelInfo <$> v .:? "user_count" parseJSON v = failExpectObj v --- |The possible values returned by a query to a single channel+-- |The possible values returned by a query to a single channel. data FullChannelInfo = FullChannelInfo { fullChannelInfoOccupied :: Bool , fullChannelInfoUserCount :: Maybe Int
src/Network/Pusher/Webhook.hs view
@@ -2,7 +2,6 @@ ( Webhooks(..) , WebhookEv(..) , WebhookPayload(..)- , parseAppKeyHdr , parseAuthSignatureHdr , parseWebhooksBody@@ -19,21 +18,21 @@ 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.Function (on)+import Data.Maybe (mapMaybe) 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)+ (AppKey, AppSecret, Channel(..), SocketID) 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+-- |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 { timeMs :: UTCTime@@ -47,14 +46,13 @@ 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.+-- |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@@ -65,26 +63,26 @@ 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.+-- |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 { onChannel :: Channel}- -- | A Channel has become vacated. There are 0 subscribers.- | ChannelVacatedEv { onChannel :: Channel}- -- | A new user has subscribed to a presence Channel.+ -- |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.+ , 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.+ , 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}+ , clientEvName :: Text+ , clientEvBody :: Maybe A.Value+ , withSocketId :: SocketID+ , withPossibleUser :: Maybe User } deriving (Eq, Show) instance A.FromJSON WebhookEv where@@ -107,65 +105,56 @@ _ -> 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.+data WebhookPayload = WebhookPayload {+ xPusherKey :: AppKey+ -- ^Authentication header. The oldest active token is used, identified by+ -- this key. , xPusherSignature :: AuthSignature+ -- ^A HMAC SHA256 formed by signing the payload with the tokens secret. , webhooks :: Webhooks } deriving (Eq, Show) --- | Given a HTTP Header and its associated value, parse a AppKey.+-- |Given a HTTP Header and its associated value, parse an 'AppKey'. parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe AppKey parseAppKeyHdr key value | on (==) (BC.map toLower) key "X-Pusher-Key" = Just value- | otherwise = Nothing+ | otherwise = Nothing --- | Given a HTTP Header and its associated value, parse a AuthSignature.+-- |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+ | otherwise = Nothing --- | Given a HTTP body, parse the contained webhooks+-- |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?+-- |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)+ B16.encode $ convert (HMAC.hmac appSecret body :: HMAC.HMAC HASH.SHA256) in authSignature == actualSignature safeHead :: [a] -> Maybe a safeHead (x:_) = Just x-safeHead _ = Nothing+safeHead _ = Nothing --- Given a list of http header key:values, a http body and a lookup function+-- |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)]+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-+ 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
@@ -8,7 +8,4 @@ import qualified Webhook main :: IO ()-main = hspec $ Auth.test- >> Protocol.test- >> Push.test- >> Webhook.test+main = hspec $ Auth.test >> Protocol.test >> Push.test >> Webhook.test
test/Push.hs view
@@ -13,7 +13,7 @@ import Test.Hspec (Spec, describe, it) import Test.QuickCheck- (elements, property, Gen, vectorOf, oneof, Arbitrary(..))+ (Arbitrary(..), Gen, elements, oneof, property, vectorOf) import Network.Pusher @@ -92,7 +92,7 @@ } in (bs, notification) --- | A ByteString will decode to some value 'a'.+-- A ByteString will decode to some value 'a'. type Decoding a = (B.ByteString, a) newtype NotificationDecoding =@@ -217,8 +217,8 @@ [("interests", "[\"" <> (B.pack . T.unpack $ interestName) <> "\"]")] -- A function which takes an initial key value pair list and adds Just pairs and skips Nothing values. -- Aeson would by default encode this as "value":null which we dont want.- consOptionals :: [(ByteString, ByteString)]- -> [(ByteString, ByteString)]+ consOptionals ::+ [(ByteString, ByteString)] -> [(ByteString, ByteString)] consOptionals = consJust "apns" (nullToMaybe apnsBS) . consJust "fcm" (nullToMaybe fcmBS) .@@ -233,8 +233,8 @@ return $ NotificationDecoding (bs, notification) -- Cons an attribute value pair if Just where- consJust- :: ByteString+ consJust ::+ ByteString -> Maybe ByteString -> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
test/Webhook.hs view
@@ -7,33 +7,38 @@ import qualified Data.HashMap.Strict as HM import Data.Time.Clock.POSIX import Network.Pusher- (parseChannel, AppKey, AppSecret, WebhookPayload(..), Webhooks(..),- WebhookEv(..), AuthSignature,parseWebhookPayloadWith)+ (AppKey, AppSecret, AuthSignature, WebhookEv(..),+ WebhookPayload(..), Webhooks(..), parseChannel,+ 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+data TestWebhookPayload = TestWebhookPayload {+ -- A Request recieved from Pusher+ _webhookRequest :: ([(B.ByteString, B.ByteString)], B.ByteString)+ -- Must have this key+ , _hasKey :: AppKey+ -- Which must correspond to this secret+ , _hasSecret :: AppSecret+ -- And which must parse to this Payload+ , _payload :: Maybe WebhookPayload } --- | Attempt to parse the contained req.+-- 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-+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:@@ -53,8 +58,8 @@ -- - 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+mkSimpleTestWebhookPayload ::+ AppKey -> AppSecret -> POSIXTime -> B.ByteString@@ -63,7 +68,8 @@ -> TestWebhookPayload mkSimpleTestWebhookPayload key secret unixTime body signature whs = TestWebhookPayload- { _webhookRequest = ([("X-Pusher-Key",key),("X-Pusher-Signature",signature)],body)+ { _webhookRequest =+ ([("X-Pusher-Key", key), ("X-Pusher-Signature", signature)], body) , _hasKey = key , _hasSecret = secret , _payload =