diff --git a/pusher-http-haskell.cabal b/pusher-http-haskell.cabal --- a/pusher-http-haskell.cabal +++ b/pusher-http-haskell.cabal @@ -1,82 +1,82 @@ -name: pusher-http-haskell -version: 1.2.0.1 -cabal-version: >=1.18 -build-type: Simple -license: MIT -license-file: LICENSE -copyright: (c) Will Sewell, 2016 -author: Will Sewell -maintainer: me@willsewell.com -stability: experimental -homepage: https://github.com/pusher-community/pusher-http-haskell -bug-reports: https://github.com/pusher-community/pusher-http-haskell/issues -synopsis: Haskell client library for the Pusher HTTP API -description: Functions that correspond to endpoints of the Pusher HTTP - API. Messages can be triggered, and information about the - channel can be queried. Additionally there are functions - for authenticating users of private and presence channels. -category: Network -tested-with: GHC >= 7.10.2 +name: pusher-http-haskell +version: 1.3.0.0 +cabal-version: >=1.18 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: (c) Will Sewell, 2016 +maintainer: me@willsewell.com +stability: experimental +homepage: https://github.com/pusher-community/pusher-http-haskell +bug-reports: https://github.com/pusher-community/pusher-http-haskell/issues +synopsis: Haskell client library for the Pusher HTTP API +description: + Functions that correspond to endpoints of the Pusher HTTP + API. Messages can be triggered, and information about the + channel can be queried. Additionally there are functions + for authenticating users of private and presence channels. +category: Network +author: Will Sewell +tested-with: GHC >=7.10.2 library - exposed-modules: Network.Pusher, - Network.Pusher.Internal, - Network.Pusher.Internal.Auth, - Network.Pusher.Internal.HTTP, - Network.Pusher.Protocol - other-modules: Network.Pusher.Data, - Network.Pusher.Error, - Network.Pusher.Internal.Util - default-language: Haskell2010 - hs-source-dirs: src - default-extensions: OverloadedStrings - build-depends: aeson >=0.8 && <1.3, - base >=4.7 && <4.10, - bytestring ==0.10.*, - base16-bytestring ==0.1.*, - cryptohash ==0.11.*, - hashable ==1.2.*, - http-client >=0.4 && <0.6, - http-types >=0.8 && <0.10, - text ==1.2.*, - time >=1.5 && <1.7, - transformers >=0.4 && <0.6, - unordered-containers ==0.2.* - ghc-options: -Wall - if impl(ghc >= 8.0.0) - ghc-options: -Wcompat - -Whi-shadowing - -Wmissing-signatures - else - ghc-options: -fwarn-hi-shadowing - -fwarn-missing-signatures - -fwarn-tabs + if impl(ghc >=8.0.0) + ghc-options: -Wcompat -Whi-shadowing -Wmissing-signatures + else + ghc-options: -fwarn-hi-shadowing -fwarn-missing-signatures -fwarn-tabs + exposed-modules: + Network.Pusher + Network.Pusher.Internal + Network.Pusher.Internal.Auth + Network.Pusher.Internal.HTTP + Network.Pusher.Protocol + build-depends: + aeson >=0.8 && <1.3, + base >=4.7 && <4.11, + bytestring ==0.10.*, + base16-bytestring ==0.1.*, + cryptohash ==0.11.*, + hashable ==1.2.*, + http-client >=0.4 && <0.6, + http-types >=0.8 && <0.10, + text ==1.2.*, + time >=1.5 && <1.7, + transformers >=0.4 && <0.6, + unordered-containers ==0.2.* + default-language: Haskell2010 + default-extensions: OverloadedStrings + hs-source-dirs: src + other-modules: + Network.Pusher.Data + Network.Pusher.Error + Network.Pusher.Internal.Util + ghc-options: -Wall + test-suite tests - default-language: Haskell2010 - default-extensions: OverloadedStrings - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: Auth, - Protocol - hs-source-dirs: test - build-depends: aeson, - base, - bytestring, - hspec, - http-client, - http-types, - pusher-http-haskell, - QuickCheck, - text, - transformers, - unordered-containers - ghc-options: -Wall - if impl(ghc >= 8.0.0) - ghc-options: -Wcompat - -Whi-shadowing - -Wmissing-signatures - else - ghc-options: -fwarn-hi-shadowing - -fwarn-missing-signatures - -fwarn-tabs + + if impl(ghc >=8.0.0) + ghc-options: -Wcompat -Whi-shadowing -Wmissing-signatures + else + ghc-options: -fwarn-hi-shadowing -fwarn-missing-signatures -fwarn-tabs + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + aeson -any, + base -any, + bytestring -any, + hspec -any, + http-client -any, + http-types -any, + pusher-http-haskell -any, + QuickCheck -any, + text -any, + transformers -any, + unordered-containers -any + default-language: Haskell2010 + default-extensions: OverloadedStrings + hs-source-dirs: test + other-modules: + Auth + Protocol + 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 @@ -24,9 +24,10 @@ @ let credentials = Credentials - { credentialsAppID = 123 - , credentialsAppKey = wrd12344rcd234 + { credentialsAppID = 123 + , credentialsAppKey = wrd12344rcd234 , credentialsAppSecret = 124df34d545v + , credentialsCluster = Nothing } pusher <- getPusher credentials result <- @@ -40,11 +41,12 @@ 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 , AppKey , AppSecret @@ -78,46 +80,26 @@ , PusherError(..) ) where -import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT) import qualified Data.Text as T import Network.Pusher.Data - ( AppID - , AppKey - , AppSecret - , Channel(..) - , ChannelName - , ChannelType(..) - , Credentials(..) - , Event - , EventData - , Pusher(..) - , SocketID - , getPusher - , getPusherWithHost - , getPusherWithConnManager - , parseChannel - , renderChannel - , renderChannelPrefix - ) -import Network.Pusher.Error(PusherError(..)) + (AppID, AppKey, AppSecret, Channel(..), ChannelName, + ChannelType(..), Credentials(..), Cluster(..), Event, EventData, + Pusher(..), SocketID, getPusher, getPusherWithHost, + getPusherWithConnManager, parseChannel, renderChannel, + renderChannelPrefix) +import Network.Pusher.Error (PusherError(..)) +import qualified Network.Pusher.Internal as Pusher import Network.Pusher.Internal.Auth - ( AuthSignature - , AuthString - , authenticatePresence - , authenticatePrivate - ) + (AuthSignature, AuthString, authenticatePresence, + authenticatePrivate) +import qualified Network.Pusher.Internal.HTTP as HTTP import Network.Pusher.Internal.Util (getTime) import Network.Pusher.Protocol - ( ChannelInfoQuery - , ChannelsInfo - , ChannelsInfoQuery - , FullChannelInfo - , Users - ) -import qualified Network.Pusher.Internal as Pusher -import qualified Network.Pusher.Internal.HTTP as HTTP + (ChannelInfoQuery, ChannelsInfo, ChannelsInfoQuery, + FullChannelInfo, Users) -- |Trigger an event to one or more channels. trigger @@ -132,10 +114,11 @@ -- ^An optional socket ID of a connection you wish to exclude -> m (Either PusherError ()) trigger pusher chans event dat socketId = - liftIO $ runExceptT $ do + liftIO $ + runExceptT $ do (requestParams, requestBody) <- ExceptT $ - Pusher.mkTriggerRequest pusher chans event dat socketId <$> getTime + Pusher.mkTriggerRequest pusher chans event dat socketId <$> getTime HTTP.post (pusherConnectionManager pusher) requestParams requestBody -- |Query a list of channels for information. @@ -148,18 +131,14 @@ -- ^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 + -> m (Either PusherError ChannelsInfo) -- ^The returned data channels pusher channelTypeFilter prefixFilter attributes = - liftIO $ runExceptT $ do + liftIO $ + runExceptT $ do requestParams <- liftIO $ - Pusher.mkChannelsRequest - pusher - channelTypeFilter - prefixFilter - attributes <$> - getTime + Pusher.mkChannelsRequest pusher channelTypeFilter prefixFilter attributes <$> + getTime HTTP.get (pusherConnectionManager pusher) requestParams -- |Query for information on a single channel. @@ -171,7 +150,8 @@ -- ^Can query user count and also subscription count (if enabled) -> m (Either PusherError FullChannelInfo) channel pusher chan attributes = - liftIO $ runExceptT $ do + liftIO $ + runExceptT $ do requestParams <- liftIO $ Pusher.mkChannelRequest pusher chan attributes <$> getTime HTTP.get (pusherConnectionManager pusher) requestParams @@ -179,10 +159,9 @@ -- |Get a list of users in a presence channel. users :: MonadIO m - => Pusher - -> Channel - -> m (Either PusherError Users) + => Pusher -> Channel -> m (Either PusherError Users) users pusher chan = - liftIO $ runExceptT $ do + liftIO $ + runExceptT $ do requestParams <- liftIO $ Pusher.mkUsersRequest pusher chan <$> getTime HTTP.get (pusherConnectionManager pusher) requestParams 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,13 +13,18 @@ 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(..) , Credentials(..) + , Cluster(..) + , clusterMt1 + , clusterEu + , clusterAp1 + , clusterAp2 , getPusher , getPusherWithHost , getPusherWithConnManager @@ -37,19 +42,21 @@ ) where import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson ((.:)) +import Data.Aeson ((.:), (.:?)) +import qualified Data.Aeson as A +import qualified Data.ByteString as B import Data.Foldable (asum) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) import GHC.Generics (Generic) -import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) -import qualified Data.Aeson as A -import qualified Data.ByteString as B -import qualified Data.Text as T +import Network.HTTP.Client + (Manager, defaultManagerSettings, newManager) -import Network.Pusher.Internal.Util (failExpectObj, show') +import Network.Pusher.Internal.Util + (failExpectObj, failExpectStr, show') type AppID = Integer @@ -70,24 +77,53 @@ { credentialsAppID :: AppID , credentialsAppKey :: AppKey , credentialsAppSecret :: AppSecret + , credentialsCluster :: Maybe Cluster } instance A.FromJSON Credentials where - parseJSON (A.Object v) = Credentials - <$> v .: "app-id" - <*> (encodeUtf8 <$> v .: "app-key") - <*> (encodeUtf8 <$> v .: "app-secret") + parseJSON (A.Object v) = + Credentials <$> v .: "app-id" <*> (encodeUtf8 <$> v .: "app-key") <*> + (encodeUtf8 <$> v .: "app-secret") <*> + v .:? "app-cluster" parseJSON v2 = failExpectObj v2 +-- | The cluster the current app resides on. Common clusters include: mt1,eu,ap1,ap2 +newtype Cluster = Cluster + { clusterName :: T.Text + } + +clusterMt1, clusterEu, clusterAp1, clusterAp2 :: Cluster +clusterMt1 = Cluster "mt1" + +clusterEu = Cluster "eu" + +clusterAp1 = Cluster "ap1" + +clusterAp2 = Cluster "ap2" + +-- The possible cluster suffix given in a host name +renderClusterSuffix :: Cluster -> T.Text +renderClusterSuffix cluster = "-" <> clusterName cluster + +instance A.FromJSON Cluster where + parseJSON v = + case v of + A.String txt -> return . Cluster $ txt + _ -> failExpectStr v + -- |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 cred + connManager <- getConnManager + return $ getPusherWithConnManager connManager Nothing cred -- |Get a Pusher instance that uses a specific API endpoint. -getPusherWithHost :: MonadIO m => T.Text -> Credentials -> m Pusher +getPusherWithHost + :: MonadIO m + => T.Text -> Credentials -> m Pusher getPusherWithHost apiHost cred = do connManager <- getConnManager return $ getPusherWithConnManager connManager (Just apiHost) cred @@ -96,21 +132,35 @@ -- if you want to share a connection with your application code. getPusherWithConnManager :: Manager -> Maybe T.Text -> Credentials -> Pusher getPusherWithConnManager connManager apiHost cred = - let path = "/apps/" <> show' (credentialsAppID cred) <> "/" in - Pusher - { pusherHost = fromMaybe "http://api.pusherapp.com" apiHost - , pusherPath = path - , pusherCredentials = cred - , pusherConnectionManager = connManager - } + let path = "/apps/" <> show' (credentialsAppID cred) <> "/" + mCluster = credentialsCluster cred + in Pusher + { pusherHost = fromMaybe (mkHost mCluster) apiHost + , pusherPath = path + , pusherCredentials = cred + , pusherConnectionManager = connManager + } -getConnManager :: MonadIO m => m Manager +-- |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 = liftIO $ newManager defaultManagerSettings type ChannelName = T.Text -- |The possible types of Pusher channe. -data ChannelType = Public | Private | Presence deriving (Eq, Generic, Show) +data ChannelType + = Public + | Private + | Presence + deriving (Eq, Generic, Show) instance Hashable ChannelType @@ -132,19 +182,19 @@ -- |Convert string representation, e.g. private-chan into the datatype parseChannel :: T.Text -> Channel -parseChannel chan = +parseChannel chan -- Attempt to parse it as a private or presence channel; default to public + = fromMaybe (Channel Public chan) - (asum [parseChanAs Private, parseChanAs Presence]) - where - parseChanAs chanType = - let split = T.splitOn (renderChannelPrefix chanType) chan in + (asum [parseChanAs Private, parseChanAs Presence]) + where + parseChanAs chanType = + let split = T.splitOn (renderChannelPrefix chanType) chan -- If the prefix appears at the start, then the first element will be empty - if length split > 1 && T.null (head split) then - Just $ Channel chanType (T.concat $ tail split) - else - Nothing + in if length split > 1 && T.null (head split) + then Just $ Channel chanType (T.concat $ tail split) + else Nothing type Event = T.Text 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 @@ -1,4 +1,6 @@ -module Network.Pusher.Error (PusherError(..)) where +module Network.Pusher.Error + ( PusherError(..) + ) where import Control.Exception (Exception) import qualified Data.Text as T @@ -10,6 +12,6 @@ | PusherNon200ResponseError T.Text -- |Received unexpected data from Pusher. | PusherInvalidResponseError T.Text - deriving Show + 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 @@ -14,37 +14,23 @@ ) where import Control.Monad (when) -import Data.Maybe (maybeToList) -import Data.Monoid ((<>)) -import Data.Text.Encoding (encodeUtf8) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import Data.Maybe (maybeToList) +import Data.Monoid ((<>)) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Network.Pusher.Data - ( Channel - , ChannelType - , Credentials(..) - , Event - , EventData - , Pusher(..) - , SocketID - , renderChannel - , renderChannelPrefix - ) -import Network.Pusher.Error(PusherError(..)) + (Channel, ChannelType, Credentials(..), Event, EventData, + Pusher(..), SocketID, renderChannel, renderChannelPrefix) +import Network.Pusher.Error (PusherError(..)) import Network.Pusher.Internal.Auth (makeQS) import Network.Pusher.Internal.HTTP - ( RequestBody - , RequestParams(RequestParams) - , RequestQueryString - ) + (RequestBody, RequestParams(RequestParams), RequestQueryString) import Network.Pusher.Protocol - ( ChannelInfoQuery - , ChannelsInfoQuery - , toURLParam - ) + (ChannelInfoQuery, ChannelsInfoQuery, toURLParam) mkTriggerRequest :: Pusher @@ -55,20 +41,21 @@ -> Int -> Either PusherError (RequestParams, RequestBody) mkTriggerRequest pusher chans event dat socketId time = do - when - (length chans > 10) - (Left $ PusherArgumentError "Must be less than 10 channels") - let - body = A.object $ + when + (length chans > 10) + (Left $ PusherArgumentError "Must be less than 10 channels") + let body = + A.object $ [ ("name", A.String event) , ("channels", A.toJSON (map (A.String . renderChannel) chans)) , ("data", A.String dat) - ] ++ maybeToList (fmap (\sID -> ("socket_id", A.String sID)) socketId) + ] ++ + maybeToList (fmap (\sID -> ("socket_id", A.String sID)) socketId) bodyBS = BL.toStrict $ A.encode body - when - (B.length bodyBS > 10000) - (Left $ PusherArgumentError "Body must be less than 10000KB") - return (mkPostRequest pusher "events" [] bodyBS time, body) + when + (B.length bodyBS > 10000) + (Left $ PusherArgumentError "Body must be less than 10000KB") + return (mkPostRequest pusher "events" [] bodyBS time, body) mkChannelsRequest :: Pusher @@ -78,61 +65,44 @@ -> Int -> RequestParams mkChannelsRequest pusher channelTypeFilter prefixFilter attributes time = - let - prefix = maybe "" renderChannelPrefix channelTypeFilter <> prefixFilter - params = - [ ("info", encodeUtf8 $ toURLParam attributes) - , ("filter_by_prefix", encodeUtf8 prefix) - ] - in - mkGetRequest pusher "channels" params time + let prefix = maybe "" renderChannelPrefix channelTypeFilter <> prefixFilter + params = + [ ("info", encodeUtf8 $ toURLParam attributes) + , ("filter_by_prefix", encodeUtf8 prefix) + ] + 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 - in - mkGetRequest pusher subPath params time + let params = [("info", encodeUtf8 $ toURLParam attributes)] + subPath = "channels/" <> renderChannel chan + in mkGetRequest pusher subPath params time mkUsersRequest :: Pusher -> Channel -> Int -> RequestParams mkUsersRequest pusher chan time = - let - subPath = "channels/" <> renderChannel chan <> "/users" - in - mkGetRequest pusher subPath [] time + let subPath = "channels/" <> renderChannel chan <> "/users" + in mkGetRequest pusher subPath [] time -mkGetRequest - :: Pusher - -> T.Text - -> RequestQueryString - -> Int - -> RequestParams +mkGetRequest :: Pusher -> T.Text -> RequestQueryString -> Int -> RequestParams mkGetRequest pusher subPath params time = - let - (ep, fullPath) = mkEndpoint pusher subPath - qs = mkQS pusher "GET" fullPath params "" time - in - RequestParams ep qs + let (ep, fullPath) = mkEndpoint pusher subPath + 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 + let (ep, fullPath) = mkEndpoint 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 @@ -140,11 +110,9 @@ -> 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) + let fullPath = pusherPath pusher <> subPath + endpoint = pusherHost pusher <> fullPath + in (endpoint, fullPath) mkQS :: Pusher @@ -155,9 +123,5 @@ -> Int -> RequestQueryString mkQS pusher = - let - credentials = pusherCredentials pusher - in - makeQS - (credentialsAppKey credentials) - (credentialsAppSecret credentials) + let credentials = pusherCredentials pusher + in makeQS (credentialsAppKey credentials) (credentialsAppSecret credentials) 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 @@ -18,35 +18,31 @@ , AuthSignature , authenticatePresence , authenticatePresenceWithEncoder - , authenticatePrivate, makeQS + , authenticatePrivate + , makeQS ) where +import qualified Data.Aeson as A import Data.Monoid ((<>)) import Data.Text.Encoding (encodeUtf8) import GHC.Exts (sortWith) -import qualified Data.Aeson as A #if MIN_VERSION_aeson(1,0,0) import qualified Data.Aeson.Text as A #else import qualified Data.Aeson.Encode as A #endif +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.MAC.HMAC as HMAC import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL -import qualified Crypto.Hash.MD5 as MD5 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.MAC.HMAC as HMAC import Network.Pusher.Data - ( AppKey - , AppSecret - , Channel - , Credentials(..) - , SocketID - , renderChannel - ) + (AppKey, AppSecret, Channel, Credentials(..), SocketID, + renderChannel) import Network.Pusher.Internal.HTTP (RequestQueryString) import Network.Pusher.Internal.Util (show') @@ -62,28 +58,29 @@ -> Int -- ^Current UNIX timestamp -> RequestQueryString makeQS appKey appSecret method path params body ts = - let - -- Generate all required parameters and add them to the list of existing ones - allParams = sortWith fst $ params ++ - [ ("auth_key", appKey) - , ("auth_timestamp", show' ts) - , ("auth_version", "1.0") - , ("body_md5", B16.encode (MD5.hash body)) - ] + let allParams + -- Generate all required parameters and add them to the list of existing + -- ones + = + sortWith fst $ + params ++ + [ ("auth_key", appKey) + , ("auth_timestamp", show' ts) + , ("auth_version", "1.0") + , ("body_md5", B16.encode (MD5.hash body)) + ] -- Generate the auth signature from the list of parameters - authSig = authSignature appSecret $ B.intercalate "\n" - [ encodeUtf8 method - , encodeUtf8 path - , formQueryString allParams - ] - in + authSig = + authSignature appSecret $ + B.intercalate + "\n" + [encodeUtf8 method, encodeUtf8 path, formQueryString allParams] -- Add the auth string to the list - ("auth_signature", authSig) : allParams + in ("auth_signature", authSig) : allParams -- |Render key-value tuple mapping of query string parameters into a string. formQueryString :: RequestQueryString -> B.ByteString -formQueryString = - B.intercalate "&" . map (\(a, b) -> a <> "=" <> b) +formQueryString = B.intercalate "&" . map (\(a, b) -> a <> "=" <> b) -- | The bytestring to sign with the app secret to create a signature from. type AuthString = B.ByteString @@ -96,31 +93,21 @@ authSignature appSecret authString = B16.encode $ HMAC.hmac SHA256.hash 64 appSecret authString - -- |Generate an auth signature of the form "app_key:auth_sig" for a user of a -- private channel. -authenticatePrivate - :: Credentials - -> SocketID - -> Channel - -> AuthSignature +authenticatePrivate :: Credentials -> SocketID -> Channel -> AuthSignature authenticatePrivate cred socketID channel = - let - sig = authSignature - (credentialsAppSecret cred) - (encodeUtf8 $ socketID <> ":" <> renderChannel channel) - in - credentialsAppKey cred <> ":" <> sig + let sig = + authSignature + (credentialsAppSecret cred) + (encodeUtf8 $ socketID <> ":" <> renderChannel channel) + in credentialsAppKey cred <> ":" <> sig -- |Generate an auth signature of the form "app_key:auth_sig" for a user of a -- presence channel. authenticatePresence :: A.ToJSON a - => Credentials - -> SocketID - -> Channel - -> a - -> AuthSignature + => Credentials -> SocketID -> Channel -> a -> AuthSignature authenticatePresence = authenticatePresenceWithEncoder (TL.toStrict . TL.toLazyText . A.encodeToTextBuilder . A.toJSON) @@ -136,9 +123,8 @@ -> a -> AuthSignature authenticatePresenceWithEncoder userEncoder cred socketID channel userData = - let - authString = - encodeUtf8 $ socketID <> ":" <> renderChannel channel <> ":" <> userEncoder userData - sig = authSignature (credentialsAppSecret cred) authString - in - credentialsAppKey cred <> ":" <> sig + let authString = + encodeUtf8 $ + socketID <> ":" <> renderChannel channel <> ":" <> userEncoder userData + sig = authSignature (credentialsAppSecret cred) authString + in credentialsAppKey cred <> ":" <> sig 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 @@ -26,16 +26,16 @@ import Control.Exception (displayException) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE) -import Data.Monoid ((<>)) -import Data.Text.Encoding (decodeUtf8') -import Network.HTTP.Types.Header (hContentType) -import Network.HTTP.Types.Method (methodPost) -import Network.HTTP.Types.Status (statusCode, statusMessage) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import Data.Monoid ((<>)) import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8') import qualified Network.HTTP.Client as HTTP.Client +import Network.HTTP.Types.Header (hContentType) +import Network.HTTP.Types.Method (methodPost) +import Network.HTTP.Types.Status (statusCode, statusMessage) import Network.Pusher.Error (PusherError(..)) @@ -56,8 +56,7 @@ :: 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 <- doReqest connManager req @@ -69,37 +68,33 @@ -- |Issue an HTTP POST request. post :: A.ToJSON a - => HTTP.Client.Manager - -> RequestParams - -> a - -> ExceptT PusherError IO () + => 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 _ <- doReqest 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 Just req -> Right $ HTTP.Client.setQueryString (map (second Just) qs) req - where + where + #if MIN_VERSION_http_client(0,4,30) parseRequest = HTTP.Client.parseRequest #else parseRequest = HTTP.Client.parseUrl #endif - mkPost :: BL.ByteString -> HTTP.Client.Request -> HTTP.Client.Request mkPost body req = req - { HTTP.Client.method = methodPost - , HTTP.Client.requestHeaders = [(hContentType, "application/json")] - , HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS body - } + { HTTP.Client.method = methodPost + , HTTP.Client.requestHeaders = [(hContentType, "application/json")] + , HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS body + } doReqest :: HTTP.Client.Manager @@ -108,12 +103,11 @@ doReqest connManager req = do response <- liftIO $ HTTP.Client.httpLbs req connManager let status = HTTP.Client.responseStatus response - if statusCode status == 200 then - return $ HTTP.Client.responseBody response - else - let decoded = decodeUtf8' $ statusMessage status in - throwE $ - either - (PusherInvalidResponseError . T.pack . displayException) - PusherNon200ResponseError - decoded + if statusCode status == 200 + then return $ HTTP.Client.responseBody response + else let decoded = decodeUtf8' $ statusMessage status + in throwE $ + either + (PusherInvalidResponseError . T.pack . displayException) + PusherNon200ResponseError + decoded 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 @@ -8,14 +8,15 @@ -} module Network.Pusher.Internal.Util ( failExpectObj + , failExpectStr , getTime , show' ) where -import Data.String (IsString, fromString) -import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A +import Data.String (IsString, fromString) +import Data.Time.Clock.POSIX (getPOSIXTime) -- |Get the system time as an Int. getTime :: IO Int @@ -26,6 +27,13 @@ failExpectObj :: A.Value -> A.Parser a failExpectObj = fail . ("Expected JSON object, got " ++) . show +-- |When decoding Aeson values, this can be used to return a failing parser +-- when an string was expected, but it was a different type of data. +failExpectStr :: A.Value -> A.Parser a +failExpectStr = fail . ("Expected JSON string, got " ++) . show + -- | Generalised version of show -show' :: (Show a, IsString b) => a -> b +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 @@ -29,23 +29,24 @@ ) where import Data.Aeson ((.:), (.:?)) -import Data.Hashable (Hashable) -import GHC.Generics (Generic) import qualified Data.Aeson as A import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS +import Data.Hashable (Hashable) import qualified Data.Text as T +import GHC.Generics (Generic) -import Network.Pusher.Internal.Util (failExpectObj) import Network.Pusher.Data (Channel, parseChannel) +import Network.Pusher.Internal.Util (failExpectObj) -- |Types that can be serialised to a querystring parameter value. class ToURLParam a where - -- |Convert the data into a querystring parameter value. toURLParam :: a -> T.Text -- |Enumeration of the attributes that can be queried about multiple channels. -data ChannelsInfoAttributes = ChannelsUserCount deriving (Eq, Generic) +data ChannelsInfoAttributes = + ChannelsUserCount + deriving (Eq, Generic) instance ToURLParam ChannelsInfoAttributes where toURLParam ChannelsUserCount = "user_count" @@ -55,10 +56,12 @@ -- |A set of requested ChannelsInfoAttributes. newtype ChannelsInfoQuery = ChannelsInfoQuery (HS.HashSet ChannelsInfoAttributes) - deriving ToURLParam + deriving (ToURLParam) -- |Enumeration of the attributes that can be queried about a single channel. -data ChannelInfoAttributes = ChannelUserCount | ChannelSubscriptionCount +data ChannelInfoAttributes + = ChannelUserCount + | ChannelSubscriptionCount deriving (Eq, Generic) instance ToURLParam ChannelInfoAttributes where @@ -68,11 +71,12 @@ instance Hashable ChannelInfoAttributes -- |A set of requested ChannelInfoAttributes. -newtype ChannelInfoQuery = ChannelInfoQuery (HS.HashSet ChannelInfoAttributes) - deriving ToURLParam - +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 @@ -85,18 +89,19 @@ parseJSON (A.Object v) = do chansV <- v .: "channels" case chansV of - A.Object cs -> + A.Object cs -- Need to go to and from list in order to map (parse) the keys - ChannelsInfo . HM.fromList - <$> mapM - (\(channel, info) -> (parseChannel channel,) <$> A.parseJSON info) - (HM.toList cs) + -> + ChannelsInfo . HM.fromList <$> + mapM + (\(channel, info) -> (parseChannel channel, ) <$> A.parseJSON info) + (HM.toList cs) v1 -> failExpectObj v1 parseJSON v2 = failExpectObj v2 -- |The possible returned channel attributes when multiple when multiple -- channels are queried. -data ChannelInfo = ChannelInfo +newtype ChannelInfo = ChannelInfo { channelInfoUserCount :: Maybe Int } deriving (Eq, Show) @@ -113,14 +118,14 @@ instance A.FromJSON FullChannelInfo where parseJSON (A.Object v) = - FullChannelInfo - <$> v .: "occupied" - <*> v .:? "user_count" - <*> v .:? "subscription_count" + FullChannelInfo <$> v .: "occupied" <*> v .:? "user_count" <*> + v .:? "subscription_count" parseJSON v = failExpectObj v -- |A list of users returned by querying for users in a presence channel. -newtype Users = Users [User] deriving (Eq, Show) +newtype Users = + Users [User] + deriving (Eq, Show) instance A.FromJSON Users where parseJSON (A.Object v) = do @@ -128,8 +133,11 @@ Users <$> A.parseJSON users parseJSON v = failExpectObj v --- |The data about a user returned when querying for users in a presence channel. -data User = User { userID :: T.Text } deriving (Eq, Show) +-- |The data about a user returned when querying for users in a presence +-- channel. +newtype User = User + { userID :: T.Text + } deriving (Eq, Show) instance A.FromJSON User where parseJSON (A.Object v) = User <$> v .: "id" diff --git a/test/Auth.hs b/test/Auth.hs --- a/test/Auth.hs +++ b/test/Auth.hs @@ -3,56 +3,54 @@ import Test.Hspec (Spec, describe, it, shouldBe) import Network.Pusher - ( Channel(..) - , ChannelType(Private, Presence) - , Credentials(..) - ) + (Channel(..), ChannelType(Presence, Private), Credentials(..)) import Network.Pusher.Internal.Auth - ( authenticatePrivate - , authenticatePresenceWithEncoder - , makeQS - ) + (authenticatePresenceWithEncoder, authenticatePrivate, makeQS) test :: Spec test = do describe "Auth.makeQS" $ it "works" $ -- Happy case based on data from the docs: https://pusher.com/docs/rest_api#worked-authentication-example - let - body = "{\"name\":\"foo\",\"channels\":[\"project-3\"],\"data\":\"{\\\"some\\\":\\\"data\\\"}\"}" - in - makeQS (credentialsAppKey credentials) (credentialsAppSecret credentials) "POST" "/apps/3/events" [] body 1353088179 - `shouldBe` - [ ("auth_signature", "da454824c97ba181a32ccc17a72625ba02771f50b50e1e7430e47a1f3f457e6c") - , ("auth_key","278d425bdf160c739803") - , ("auth_timestamp","1353088179") - , ("auth_version","1.0") - , ("body_md5","ec365a775a4cd0599faeb73354201b6f") - ] - + let body = + "{\"name\":\"foo\",\"channels\":[\"project-3\"],\"data\":\"{\\\"some\\\":\\\"data\\\"}\"}" + in makeQS + (credentialsAppKey credentials) + (credentialsAppSecret credentials) + "POST" + "/apps/3/events" + [] + body + 1353088179 `shouldBe` + [ ( "auth_signature" + , "da454824c97ba181a32ccc17a72625ba02771f50b50e1e7430e47a1f3f457e6c") + , ("auth_key", "278d425bdf160c739803") + , ("auth_timestamp", "1353088179") + , ("auth_version", "1.0") + , ("body_md5", "ec365a775a4cd0599faeb73354201b6f") + ] describe "Auth.authenticatePrivate" $ it "works" $ -- Data from https://pusher.com/docs/auth_signatures#worked-example - authenticatePrivate credentials "1234.1234" (Channel Private "foobar") - `shouldBe` "278d425bdf160c739803:58df8b0c36d6982b82c3ecf6b4662e34fe8c25bba48f5369f135bf843651c3a4" - + authenticatePrivate credentials "1234.1234" (Channel Private "foobar") `shouldBe` + "278d425bdf160c739803:58df8b0c36d6982b82c3ecf6b4662e34fe8c25bba48f5369f135bf843651c3a4" describe "Auth.authenticatePresenceWithEncoder" $ it "works for presence channels" $ -- Data from https://pusher.com/docs/auth_signatures#presence - let - userData = "{\"user_id\":10,\"user_info\":{\"name\":\"Mr. Pusher\"}}" - in - authenticatePresenceWithEncoder - (const userData) - credentials - "1234.1234" - (Channel Presence "foobar") - ("doesn't matter" :: String) - `shouldBe` "278d425bdf160c739803:afaed3695da2ffd16931f457e338e6c9f2921fa133ce7dac49f529792be6304c" + let userData = "{\"user_id\":10,\"user_info\":{\"name\":\"Mr. Pusher\"}}" + in authenticatePresenceWithEncoder + (const userData) + credentials + "1234.1234" + (Channel Presence "foobar") + ("doesn't matter" :: String) `shouldBe` + "278d425bdf160c739803:afaed3695da2ffd16931f457e338e6c9f2921fa133ce7dac49f529792be6304c" credentials :: Credentials -credentials = Credentials +credentials = + Credentials { credentialsAppID = 3 , credentialsAppKey = "278d425bdf160c739803" , credentialsAppSecret = "7ad3773142a6692b25b8" + , credentialsCluster = Nothing } diff --git a/test/Protocol.hs b/test/Protocol.hs --- a/test/Protocol.hs +++ b/test/Protocol.hs @@ -1,32 +1,26 @@ module Protocol where -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.QuickCheck (Arbitrary(..), elements, property) import qualified Data.Aeson as A import qualified Data.HashMap.Strict as HM import qualified Data.Text as T +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (Arbitrary(..), elements, property) import Network.Pusher - ( Channel(..) - , ChannelType(Public, Presence, Private) - , parseChannel - , renderChannel - ) + (Channel(..), ChannelType(Presence, Private, Public), parseChannel, + renderChannel) import Network.Pusher.Protocol - ( ChannelInfo(..) - , ChannelsInfo(..) - , FullChannelInfo(..) - , User(..) - , Users(..) - ) + (ChannelInfo(..), ChannelsInfo(..), FullChannelInfo(..), User(..), + Users(..)) -newtype TestChannel = TestChannel Channel deriving (Show) +newtype TestChannel = + TestChannel Channel + deriving (Show) instance Arbitrary TestChannel where arbitrary = do - let - testChannelType = elements [Public, Private, Presence] - channel = Channel <$> testChannelType <*> (T.pack <$> arbitrary) + let testChannelType = elements [Public, Private, Presence] + channel = Channel <$> testChannelType <*> (T.pack <$> arbitrary) TestChannel <$> channel test :: Spec @@ -34,18 +28,16 @@ describe "Protocol.Channel" $ do it "show instance works for public channels" $ renderChannel (Channel Public "test") `shouldBe` "test" - it "show instance works for private channels" $ renderChannel (Channel Private "test") `shouldBe` "private-test" - it "show instance is an inverse of parseChannel" $ - property $ \(TestChannel chan) -> parseChannel (renderChannel chan) == chan - + property $ \(TestChannel chan) -> + parseChannel (renderChannel chan) == chan describe "Protocol.ChannelsInfo" $ it "parsing works" $ -- Data from https://pusher.com/docs/rest_api#successful-response-1 - A.decode - "{\ + A.decode + "{\ \ \"channels\": {\ \ \"presence-foobar\": {\ \ \"user_count\": 42\ @@ -54,33 +46,30 @@ \ \"user_count\": 123\ \ }\ \ }\ -\ }" - `shouldBe` - (Just $ ChannelsInfo $ HM.fromList - [ (Channel Presence "foobar", ChannelInfo $ Just 42) - , (Channel Presence "another", ChannelInfo $ Just 123) - ]) - +\ }" `shouldBe` + (Just $ + ChannelsInfo $ + HM.fromList + [ (Channel Presence "foobar", ChannelInfo $ Just 42) + , (Channel Presence "another", ChannelInfo $ Just 123) + ]) describe "Protocol.FullChannelInfo" $ it "parsing works" $ -- Data from https://pusher.com/docs/rest_api#successful-response-2 - A.decode - "{\ + A.decode + "{\ \ \"occupied\": true,\ \ \"user_count\": 42,\ \ \"subscription_count\": 42\ -\ }" - `shouldBe` - (Just $ FullChannelInfo True (Just 42) (Just 42)) - +\ }" `shouldBe` + (Just $ FullChannelInfo True (Just 42) (Just 42)) describe "Protocol.Users" $ it "parsing works" $ - A.decode - "{\ + A.decode + "{\ \ \"users\": [\ \ { \"id\": \"1\" },\ \ { \"id\": \"2\" }\ \ ]\ -\ }" - `shouldBe` - (Just $ Users [User "1", User "2"]) +\ }" `shouldBe` + (Just $ Users [User "1", User "2"])