pusher-http-haskell 0.3.0.2 → 1.0.0.0
raw patch · 19 files changed
+419/−589 lines, 19 filesdep −containersdep −mtldep −snap-coredep ~aesondep ~basedep ~bytestring
Dependencies removed: containers, mtl, snap-core, snap-server, yaml
Dependency ranges changed: aeson, base, bytestring, text, transformers, unordered-containers
Files
- LICENSE +1/−1
- example/api/Main.hs +0/−38
- example/auth/Main.hs +0/−42
- pusher-http-haskell.cabal +7/−41
- src/Control/Monad/Pusher.hs +0/−47
- src/Control/Monad/Pusher/HTTP.hs +0/−33
- src/Control/Monad/Pusher/Time.hs +0/−30
- src/Data/Pusher.hs +0/−81
- src/Network/Pusher.hs +84/−97
- src/Network/Pusher/Data.hs +81/−0
- src/Network/Pusher/Error.hs +15/−0
- src/Network/Pusher/Internal.hs +166/−0
- src/Network/Pusher/Internal/Auth.hs +2/−2
- src/Network/Pusher/Internal/HTTP.hs +53/−54
- src/Network/Pusher/Internal/Util.hs +7/−1
- src/Network/Pusher/Protocol.hs +1/−1
- test/Auth.hs +1/−2
- test/HTTP.hs +0/−117
- test/Main.hs +1/−2
LICENSE view
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2015 Will Sewell+Copyright (c) 2016 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
− example/api/Main.hs
@@ -1,38 +0,0 @@-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
@@ -1,42 +0,0 @@-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
@@ -1,10 +1,10 @@ name: pusher-http-haskell-version: 0.3.0.2+version: 1.0.0.0 cabal-version: >=1.18 build-type: Simple license: MIT license-file: LICENSE-copyright: (c) Will Sewell, 2015+copyright: (c) Will Sewell, 2016 author: Will Sewell maintainer: me@willsewell.com stability: experimental@@ -19,15 +19,14 @@ tested-with: GHC == 7.10.3 library- exposed-modules: Control.Monad.Pusher,- Control.Monad.Pusher.HTTP,- Control.Monad.Pusher.Time,- Data.Pusher,- Network.Pusher,+ exposed-modules: Network.Pusher,+ Network.Pusher.Internal, Network.Pusher.Internal.Auth, Network.Pusher.Internal.HTTP, Network.Pusher.Protocol- other-modules: Network.Pusher.Internal.Util+ other-modules: Network.Pusher.Data,+ Network.Pusher.Error,+ Network.Pusher.Internal.Util default-language: Haskell2010 hs-source-dirs: src default-extensions: OverloadedStrings@@ -39,50 +38,18 @@ hashable ==1.2.*, http-client ==0.4.*, http-types >=0.8 && <0.10,- mtl ==2.2.*, QuickCheck >=2.7 && <2.9, text ==1.2.*, time >=1.4 && <1.6, transformers >=0.3 && <0.5, 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,@@ -91,7 +58,6 @@ hspec, http-client, http-types,- mtl, pusher-http-haskell, QuickCheck, text,
− src/Control/Monad/Pusher.hs
@@ -1,47 +0,0 @@-{-# 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.Except (ExceptT, MonadError, runExceptT)-import Control.Monad.Identity (Identity)-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)-import qualified Data.Text as T--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 (ExceptT T.Text m) a---- |Run the monadic Pusher code to extract the result-runPusherT :: PusherT m a -> Pusher -> m (Either T.Text a)-runPusherT run p = runExceptT $ runReaderT run p---- |Typeclass alias for the return type of the API functions (keeps the--- signatures less verbose)-type MonadPusher m =- ( Functor m- , MonadError T.Text m- , MonadHTTP m- , MonadReader Pusher m- , MonadTime m- )
− src/Control/Monad/Pusher/HTTP.hs
@@ -1,33 +0,0 @@-{-|-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.Except (ExceptT)-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 MonadHTTP m => MonadHTTP (ExceptT e m) where- httpLbs req mngr = lift $ httpLbs req mngr
− src/Control/Monad/Pusher/Time.hs
@@ -1,30 +0,0 @@-{-|-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.Except (ExceptT)-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 MonadTime m => MonadTime (ExceptT e m) where- getPOSIXTime = lift getPOSIXTime
− src/Data/Pusher.hs
@@ -1,81 +0,0 @@-{-|-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- , getPusherWithHost- , getPusherWithConnManager- ) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson ((.:))-import Data.Maybe (fromMaybe)-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, show')---- |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 <- 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 apiHost cred = do- connManager <- getConnManager- return $ getPusherWithConnManager connManager (Just apiHost) cred---- |Get a Pusher instance with a given connection manager. This can be useful--- if you want to share a connection with your application code.-getPusherWithConnManager :: Manager -> Maybe T.Text -> 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- }--getConnManager :: MonadIO m => m Manager-getConnManager = liftIO $ newManager defaultManagerSettings
src/Network/Pusher.hs view
@@ -4,7 +4,7 @@ {-| Module : Network.Pusher Description : Haskell interface to the Pusher HTTP API-Copyright : (c) Will Sewell, 2015+Copyright : (c) Will Sewell, 2016 Licence : MIT Maintainer : me@willsewell.com Stability : experimental@@ -35,10 +35,11 @@ , credentialsAppSecret = 124df34d545v } pusher <- getPusher credentials- result <- runPusherT (trigger [Channel Public "my-channel"] "my-event" "my-data" Nothing) pusher+ result <-+ trigger pusher [Channel Public "my-channel"] "my-event" "my-data" Nothing case result of- Right resp -> print resp Left e -> error e+ Right resp -> print resp @ There is a simple working example in the example/ directory.@@ -46,8 +47,14 @@ See https://pusher.com/docs/rest_api for more detail on the HTTP requests. -} module Network.Pusher (+ -- * The Pusher config type+ Pusher(..)+ , Credentials(..)+ , getPusher+ , getPusherWithHost+ , getPusherWithConnManager -- * Events- trigger+ , trigger -- * Channel queries , channels , channel@@ -55,32 +62,39 @@ -- * Authentication , authenticatePresence , authenticatePrivate+ -- * Errors+ , PusherError(..) ) where import Control.Applicative ((<$>)) import Control.Monad (when)-import Control.Monad.Except (throwError)-import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT, throwE)+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Maybe (maybeToList) import Data.Monoid ((<>)) import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Client (Manager) 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.Data+ ( Pusher(..)+ , Credentials(..)+ , getPusher+ , getPusherWithHost+ , getPusherWithConnManager+ )+import Network.Pusher.Error(PusherError(..)) import Network.Pusher.Internal.Auth ( authenticatePresence , authenticatePrivate , makeQS )-import Network.Pusher.Internal.HTTP (get, post)+import Network.Pusher.Internal.Util (getTime) import Network.Pusher.Protocol ( Channel- , ChannelInfo , ChannelInfoQuery , ChannelsInfo , ChannelsInfoQuery@@ -91,101 +105,74 @@ , renderChannelPrefix , toURLParam )+import qualified Network.Pusher.Internal as Pusher+import qualified Network.Pusher.Internal.HTTP as HTTP -- |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 . renderChannel) 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+ :: MonadIO m+ => Pusher+ -> [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 (Either PusherError ())+trigger pusher chans event dat socketId =+ liftIO $ runExceptT $ do+ (requestParams, requestBody) <-+ ExceptT $+ Pusher.mkTriggerRequest pusher chans event dat socketId <$> getTime+ HTTP.post (pusherConnectionManager pusher) requestParams requestBody -- |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 "" renderChannelPrefix 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+ :: MonadIO m+ => Pusher+ -> 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 (Either PusherError ChannelsInfo)+ -- ^The returned data+channels pusher channelTypeFilter prefixFilter attributes =+ liftIO $ runExceptT $ do+ requestParams <-+ liftIO $+ Pusher.mkChannelsRequest+ pusher+ channelTypeFilter+ prefixFilter+ attributes <$>+ getTime+ HTTP.get (pusherConnectionManager pusher) requestParams -- |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/" <> renderChannel chan- qs <- makeQSWithTS "GET" path params ""- connManager <- asks pusherConnectionManager- get connManager (encodeUtf8 ep) qs+ :: MonadIO m+ => Pusher+ -> Channel+ -> ChannelInfoQuery+ -- ^Can query user count and also subscription count (if enabled)+ -> m (Either PusherError FullChannelInfo)+channel pusher chan attributes =+ liftIO $ runExceptT $ do+ requestParams <-+ liftIO $ Pusher.mkChannelRequest pusher chan attributes <$> getTime+ HTTP.get (pusherConnectionManager pusher) requestParams -- |Get a list of users in a presence channel. users- :: MonadPusher m- => Channel- -> m Users-users chan = do- (ep, path) <- getEndpoint $ "channels/" <> renderChannel 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+ :: MonadIO m+ => Pusher+ -> Channel+ -> m (Either PusherError Users)+users pusher chan =+ liftIO $ runExceptT $ do+ requestParams <- liftIO $ Pusher.mkUsersRequest pusher chan <$> getTime+ HTTP.get (pusherConnectionManager pusher) requestParams
+ src/Network/Pusher/Data.hs view
@@ -0,0 +1,81 @@+{-|+Module : Network.Pusher.Data+Description : Data structure to store Pusher config+Copyright : (c) Will Sewell, 2016+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 Network.Pusher.Data+ ( Pusher(..)+ , Credentials(..)+ , getPusher+ , getPusherWithHost+ , getPusherWithConnManager+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Aeson ((.:))+import Data.Maybe (fromMaybe)+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, show')++-- |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 <- 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 apiHost cred = do+ connManager <- getConnManager+ return $ getPusherWithConnManager connManager (Just apiHost) cred++-- |Get a Pusher instance with a given connection manager. This can be useful+-- if you want to share a connection with your application code.+getPusherWithConnManager :: Manager -> Maybe T.Text -> 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+ }++getConnManager :: MonadIO m => m Manager+getConnManager = liftIO $ newManager defaultManagerSettings
+ src/Network/Pusher/Error.hs view
@@ -0,0 +1,15 @@+module Network.Pusher.Error (PusherError(..)) where++import Control.Exception (Exception)+import qualified Data.Text as T++data PusherError+ -- |Data from the caller is not valid.+ = PusherArgumentError T.Text+ -- |Received non 200 response code from Pusher.+ | PusherNon200ResponseError T.Text+ -- |Received unexpected data from Pusher.+ | PusherInvalidResponseError T.Text+ deriving Show++instance Exception PusherError
+ src/Network/Pusher/Internal.hs view
@@ -0,0 +1,166 @@+{-|+Module : Network.Pusher.Internal+Description : Pure functions called by the public interface+Copyright : (c) Will Sewell, 2016+Licence : MIT+Maintainer : me@willsewell.com+Stability : experimental+-}+module Network.Pusher.Internal+ ( PusherRequestParams(..)+ , PusherRequestBody+ , mkTriggerRequest+ , mkChannelsRequest+ , mkChannelRequest+ , mkUsersRequest+ ) 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 qualified Data.Text as T++import Network.Pusher.Data (Pusher(..), Credentials(..))+import Network.Pusher.Error(PusherError(..))+import Network.Pusher.Internal.Auth (makeQS)+import Network.Pusher.Protocol+ ( Channel+ , ChannelInfoQuery+ , ChannelsInfo+ , ChannelsInfoQuery+ , ChannelType+ , FullChannelInfo+ , Users+ , renderChannel+ , renderChannelPrefix+ , toURLParam+ )++data PusherRequestParams = PusherRequestParams+ { pusherRequestEndpoint :: T.Text+ -- ^The API endpoint, for example http://api.pusherapp.com/apps/123/events+ , pusherRequestQueryString :: [(B.ByteString, B.ByteString)]+ -- ^List of query string parameters as key-value tuples+ }++type PusherRequestBody = A.Value++mkTriggerRequest+ :: Pusher+ -> [Channel]+ -> T.Text+ -> T.Text+ -> Maybe T.Text+ -> Int+ -> Either PusherError (PusherRequestParams, PusherRequestBody)+mkTriggerRequest pusher chans event dat socketId time = do+ 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)+ 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)++mkChannelsRequest+ :: Pusher+ -> Maybe ChannelType+ -> T.Text+ -> ChannelsInfoQuery+ -> Int+ -> PusherRequestParams+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++mkChannelRequest+ :: Pusher+ -> Channel+ -> ChannelInfoQuery+ -> Int+ -> PusherRequestParams+mkChannelRequest pusher chan attributes time =+ let+ params = [("info", encodeUtf8 $ toURLParam attributes)]+ subPath = "channels/" <> renderChannel chan+ in+ mkGetRequest pusher subPath params time++mkUsersRequest :: Pusher -> Channel -> Int -> PusherRequestParams+mkUsersRequest pusher chan time =+ let+ subPath = "channels/" <> renderChannel chan <> "/users"+ in+ mkGetRequest pusher subPath [] time++mkGetRequest+ :: Pusher+ -> T.Text+ -> [(B.ByteString, B.ByteString)]+ -> Int+ -> PusherRequestParams+mkGetRequest pusher subPath params time =+ let+ (ep, fullPath) = mkEndpoint pusher subPath+ qs = mkQS pusher "GET" fullPath params "" time+ in+ PusherRequestParams ep qs++mkPostRequest+ :: Pusher+ -> T.Text+ -> [(B.ByteString, B.ByteString)]+ -> B.ByteString+ -> Int+ -> PusherRequestParams+mkPostRequest pusher subPath params bodyBS time =+ let+ (ep, fullPath) = mkEndpoint pusher subPath+ qs = mkQS pusher "POST" fullPath params bodyBS time+ in+ PusherRequestParams ep qs++-- |Build a full endpoint from the details in Pusher and the subPath.+mkEndpoint+ :: Pusher+ -> T.Text -- ^The subpath of the specific request, e.g "events/channel-name"+ -> (T.Text, T.Text) -- ^The full endpoint, and just the path component+mkEndpoint pusher subPath =+ let+ fullPath = pusherPath pusher <> subPath+ endpoint = pusherHost pusher <> fullPath+ in+ (endpoint, fullPath)++mkQS+ :: Pusher+ -> T.Text+ -> T.Text+ -> [(B.ByteString, B.ByteString)]+ -> B.ByteString+ -> Int+ -> [(B.ByteString, B.ByteString)]+mkQS pusher =+ let+ credentials = pusherCredentials pusher+ in+ makeQS+ (credentialsAppKey credentials)+ (credentialsAppSecret credentials)
src/Network/Pusher/Internal/Auth.hs view
@@ -3,7 +3,7 @@ {-| Module : Network.Pusher.Internal.Auth Description : Functions to perform authentication (generate auth signatures)-Copyright : (c) Will Sewell, 2015+Copyright : (c) Will Sewell, 2016 Licence : MIT Maintainer : me@willsewell.com Stability : experimental@@ -31,7 +31,7 @@ import qualified Crypto.Hash.SHA256 as SHA256 import qualified Crypto.MAC.HMAC as HMAC -import Data.Pusher (Credentials(..))+import Network.Pusher.Data (Credentials(..)) import Network.Pusher.Internal.Util (show') -- |Generate the required query string parameters required to send API requests
src/Network/Pusher/Internal/HTTP.hs view
@@ -4,7 +4,7 @@ {-| Module : Network.Pusher.Internal.HTTP Description : Functions for issuing HTTP requests-Copyright : (c) Will Sewell, 2015+Copyright : (c) Will Sewell, 2016 Licence : MIT Maintainer : me@willsewell.com Stability : experimental@@ -13,15 +13,20 @@ 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+module Network.Pusher.Internal.HTTP (get, post) where import Control.Arrow (second)-import Control.Monad.Except (MonadError, throwError)+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.Client ( Manager+ , Request , RequestBody(RequestBodyLBS) , Response+ , httpLbs , method , parseUrl , requestBody@@ -39,71 +44,65 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T -import Control.Monad.Pusher.HTTP (MonadHTTP(httpLbs))+import Network.Pusher.Error (PusherError(..))+import Network.Pusher.Internal (PusherRequestParams(PusherRequestParams)) import Network.Pusher.Internal.Util (show') -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 T.Text m, MonadHTTP m)+ :: A.FromJSON a => 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+ -> PusherRequestParams+ -> ExceptT PusherError IO a -- ^The body of the response-get connManager ep qs = do- resp <- makeRequest connManager ep qs Nothing- when200 resp $- either- (throwError . T.pack)- return- (A.eitherDecode $ responseBody resp)+get connManager (PusherRequestParams ep qs) = do+ req <- ExceptT $ return $ mkRequest ep qs+ resp <- doReqest connManager req+ either+ (throwE . PusherInvalidResponseError . T.pack)+ return+ (A.eitherDecode resp) -- |Issue an HTTP POST request. post- :: (A.ToJSON a, Functor m, MonadError T.Text m, MonadHTTP m)+ :: A.ToJSON a => Manager- -> B.ByteString- -> [(B.ByteString, B.ByteString)]+ -> PusherRequestParams -> a- -> m ()-post connManager ep qs body = do- resp <- makeRequest connManager ep qs (Just $ A.encode body)- errorOn200 resp+ -> ExceptT PusherError IO ()+post connManager (PusherRequestParams ep qs) body = do+ req <- ExceptT $ return $ mkPost (A.encode body) <$> mkRequest ep qs+ _ <- doReqest connManager req+ return () --- |Make a request by building up an http-client Request data structure, and--- performing the IO action.-makeRequest- :: (Functor m, MonadError T.Text m, MonadHTTP m)- => Manager- -> B.ByteString+mkRequest+ :: T.Text -> [(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+ -> Either PusherError Request+mkRequest ep qs =+ case parseUrl $ T.unpack ep of+ Nothing -> Left $ PusherArgumentError $ "failed to parse url: " <> ep+ Just req -> Right $ setQueryString (map (second Just) qs) req -when200 :: (MonadError T.Text m) => Response BL.ByteString -> m a -> m a-when200 response run =- let status = responseStatus response in+mkPost :: BL.ByteString -> Request -> Request+mkPost body req =+ req+ { method = methodPost+ , requestHeaders = [(hContentType, "application/json")]+ , requestBody = RequestBodyLBS body+ }++doReqest :: Manager -> Request -> ExceptT PusherError IO BL.ByteString+doReqest connManager req = do+ response <- liftIO $ httpLbs req connManager+ let status = responseStatus response if statusCode status == 200 then- run+ return $ responseBody response else- throwError $ either show' id $ decodeUtf8' $ statusMessage status--errorOn200 :: (MonadError T.Text m) => Response BL.ByteString -> m ()-errorOn200 response = when200 response (return ())+ let decoded = decodeUtf8' $ statusMessage status in+ throwE $+ either+ (PusherInvalidResponseError . T.pack . displayException)+ PusherNon200ResponseError+ decoded
src/Network/Pusher/Internal/Util.hs view
@@ -1,20 +1,26 @@ {-| Module : Network.Pusher.Internal.Util Description : Various utilty functions-Copyright : (c) Will Sewell, 2015+Copyright : (c) Will Sewell, 2016 Licence : MIT Maintainer : me@willsewell.com Stability : experimental -} module Network.Pusher.Internal.Util ( failExpectObj+ , getTime , show' ) where import Control.Applicative ((<$>)) import Data.String (IsString, fromString)+import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A++-- |Get the system time as an Int.+getTime :: IO Int+getTime = round <$> getPOSIXTime -- |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.
src/Network/Pusher/Protocol.hs view
@@ -5,7 +5,7 @@ {-| Module : Network.Pusher.Protocol Description : Types representing Pusher messages-Copyright : (c) Will Sewell, 2015+Copyright : (c) Will Sewell, 2016 Licence : MIT Maintainer : me@willsewell.com Stability : experimental
test/Auth.hs view
@@ -2,7 +2,7 @@ import Test.Hspec (Spec, describe, it, shouldBe) -import Data.Pusher (Credentials(..))+import Network.Pusher (Credentials(..)) import Network.Pusher.Internal.Auth ( authenticatePrivate , authenticatePresenceWithEncoder@@ -52,4 +52,3 @@ , credentialsAppKey = "278d425bdf160c739803" , credentialsAppSecret = "7ad3773142a6692b25b8" }-
− test/HTTP.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--module HTTP where--import Control.Applicative (Applicative)-import Control.Monad.Except (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 qualified Data.Text as T--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 T.Text ())- `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 T.Text ())- `shouldBe` Left "fail"
test/Main.hs view
@@ -3,8 +3,7 @@ import Test.Hspec (hspec) import qualified Auth-import qualified HTTP import qualified Protocol main :: IO ()-main = hspec $ Auth.test >> HTTP.test >> Protocol.test+main = hspec $ Auth.test >> Protocol.test