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.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 diff --git a/src/Network/Pusher.hs b/src/Network/Pusher.hs --- a/src/Network/Pusher.hs +++ b/src/Network/Pusher.hs @@ -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 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 @@ -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) = diff --git a/src/Network/Pusher/Error.hs b/src/Network/Pusher/Error.hs --- a/src/Network/Pusher/Error.hs +++ b/src/Network/Pusher/Error.hs @@ -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 diff --git a/src/Network/Pusher/Internal.hs b/src/Network/Pusher/Internal.hs --- a/src/Network/Pusher/Internal.hs +++ b/src/Network/Pusher/Internal.hs @@ -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 diff --git a/src/Network/Pusher/Internal/Auth.hs b/src/Network/Pusher/Internal/Auth.hs --- a/src/Network/Pusher/Internal/Auth.hs +++ b/src/Network/Pusher/Internal/Auth.hs @@ -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. diff --git a/src/Network/Pusher/Internal/HTTP.hs b/src/Network/Pusher/Internal/HTTP.hs --- a/src/Network/Pusher/Internal/HTTP.hs +++ b/src/Network/Pusher/Internal/HTTP.hs @@ -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 diff --git a/src/Network/Pusher/Internal/Util.hs b/src/Network/Pusher/Internal/Util.hs --- a/src/Network/Pusher/Internal/Util.hs +++ b/src/Network/Pusher/Internal/Util.hs @@ -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 diff --git a/src/Network/Pusher/Protocol.hs b/src/Network/Pusher/Protocol.hs --- a/src/Network/Pusher/Protocol.hs +++ b/src/Network/Pusher/Protocol.hs @@ -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 diff --git a/src/Network/Pusher/Webhook.hs b/src/Network/Pusher/Webhook.hs --- a/src/Network/Pusher/Webhook.hs +++ b/src/Network/Pusher/Webhook.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Push.hs b/test/Push.hs --- a/test/Push.hs +++ b/test/Push.hs @@ -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)] diff --git a/test/Webhook.hs b/test/Webhook.hs --- a/test/Webhook.hs +++ b/test/Webhook.hs @@ -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 =