diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2015 Will Sewell + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/api/Main.hs b/example/api/Main.hs new file mode 100644 --- /dev/null +++ b/example/api/Main.hs @@ -0,0 +1,38 @@ +module Main where + +import Control.Monad.Pusher (PusherT, runPusherT) +import qualified Data.HashSet as HS +import qualified Data.Pusher as P +import qualified Data.Yaml as Y +import qualified Network.Pusher as P +import qualified Network.Pusher.Protocol as P + +main :: IO () +main = do + eitherCred <- Y.decodeFileEither "example/credentials.yaml" + case eitherCred of + Right cred -> do + pusher <- P.getPusher cred + result <- runPusherT pusherApp pusher + case result of + Right (channels, channel, users) -> do + print $ "Channels info: " ++ show channels + print $ "Channel info: " ++ show channel + print $ "Userss info: " ++ show users + Left e -> print e + Left e -> print e + +pusherApp :: PusherT IO (P.ChannelsInfo, P.FullChannelInfo, P.Users) +pusherApp = do + let chan = P.Channel P.Presence "messages" + P.trigger [chan] "some_event" "data" Nothing + channels <- P.channels + (Just P.Presence) + "" + (P.ChannelsInfoQuery (HS.singleton P.ChannelsUserCount)) + channel <- P.channel + chan + (P.ChannelInfoQuery + (HS.fromList [P.ChannelUserCount, P.ChannelSubscriptionCount])) + users <- P.users chan + return (channels, channel, users) diff --git a/example/auth/Main.hs b/example/auth/Main.hs new file mode 100644 --- /dev/null +++ b/example/auth/Main.hs @@ -0,0 +1,42 @@ +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromJust) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Network.Pusher (authenticatePresence) +import Snap.Core + ( Method(GET) + , Snap + , getParams + , method + , writeBS + ) +import Snap.Http.Server (quickHttpServe) +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Map as M +import qualified Data.Yaml as Y + +main :: IO () +main = quickHttpServe $ method GET authHandler + +authHandler :: Snap () +authHandler = do + cred <- liftIO $ Y.decodeFile "example/credentials.yaml" + params <- getParams + let + userData = A.Object $ HM.fromList -- Would normally come from session data + [ ("user_id", A.Number 10) + , ("user_info", A.Object $ HM.singleton "name" (A.String "Mr. Pusher"))] + signature = authenticatePresence + (fromJust cred) + (head $ params M.! "socket_id") + (head $ params M.! "channel_name") + userData + respBody = A.Object $ HM.fromList + [ ("auth", A.String $ decodeUtf8 signature) + , ("channel_data", A.String $ decodeUtf8 $ BL.toStrict $ A.encode userData) + ] + writeBS $ head (params M.! "callback") <> "(" <> BL.toStrict (A.encode respBody) <> ");" diff --git a/pusher-http-haskell.cabal b/pusher-http-haskell.cabal new file mode 100644 --- /dev/null +++ b/pusher-http-haskell.cabal @@ -0,0 +1,95 @@ +name: pusher-http-haskell +version: 0.1.0.0 +cabal-version: >=1.18 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: (c) Will Sewell, 2015 +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 +category: Network +tested-with: GHC == 7.8.4 + +library + exposed-modules: Control.Monad.Pusher, + Control.Monad.Pusher.HTTP, + Control.Monad.Pusher.Time, + Data.Pusher, + Network.Pusher, + Network.Pusher.Internal.Auth, + Network.Pusher.Internal.HTTP, + Network.Pusher.Protocol + other-modules: Network.Pusher.Internal.Util + default-language: Haskell2010 + hs-source-dirs: src + default-extensions: OverloadedStrings + build-depends: aeson ==0.8.*, + base ==4.7.*, + bytestring ==0.10.*, + base16-bytestring ==0.1.*, + cryptohash ==0.11.*, + hashable ==1.2.*, + http-client ==0.4.*, + http-types ==0.8.*, + mtl ==2.1.*, + QuickCheck ==2.7.*, + text ==1.2.*, + time ==1.4.*, + transformers ==0.3.*, + unordered-containers ==0.2.* + +executable api-example + default-language: Haskell2010 + default-extensions: OverloadedStrings + hs-source-dirs: example/api + main-is: Main.hs + build-depends: base, + mtl, + pusher-http-haskell, + text, + unordered-containers, + yaml + +executable auth-example + default-language: Haskell2010 + default-extensions: OverloadedStrings + hs-source-dirs: example/auth + main-is: Main.hs + build-depends: aeson, + base, + bytestring, + containers, + mtl, + pusher-http-haskell, + snap-core, + snap-server, + text, + transformers, + unordered-containers, + yaml + +test-suite tests + default-language: Haskell2010 + default-extensions: OverloadedStrings + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Auth, + HTTP + Protocol + hs-source-dirs: test + build-depends: aeson, + base, + bytestring, + hspec, + http-client, + http-types, + mtl, + pusher-http-haskell, + QuickCheck, + text, + transformers, + unordered-containers diff --git a/src/Control/Monad/Pusher.hs b/src/Control/Monad/Pusher.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Pusher.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +{-| +Module : Control.Monad.Pusher +Description : Monad type aliases for the return types of the external API functions +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +Monad type aliases for the return types of the external API functions. + +The API functions return a monad that implements MonadPusher. The user of the +library can use PusherT or PusherM as the concrete return type, or they can use +their own types. They are really just aliases for a stack of ReaderT and ErrorT. +-} +module Control.Monad.Pusher (MonadPusher, PusherM, PusherT, runPusherT) where + +import Control.Monad.Error (ErrorT, MonadError, runErrorT) +import Control.Monad.Identity (Identity) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) + +import Control.Monad.Pusher.HTTP (MonadHTTP) +import Control.Monad.Pusher.Time (MonadTime) +import Data.Pusher (Pusher) + +-- |Monad that can be used as the return type of the main API functions. +type PusherM a = PusherT Identity a + +-- |Use this if you wish to stack this on your own monads. +type PusherT m a = ReaderT Pusher (ErrorT String m) a + +-- |Run the monadic Pusher code to extract the result +runPusherT :: PusherT m a -> Pusher -> m (Either String a) +runPusherT run p = runErrorT $ runReaderT run p + +-- |Typeclass alias for the return type of the API functions (keeps the +-- signatures less verbose) +type MonadPusher m = + ( Functor m + , MonadError String m + , MonadHTTP m + , MonadReader Pusher m + , MonadTime m + ) diff --git a/src/Control/Monad/Pusher/HTTP.hs b/src/Control/Monad/Pusher/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Pusher/HTTP.hs @@ -0,0 +1,33 @@ +{-| +Module : Control.Monad.Pusher.HTTP +Description : Typclass for IO monads that can issue HTTP requests +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +A typeclass for IO monads that can issue get and post requests. The intention is +to use the IO instance in the main library, and a mock in the tests. +-} +module Control.Monad.Pusher.HTTP (MonadHTTP(..)) where + +import Control.Monad.Error (Error, ErrorT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans.Class (lift) +import Network.HTTP.Client (Manager, Request, Response) +import qualified Data.ByteString.Lazy as BL +import qualified Network.HTTP.Client as HTTP.Client + +-- |These functions essentially abstract the corresponding functions from the +-- Wreq library. +class Monad m => MonadHTTP m where + httpLbs :: Request -> Manager -> m (Response BL.ByteString) + +instance MonadHTTP IO where + httpLbs = HTTP.Client.httpLbs + +instance MonadHTTP m => MonadHTTP (ReaderT r m) where + httpLbs req mngr = lift $ httpLbs req mngr + +instance (Error e, MonadHTTP m) => MonadHTTP (ErrorT e m) where + httpLbs req mngr = lift $ httpLbs req mngr diff --git a/src/Control/Monad/Pusher/Time.hs b/src/Control/Monad/Pusher/Time.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Pusher/Time.hs @@ -0,0 +1,30 @@ +{-| +Module : Control.Monad.Pusher.Time +Description : Typclass for IO monads that can get the current time +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental +-} +module Control.Monad.Pusher.Time (MonadTime(..)) where + +import Control.Applicative ((<$>)) +import Control.Monad.Error (Error, ErrorT) +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans.Class (lift) +import Network.HTTP.Client (Manager, Request, Response) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Time.Clock.POSIX as Clock +import qualified Network.HTTP.Client as HTTP.Client + +class Monad m => MonadTime m where + getPOSIXTime :: m Int + +instance MonadTime IO where + getPOSIXTime = round <$> Clock.getPOSIXTime + +instance MonadTime m => MonadTime (ReaderT r m) where + getPOSIXTime = lift getPOSIXTime + +instance (Error e, MonadTime m) => MonadTime (ErrorT e m) where + getPOSIXTime = lift getPOSIXTime diff --git a/src/Data/Pusher.hs b/src/Data/Pusher.hs new file mode 100644 --- /dev/null +++ b/src/Data/Pusher.hs @@ -0,0 +1,68 @@ +{-| +Module : Data.Pusher +Description : Data structure to store Pusher config +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +You must create an instance of this datatype with your particular Pusher app +credentials in order to run the main API functions. +-} +module Data.Pusher + ( Pusher(..) + , Credentials(..) + , getPusher + , getPusherWithConnManager + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Aeson ((.:)) +import Data.Monoid ((<>)) +import Data.Text.Encoding (encodeUtf8) +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.Pusher.Internal.Util (failExpectObj) + +-- |All the required configuration needed to interact with the API. +data Pusher = Pusher + { pusherHost :: T.Text + , pusherPath :: T.Text + , pusherCredentials :: Credentials + , pusherConnectionManager :: Manager + } + +-- |The credentials for the current app. +data Credentials = Credentials + { credentialsAppID :: Integer + , credentialsAppKey :: B.ByteString + , credentialsAppSecret :: B.ByteString + } + +instance A.FromJSON Credentials where + parseJSON (A.Object v) = Credentials + <$> v .: "app-id" + <*> (encodeUtf8 <$> v .: "app-key") + <*> (encodeUtf8 <$> v .: "app-secret") + parseJSON v2 = failExpectObj v2 + +-- |Use this to get an instance Pusher. This will fill in the host and path +-- automatically. +getPusher :: MonadIO m => Credentials -> m Pusher +getPusher cred = do + connManager <- liftIO $ newManager defaultManagerSettings + return $ getPusherWithConnManager connManager cred + +getPusherWithConnManager :: Manager -> Credentials -> Pusher +getPusherWithConnManager connManager cred = + let path = "/apps/" <> T.pack (show $ credentialsAppID cred) <> "/" in + Pusher + { pusherHost = "http://api.pusherapp.com" + , pusherPath = path + , pusherCredentials = cred + , pusherConnectionManager = connManager + } diff --git a/src/Network/Pusher.hs b/src/Network/Pusher.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pusher.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +{-| +Module : Network.Pusher +Description : Haskell interface to the Pusher HTTP API +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +Exposes the functions necessary for interacting with the Pusher HTTP API, as +well as functions for generating auth signatures for private and presence +channels. + +The idea is that you must create a Pusher data structure with your credentials, +then your write your block of code that calls functions from this library, and +finally "run" this code with the Pusher data structure you created. + +The types of the functions are general enough to allow you to use the provided +PusherM as the return type, or PusherT if you wish to use other monads in your +applications monad transformer stack. + +The functions return a MonadError type which means any can fail, and you must +handle these failures in your client application. In the simplist case you can +instantiate the type to an Either and case split on it. + +An example of how you would use these functions: + +@ + let + pusher = getPusher $ Credentials + { credentials'appID = 123 + , credentials'appKey = wrd12344rcd234 + , credentials'appSecret = 124df34d545v + } + result <- runPusherT (Pusher.trigger ["my-channel"] "my-event" "my-data") pusher + case result of + Right resp -> print resp + Left e -> error e +@ + +There is a simple working example in the example/ directory. + +See https://pusher.com/docs/rest_api for more detail on the HTTP requests. +-} +module Network.Pusher ( + -- * Events + trigger + -- * Channel queries + , channels + , channel + , users + -- * Authentication + , authenticatePresence + , authenticatePrivate + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Control.Monad.Error (throwError) +import Control.Monad.Reader (MonadReader, asks) +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 qualified Data.Text as T + +import Control.Monad.Pusher (MonadPusher) +import Control.Monad.Pusher.Time (MonadTime, getPOSIXTime) +import Data.Pusher (Credentials(..), Pusher(..)) +import Network.Pusher.Internal.Auth + ( authenticatePresence + , authenticatePrivate + , makeQS + ) +import Network.Pusher.Internal.HTTP (get, post) +import Network.Pusher.Internal.Util (show') +import Network.Pusher.Protocol + ( Channel + , ChannelInfo + , ChannelInfoQuery + , ChannelsInfo + , ChannelsInfoQuery + , ChannelType + , FullChannelInfo + , Users + , toURLParam + ) + +-- |Trigger an event to one or more channels. +trigger + :: MonadPusher m + => [Channel] -- ^The list of channels to trigger to + -> T.Text -- ^The event + -> T.Text -- ^The data to send (often encoded JSON) + -> Maybe T.Text -- ^An optional socket ID of a connection you wish to exclude + -> m () +trigger chans event dat socketId = do + when + (length chans > 10) + (throwError "Must be less than 10 channels") + + let + body = A.object $ + [ ("name", A.String event) + , ("channels", A.toJSON (map (A.String . show') chans)) + , ("data", A.String dat) + ] ++ maybeToList (fmap (\sID -> ("socket_id", A.String sID)) socketId) + bodyBS = BL.toStrict $ A.encode body + when + (B.length bodyBS > 10000) + (throwError "Body must be less than 10000KB") + + (ep, path) <- getEndpoint "events" + qs <- makeQSWithTS "POST" path [] bodyBS + connManager <- asks pusherConnectionManager + post connManager (encodeUtf8 ep) qs body + +-- |Query a list of channels for information. +channels + :: MonadPusher m + => Maybe ChannelType -- ^Filter by the type of channel + -> T.Text -- ^A channel prefix you wish to filter on + -> ChannelsInfoQuery -- ^Data you wish to query for, currently just the user count + -> m ChannelsInfo -- ^The returned data +channels channelTypeFilter prefixFilter attributes = do + let + prefix = maybe "" show' channelTypeFilter <> prefixFilter + params = + [ ("info", encodeUtf8 $ toURLParam attributes) + , ("filter_by_prefix", encodeUtf8 prefix) + ] + (ep, path) <- getEndpoint "channels" + qs <- makeQSWithTS "GET" path params "" + connManager <- asks pusherConnectionManager + get connManager (encodeUtf8 ep) qs + +-- |Query for information on a single channel. +channel + :: MonadPusher m + => Channel + -> ChannelInfoQuery -- ^Can query user count and also subscription count (if enabled) + -> m FullChannelInfo +channel chan attributes = do + let params = [("info", encodeUtf8 $ toURLParam attributes)] + (ep, path) <- getEndpoint $ "channels/" <> show' chan + qs <- makeQSWithTS "GET" path params "" + connManager <- asks pusherConnectionManager + get connManager (encodeUtf8 ep) qs + +-- |Get a list of users in a presence channel. +users + :: MonadPusher m + => Channel + -> m Users +users chan = do + (ep, path) <- getEndpoint $ "channels/" <> show' chan <> "/users" + qs <- makeQSWithTS "GET" path [] "" + connManager <- asks pusherConnectionManager + get connManager (encodeUtf8 ep) qs + +-- |Build a full endpoint from the details in Pusher and the subPath. +getEndpoint + :: (MonadReader Pusher m) + => T.Text -- ^The subpath of the specific request, e.g "events/channel-name" + -> m (T.Text, T.Text) -- ^The full endpoint, and just the path component +getEndpoint subPath = do + host <- asks pusherHost + path <- asks pusherPath + let + fullPath = path <> subPath + endpoint = host <> fullPath + return (endpoint, fullPath) + +-- |Impure wrapper around makeQS which gets the current time implicitly. +makeQSWithTS + :: (Functor m, MonadTime m, MonadReader Pusher m) + => T.Text + -> T.Text + -> [(B.ByteString, B.ByteString)] + -> B.ByteString + -> m [(B.ByteString, B.ByteString)] +makeQSWithTS method path params body = do + appKey <- asks $ credentialsAppKey . pusherCredentials + appSecret <- asks $ credentialsAppSecret . pusherCredentials + makeQS appKey appSecret method path params body <$> getPOSIXTime diff --git a/src/Network/Pusher/Internal/Auth.hs b/src/Network/Pusher/Internal/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pusher/Internal/Auth.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleContexts #-} + +{-| +Module : Network.Pusher.Internal.Auth +Description : Functions to perform authentication (generate auth signatures) +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +This module contains helper functions for authenticating HTTP requests, as well +as publically facing functions for authentication private and presence channel +users; these functions are re-exported in the main Pusher module. +-} +module Network.Pusher.Internal.Auth + ( authenticatePresence + , authenticatePresenceWithEncoder + , authenticatePrivate, makeQS + ) where + +import Data.Monoid ((<>)) +import Data.Text.Encoding (encodeUtf8) +import GHC.Exts (sortWith) +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.MAC.HMAC as HMAC + +import Data.Pusher (Credentials(..)) + +-- |Generate the required query string parameters required to send API requests +-- to Pusher. +makeQS + :: B.ByteString + -> B.ByteString + -> T.Text + -> T.Text + -> [(B.ByteString, B.ByteString)] -- ^Any additional parameters + -> B.ByteString + -> Int -- ^Current UNIX timestamp + -> [(B.ByteString, B.ByteString)] +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", BC.pack $ 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 + -- Add the auth string to the list + ("auth_signature", authSig) : allParams + +-- |Render key-value tuple mapping of query string parameters into a string. +formQueryString :: [(B.ByteString, B.ByteString)] -> B.ByteString +formQueryString = + B.intercalate "&" . map (\(a, b) -> a <> "=" <> b) + +-- |Create a Pusher auth signature of a string using the provided credentials. +authSignature :: B.ByteString -> B.ByteString -> B.ByteString +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 -> B.ByteString -> B.ByteString -> B.ByteString +authenticatePrivate cred socketID channelName = + let + sig = authSignature + (credentialsAppSecret cred) + (socketID <> ":" <> channelName) + 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 -> B.ByteString -> B.ByteString -> a -> B.ByteString +authenticatePresence = + authenticatePresenceWithEncoder (BL.toStrict . A.encode) + +-- |As above, but allows the encoder of the user data to be specified. This is +-- useful for testing because the encoder can be mocked; aeson's encoder enodes +-- JSON object fields in arbitrary orders, which makes it impossible to test. +authenticatePresenceWithEncoder + :: A.ToJSON a + => (a -> B.ByteString) -- ^The encoder of the user data. + -> Credentials + -> B.ByteString + -> B.ByteString + -> a + -> B.ByteString +authenticatePresenceWithEncoder userEncoder cred socketID channelName userData = + let + sig = authSignature (credentialsAppSecret cred) + ( socketID <> ":" + <> channelName <> ":" + <> userEncoder userData + ) + in + credentialsAppKey cred <> ":" <> sig + diff --git a/src/Network/Pusher/Internal/HTTP.hs b/src/Network/Pusher/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pusher/Internal/HTTP.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : Network.Pusher.Internal.HTTP +Description : Functions for issuing HTTP requests +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +A layer on top of the HTTP functions in the Wreq library which lifts the return +values to the typclasses we are using in this library. Non 200 responses are +converted into MonadError errors. +-} +module Network.Pusher.Internal.HTTP (MonadHTTP(..), get, post) where + +import Control.Arrow (second) +import Control.Monad.Error (MonadError, throwError) +import Network.HTTP.Client + ( Manager + , RequestBody(RequestBodyLBS) + , Response + , method + , parseUrl + , requestBody + , requestHeaders + , responseBody + , responseStatus + , setQueryString + ) +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.Char8 as BC +import qualified Data.ByteString.Lazy as BL + +import Control.Monad.Pusher.HTTP (MonadHTTP(httpLbs)) + +import Debug.Trace + +-- |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, Functor m, MonadError String m, MonadHTTP m) + => Manager + -> B.ByteString + -- ^The API endpoint, for example http://api.pusherapp.com/apps/123/events + -> [(B.ByteString, B.ByteString)] + -- ^List of query string parameters as key-value tuples + -> m a + -- ^The body of the response +get connManager ep qs = do + resp <- makeRequest connManager ep qs Nothing + when200 resp $ + either + throwError + return + (A.eitherDecode $ responseBody resp) + +-- |Issue an HTTP POST request. +post + :: (A.ToJSON a, Functor m, MonadError String m, MonadHTTP m) + => Manager + -> B.ByteString + -> [(B.ByteString, B.ByteString)] + -> a + -> m () +post connManager ep qs body = do + resp <- makeRequest connManager ep qs (Just $ A.encode body) + errorOn200 resp + +-- |Make a request by building up an http-client Request data structure, and +-- performing the IO action. +makeRequest + :: (Functor m, MonadError String m, MonadHTTP m) + => Manager + -> B.ByteString + -> [(B.ByteString, B.ByteString)] + -> Maybe BL.ByteString + -> m (Response BL.ByteString) +makeRequest connManager ep qs body = do + req <- either (throwError . show) return (parseUrl $ BC.unpack ep) + let + req' = setQueryString (map (second Just) qs) req + req'' = case body of + Just b -> req' + { method = methodPost + , requestHeaders = [(hContentType, "application/json")] + , requestBody = RequestBodyLBS b + } + Nothing -> req' + httpLbs req'' connManager + +when200 :: (MonadError String m) => Response BL.ByteString -> m a -> m a +when200 response run = + let status = responseStatus response in + if statusCode status == 200 then + run + else + throwError $ show $ statusMessage status + +errorOn200 :: (MonadError String m) => Response BL.ByteString -> m () +errorOn200 response = when200 response (return ()) diff --git a/src/Network/Pusher/Internal/Util.hs b/src/Network/Pusher/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/Pusher/Internal/Util.hs @@ -0,0 +1,26 @@ +{-| +Module : Network.Pusher.Internal.Util +Description : Various utilty functions +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental +-} +module Network.Pusher.Internal.Util + ( failExpectObj + , show' + ) where + +import Control.Applicative ((<$>)) +import Data.String (IsString, fromString) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A + +-- |When decoding Aeson values, this can be used to return a failing parser +-- when an object was expected, but it was a different type of data. +failExpectObj :: A.Value -> A.Parser a +failExpectObj = fail . ("Expected JSON object, got " ++) . show + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Network/Pusher/Protocol.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} + +{-| +Module : Network.Pusher.Protocol +Description : Types representing Pusher messages +Copyright : (c) Will Sewell, 2015 +Licence : MIT +Maintainer : me@willsewell.com +Stability : experimental + +Types representing the JSON format of Pusher messages. + +There are also types for query string parameters. +-} +module Network.Pusher.Protocol + ( Channel(..) + , ChannelInfo(..) + , ChannelInfoAttributes(..) + , ChannelInfoAttributeResp(..) + , ChannelInfoQuery(..) + , ChannelsInfo(..) + , ChannelsInfoQuery(..) + , ChannelsInfoAttributes(..) + , ChannelType(..) + , FullChannelInfo + , User(..) + , Users(..) + , parseChannel + , toURLParam + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson ((.:), (.:?)) +import Data.Foldable (asum) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary, arbitrary, elements) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Text as T + +import Network.Pusher.Internal.Util (failExpectObj, show') + +-- |The possible types of Pusher channe. +data ChannelType = Public | Private | Presence deriving (Eq, Generic) + +instance Hashable ChannelType + +instance Show ChannelType where + show Public = "" + show Private = "private-" + show Presence = "presence-" + +instance Arbitrary ChannelType where + arbitrary = elements [Public, Private, Presence] + +-- |The channel name (not including the channel type prefix) and its type. +data Channel = Channel + { channelType :: ChannelType + , channelName :: T.Text + } deriving (Eq, Generic) + +instance Hashable Channel + +instance Show Channel where + show (Channel chanType name) = show chanType ++ T.unpack name + +instance Arbitrary Channel where + arbitrary = Channel <$> arbitrary <*> (T.pack <$> arbitrary) + +-- |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 + fromMaybe + (Channel Public chan) + (asum [parseChanAs Private, parseChanAs Presence]) + where + parseChanAs chanType = + let split = T.splitOn (show' chanType) chan in + -- 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 + +-- |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) + +instance ToURLParam ChannelsInfoAttributes where + toURLParam ChannelsUserCount = "user_count" + +instance Hashable ChannelsInfoAttributes + +-- |A set of requested ChannelsInfoAttributes. +newtype ChannelsInfoQuery = + ChannelsInfoQuery (HS.HashSet ChannelsInfoAttributes) + deriving ToURLParam + +-- |Enumeration of the attributes that can be queried about a single channel. +data ChannelInfoAttributes = ChannelUserCount | ChannelSubscriptionCount + deriving (Eq, Generic) + +instance ToURLParam ChannelInfoAttributes where + toURLParam ChannelUserCount = "user_count" + toURLParam ChannelSubscriptionCount = "subscription_count" + +instance Hashable ChannelInfoAttributes + +-- |A set of requested ChannelInfoAttributes. +newtype ChannelInfoQuery = ChannelInfoQuery (HS.HashSet ChannelInfoAttributes) + deriving ToURLParam + + +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 +-- info from multuple channels. +newtype ChannelsInfo = + ChannelsInfo (HM.HashMap Channel ChannelInfo) + deriving (Eq, Show) + +instance A.FromJSON ChannelsInfo where + parseJSON (A.Object v) = do + chansV <- v .: "channels" + case chansV of + 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) + v1 -> failExpectObj v1 + parseJSON v2 = failExpectObj v2 + +-- |A set of returned channel attributes for a single channel. +newtype ChannelInfo = + ChannelInfo (HS.HashSet ChannelInfoAttributeResp) + deriving (Eq, Show) + +instance A.FromJSON ChannelInfo where + parseJSON (A.Object v) = do + maybeUserCount <- v .:? "user_count" + return $ ChannelInfo $ maybe + HS.empty + (HS.singleton . UserCountResp) + maybeUserCount + parseJSON v = failExpectObj v + +-- |An enumeration of possible returned channel attributes when multiple +-- when multiple channels are queried. +data ChannelInfoAttributeResp = UserCountResp Int deriving (Eq, Generic, Show) + +instance Hashable ChannelInfoAttributeResp + +-- |A set of returned channel attributes for a single channel. +newtype FullChannelInfo = + FullChannelInfo (HS.HashSet FullChannelAttributeResp) + deriving (Eq, Show) + +instance A.FromJSON FullChannelInfo where + parseJSON (A.Object v) = do + occupied <- v .: "occupied" + maybeUserCount <- v .:? "user_count" + maybeSubCount <- v .:? "subscription_count" + let + hs = HS.singleton (OccupiedResp occupied) + hs' = maybeInsert (FullUserCountResp <$> maybeUserCount) hs + hs'' = maybeInsert (SubscriptionCountResp <$> maybeSubCount) hs' + return $ FullChannelInfo hs'' + where + maybeInsert :: (Eq a, Hashable a) => Maybe a -> HS.HashSet a -> HS.HashSet a + maybeInsert maybeVal hs = maybe hs (`HS.insert` hs) maybeVal + + parseJSON v = failExpectObj v + +-- |An enumeration of possible returned channel attributes when a single +-- channel is queried +data FullChannelAttributeResp + = OccupiedResp Bool + | FullUserCountResp Int + | SubscriptionCountResp Int + deriving (Eq, Generic, Show) + +instance Hashable FullChannelAttributeResp + +-- |A list of users returned by querying for users in a presence channel. +newtype Users = Users [User] deriving (Eq, Show) + +instance A.FromJSON Users where + parseJSON (A.Object v) = do + users <- v .: "users" + 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) + +instance A.FromJSON User where + parseJSON (A.Object v) = User <$> v .: "id" + parseJSON v = failExpectObj v diff --git a/test/Auth.hs b/test/Auth.hs new file mode 100644 --- /dev/null +++ b/test/Auth.hs @@ -0,0 +1,55 @@ +module Auth where + +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Pusher (Credentials(..)) +import Network.Pusher.Internal.Auth + ( authenticatePrivate + , authenticatePresenceWithEncoder + , 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") + ] + + describe "Auth.authenticatePrivate" $ + it "works" $ + -- Data from https://pusher.com/docs/auth_signatures#worked-example + authenticatePrivate credentials "1234.1234" "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" + "presence-foobar" + ("doesn't matter" :: String) + `shouldBe` "278d425bdf160c739803:afaed3695da2ffd16931f457e338e6c9f2921fa133ce7dac49f529792be6304c" + +credentials :: Credentials +credentials = Credentials + { credentialsAppID = 3 + , credentialsAppKey = "278d425bdf160c739803" + , credentialsAppSecret = "7ad3773142a6692b25b8" + } + diff --git a/test/HTTP.hs b/test/HTTP.hs new file mode 100644 --- /dev/null +++ b/test/HTTP.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module HTTP where + +import Control.Applicative (Applicative) +import Control.Monad.Error (MonadError, catchError, throwError) +import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Test.Hspec (Spec, describe, it, shouldBe) +import Network.HTTP.Client + ( Manager + , createCookieJar + , defaultManagerSettings + , newManager + ) +import Network.HTTP.Client.Internal (Response(..), ResponseClose(..)) +import Network.HTTP.Types.Status (mkStatus) +import Network.HTTP.Types.Version (http11) +import qualified Control.Monad.Trans.Reader as Reader +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM + +import Network.Pusher.Internal.HTTP + ( MonadHTTP(httpLbs) + , get + , post + ) + +-- Need to use newtype, otherwise there would be overlapping instances with the +-- existing ReaderT insatnce of MonadHTTP +-- Unfortunately most of boilerplate lines below are require because of this +-- newtype instance +newtype MockServer m a = MockServer + { server :: ReaderT (Response BL.ByteString) m a } + deriving (Applicative, Functor, Monad, MonadTrans) + +runMockServer :: MockServer m a -> Response BL.ByteString -> m a +runMockServer (MockServer s) = runReaderT s + +deriving instance Monad m => MonadReader (Response BL.ByteString) (MockServer m) + +liftCatchMockerServer + :: (m a -> (e -> m a) -> m a) + -> MockServer m a + -> (e -> MockServer m a) + -> MockServer m a +liftCatchMockerServer catcher run handler = + MockServer $ Reader.liftCatch catcher (server run) (server . handler) + +instance (MonadError e m) => MonadError e (MockServer m) where + throwError = lift . throwError + catchError = liftCatchMockerServer catchError + +instance Monad m => MonadHTTP (MockServer m) where + httpLbs _ _ = ask + +succeededResponse :: Response BL.ByteString +succeededResponse = Response + { responseStatus = mkStatus 200 "succeess" + , responseVersion = http11 + , responseHeaders = [] + , responseBody = "{\"data\":\"some body\"}" + , responseCookieJar = createCookieJar [] + , responseClose' = ResponseClose (return () :: IO ()) + } + +failedResponse :: Response BL.ByteString +failedResponse = Response + { responseStatus = mkStatus 404 "fail" + , responseVersion = http11 + , responseHeaders = [] + , responseBody = "" + , responseCookieJar = createCookieJar [] + , responseClose' = ResponseClose (return () :: IO ()) + } + +-- |Create a connection manager. This will be ignored by the mock server, but we +-- need it in order to type check. +withConnManager :: (Manager -> IO a) -> IO a +withConnManager run = newManager defaultManagerSettings >>= run + +test :: Spec +test = do + describe "HTTP.get" $ do + it "returns the body when the request is 200" $ withConnManager $ \mngr -> + runMockServer + (get mngr "http://example.com/path" []) + succeededResponse + `shouldBe` (Right $ A.Object $ HM.singleton "data" (A.String "some body")) + + it "returns an error when the request fails" $ withConnManager $ \mngr -> + (runMockServer + (get mngr "http://example.com/path" []) + failedResponse + :: Either String ()) + `shouldBe` Left "\"fail\"" + + describe "HTTP.post" $ do + it "returns the body when the request is 200" $ withConnManager $ \mngr -> + -- TODO: Need a way of checking the POST data that is sent to the server + runMockServer + (post mngr "http://example.com/path" [] (A.Object HM.empty)) + succeededResponse + `shouldBe` Right () + + it "returns an error when the request fails" $ withConnManager $ \mngr -> + (runMockServer + (post mngr "http://example.com/path" [] (A.Object HM.empty)) + failedResponse + :: Either String ()) + `shouldBe` Left "\"fail\"" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Hspec (hspec) + +import qualified Auth +import qualified HTTP +import qualified Protocol + +main :: IO () +main = hspec $ Auth.test >> HTTP.test >> Protocol.test diff --git a/test/Protocol.hs b/test/Protocol.hs new file mode 100644 --- /dev/null +++ b/test/Protocol.hs @@ -0,0 +1,76 @@ +module Protocol where + +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (property) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Text as T + +import Network.Pusher.Protocol + ( Channel(..) + , ChannelInfo(..) + , ChannelInfoAttributeResp(UserCountResp) + , ChannelsInfo(..) + , ChannelType(Public, Presence, Private) + , User(..) + , Users(..) + , parseChannel + ) + +test :: Spec +test = do + describe "Protocol.Channel" $ do + it "show instance works for public channels" $ + show (Channel Public "test") `shouldBe` "test" + + it "show instance works for private channels" $ + show (Channel Private "test") `shouldBe` "private-test" + + it "show instance is an inverse of parseChannel" $ + property $ \chan -> parseChannel (T.pack $ show chan) == chan + + describe "Protocol.ChannelsInfo" $ + it "parsing works" $ + -- Data from https://pusher.com/docs/rest_api#successful-response-1 + A.decode + "{\ +\ \"channels\": {\ +\ \"presence-foobar\": {\ +\ \"user_count\": 42\ +\ },\ +\ \"presence-another\": {\ +\ \"user_count\": 123\ +\ }\ +\ }\ +\ }" + `shouldBe` + (Just $ ChannelsInfo $ HM.fromList + [ (Channel Presence "foobar", ChannelInfo $ HS.fromList [UserCountResp 42]) + , (Channel Presence "another", ChannelInfo $ HS.fromList [UserCountResp 123]) + ]) + + describe "Protocol.ChannelInfo" $ + it "parsing works" $ + -- Data from https://pusher.com/docs/rest_api#successful-response-2 + A.decode + "{\ +\ \"occupied\": true,\ +\ \"user_count\": 42,\ +\ \"subscription_count\": 42\ +\ }" + `shouldBe` + -- TODO: Currently incomplete due to ChannelInfo being incomplete + (Just $ ChannelInfo $ HS.fromList [UserCountResp 42]) + + describe "Protocol.Users" $ + it "parsing works" $ + A.decode + "{\ +\ \"users\": [\ +\ { \"id\": \"1\" },\ +\ { \"id\": \"2\" }\ +\ ]\ +\ }" + `shouldBe` + (Just $ Users [User "1", User "2"])