packages feed

pusher-http-haskell (empty) → 0.1.0.0

raw patch · 18 files changed

+1280/−0 lines, 18 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, base16-bytestring, bytestring, containers, cryptohash, hashable, hspec, http-client, http-types, mtl, pusher-http-haskell, snap-core, snap-server, text, time, transformers, unordered-containers, yaml

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/api/Main.hs view
@@ -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)
+ example/auth/Main.hs view
@@ -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) <> ");"
+ pusher-http-haskell.cabal view
@@ -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
+ src/Control/Monad/Pusher.hs view
@@ -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+  )
+ src/Control/Monad/Pusher/HTTP.hs view
@@ -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
+ src/Control/Monad/Pusher/Time.hs view
@@ -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
+ src/Data/Pusher.hs view
@@ -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+    }
+ src/Network/Pusher.hs view
@@ -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
+ src/Network/Pusher/Internal/Auth.hs view
@@ -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+
+ src/Network/Pusher/Internal/HTTP.hs view
@@ -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 ())
+ src/Network/Pusher/Internal/Util.hs view
@@ -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
+ src/Network/Pusher/Protocol.hs view
@@ -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
+ test/Auth.hs view
@@ -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"+  }+
+ test/HTTP.hs view
@@ -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\""
+ test/Main.hs view
@@ -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
+ test/Protocol.hs view
@@ -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"])