diff --git a/pusher-http-haskell.cabal b/pusher-http-haskell.cabal --- a/pusher-http-haskell.cabal +++ b/pusher-http-haskell.cabal @@ -1,5 +1,5 @@ name: pusher-http-haskell -version: 0.2.1.0 +version: 0.3.0.0 cabal-version: >=1.18 build-type: Simple license: MIT diff --git a/src/Data/Pusher.hs b/src/Data/Pusher.hs --- a/src/Data/Pusher.hs +++ b/src/Data/Pusher.hs @@ -13,12 +13,14 @@ ( 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) @@ -26,7 +28,7 @@ import qualified Data.ByteString as B import qualified Data.Text as T -import Network.Pusher.Internal.Util (failExpectObj) +import Network.Pusher.Internal.Util (failExpectObj, show') -- |All the required configuration needed to interact with the API. data Pusher = Pusher @@ -54,15 +56,26 @@ -- automatically. getPusher :: MonadIO m => Credentials -> m Pusher getPusher cred = do - connManager <- liftIO $ newManager defaultManagerSettings - return $ getPusherWithConnManager connManager cred + connManager <- getConnManager + return $ getPusherWithConnManager connManager Nothing cred -getPusherWithConnManager :: Manager -> Credentials -> Pusher -getPusherWithConnManager connManager cred = - let path = "/apps/" <> T.pack (show $ credentialsAppID cred) <> "/" in +-- |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 = "http://api.pusherapp.com" + { pusherHost = fromMaybe "http://api.pusherapp.com" apiHost , pusherPath = path , pusherCredentials = cred , pusherConnectionManager = connManager } + +getConnManager :: MonadIO m => m Manager +getConnManager = liftIO $ newManager defaultManagerSettings diff --git a/src/Network/Pusher.hs b/src/Network/Pusher.hs --- a/src/Network/Pusher.hs +++ b/src/Network/Pusher.hs @@ -29,12 +29,13 @@ @ let - pusher = getPusher $ Credentials - { credentials'appID = 123 - , credentials'appKey = wrd12344rcd234 - , credentials'appSecret = 124df34d545v + credentials = Credentials + { credentialsAppID = 123 + , credentialsAppKey = wrd12344rcd234 + , credentialsAppSecret = 124df34d545v } - result <- runPusherT (Pusher.trigger ["my-channel"] "my-event" "my-data") pusher + pusher <- getPusher credentials + result <- runPusherT (trigger [Channel Public "my-channel"] "my-event" "my-data" Nothing) pusher case result of Right resp -> print resp Left e -> error e @@ -77,7 +78,6 @@ , makeQS ) import Network.Pusher.Internal.HTTP (get, post) -import Network.Pusher.Internal.Util (show') import Network.Pusher.Protocol ( Channel , ChannelInfo @@ -87,6 +87,8 @@ , ChannelType , FullChannelInfo , Users + , renderChannel + , renderChannelPrefix , toURLParam ) @@ -106,7 +108,7 @@ let body = A.object $ [ ("name", A.String event) - , ("channels", A.toJSON (map (A.String . show') chans)) + , ("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 @@ -128,7 +130,7 @@ -> m ChannelsInfo -- ^The returned data channels channelTypeFilter prefixFilter attributes = do let - prefix = maybe "" show' channelTypeFilter <> prefixFilter + prefix = maybe "" renderChannelPrefix channelTypeFilter <> prefixFilter params = [ ("info", encodeUtf8 $ toURLParam attributes) , ("filter_by_prefix", encodeUtf8 prefix) @@ -146,7 +148,7 @@ -> m FullChannelInfo channel chan attributes = do let params = [("info", encodeUtf8 $ toURLParam attributes)] - (ep, path) <- getEndpoint $ "channels/" <> show' chan + (ep, path) <- getEndpoint $ "channels/" <> renderChannel chan qs <- makeQSWithTS "GET" path params "" connManager <- asks pusherConnectionManager get connManager (encodeUtf8 ep) qs @@ -157,7 +159,7 @@ => Channel -> m Users users chan = do - (ep, path) <- getEndpoint $ "channels/" <> show' chan <> "/users" + (ep, path) <- getEndpoint $ "channels/" <> renderChannel chan <> "/users" qs <- makeQSWithTS "GET" path [] "" connManager <- asks pusherConnectionManager get connManager (encodeUtf8 ep) qs diff --git a/src/Network/Pusher/Internal/Auth.hs b/src/Network/Pusher/Internal/Auth.hs --- a/src/Network/Pusher/Internal/Auth.hs +++ b/src/Network/Pusher/Internal/Auth.hs @@ -32,6 +32,7 @@ import qualified Crypto.MAC.HMAC as HMAC import Data.Pusher (Credentials(..)) +import Network.Pusher.Internal.Util (show') -- |Generate the required query string parameters required to send API requests -- to Pusher. @@ -49,7 +50,7 @@ -- 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_timestamp", show' ts) , ("auth_version", "1.0") , ("body_md5", B16.encode (MD5.hash body)) ] @@ -113,4 +114,3 @@ ) in credentialsAppKey cred <> ":" <> sig - diff --git a/src/Network/Pusher/Internal/HTTP.hs b/src/Network/Pusher/Internal/HTTP.hs --- a/src/Network/Pusher/Internal/HTTP.hs +++ b/src/Network/Pusher/Internal/HTTP.hs @@ -40,6 +40,7 @@ import qualified Data.Text as T import Control.Monad.Pusher.HTTP (MonadHTTP(httpLbs)) +import Network.Pusher.Internal.Util (show') import Debug.Trace @@ -84,7 +85,7 @@ -> Maybe BL.ByteString -> m (Response BL.ByteString) makeRequest connManager ep qs body = do - req <- either (throwError . T.pack . show) return (parseUrl $ BC.unpack ep) + req <- either (throwError . show') return (parseUrl $ BC.unpack ep) let req' = setQueryString (map (second Just) qs) req req'' = case body of @@ -102,7 +103,7 @@ if statusCode status == 200 then run else - throwError $ either (T.pack . show) id $ decodeUtf8' $ statusMessage status + throwError $ either show' id $ decodeUtf8' $ statusMessage status errorOn200 :: (MonadError T.Text m) => Response BL.ByteString -> m () errorOn200 response = when200 response (return ()) diff --git a/src/Network/Pusher/Protocol.hs b/src/Network/Pusher/Protocol.hs --- a/src/Network/Pusher/Protocol.hs +++ b/src/Network/Pusher/Protocol.hs @@ -18,17 +18,17 @@ ( Channel(..) , ChannelInfo(..) , ChannelInfoAttributes(..) - , ChannelInfoAttributeResp(..) , ChannelInfoQuery(..) , ChannelsInfo(..) , ChannelsInfoQuery(..) , ChannelsInfoAttributes(..) , ChannelType(..) , FullChannelInfo(..) - , FullChannelAttributeResp(..) , User(..) , Users(..) , parseChannel + , renderChannel + , renderChannelPrefix , toURLParam ) where @@ -37,6 +37,7 @@ import Data.Foldable (asum) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary, arbitrary, elements) import qualified Data.Aeson as A @@ -44,35 +45,35 @@ import qualified Data.HashSet as HS import qualified Data.Text as T -import Network.Pusher.Internal.Util (failExpectObj, show') +import Network.Pusher.Internal.Util (failExpectObj) -- |The possible types of Pusher channe. -data ChannelType = Public | Private | Presence deriving (Eq, Generic) +data ChannelType = Public | Private | Presence deriving (Eq, Generic, Show) instance Hashable ChannelType -instance Show ChannelType where - show Public = "" - show Private = "private-" - show Presence = "presence-" - instance Arbitrary ChannelType where arbitrary = elements [Public, Private, Presence] +renderChannelPrefix :: ChannelType -> T.Text +renderChannelPrefix Public = "" +renderChannelPrefix Private = "private-" +renderChannelPrefix Presence = "presence-" + -- |The channel name (not including the channel type prefix) and its type. data Channel = Channel { channelType :: ChannelType , channelName :: T.Text - } deriving (Eq, Generic) + } deriving (Eq, Generic, Show) 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) +renderChannel :: Channel -> T.Text +renderChannel (Channel cType cName) = renderChannelPrefix cType <> cName + -- |Convert string representation, e.g. private-chan into the datatype parseChannel :: T.Text -> Channel parseChannel chan = @@ -82,7 +83,7 @@ (asum [parseChanAs Private, parseChanAs Presence]) where parseChanAs chanType = - let split = T.splitOn (show' chanType) chan in + let split = T.splitOn (renderChannelPrefix 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) @@ -144,56 +145,30 @@ 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) +-- |The possible returned channel attributes when multiple when multiple +-- channels are queried. +data ChannelInfo = ChannelInfo + { channelInfoUserCount :: Maybe Int + } 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 (A.Object v) = ChannelInfo <$> v .:? "user_count" 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) +-- |The possible values returned by a query to a single channel +data FullChannelInfo = FullChannelInfo + { fullChannelInfoOccupied :: Bool + , fullChannelInfoUserCount :: Maybe Int + , fullChannelInfoSubCount :: Maybe Int + } 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 (A.Object v) = + FullChannelInfo + <$> v .: "occupied" + <*> v .:? "user_count" + <*> v .:? "subscription_count" 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) diff --git a/test/Protocol.hs b/test/Protocol.hs --- a/test/Protocol.hs +++ b/test/Protocol.hs @@ -10,25 +10,26 @@ import Network.Pusher.Protocol ( Channel(..) , ChannelInfo(..) - , ChannelInfoAttributeResp(UserCountResp) , ChannelsInfo(..) , ChannelType(Public, Presence, Private) + , FullChannelInfo(..) , User(..) , Users(..) , parseChannel + , renderChannel ) test :: Spec test = do describe "Protocol.Channel" $ do it "show instance works for public channels" $ - show (Channel Public "test") `shouldBe` "test" + renderChannel (Channel Public "test") `shouldBe` "test" it "show instance works for private channels" $ - show (Channel Private "test") `shouldBe` "private-test" + renderChannel (Channel Private "test") `shouldBe` "private-test" it "show instance is an inverse of parseChannel" $ - property $ \chan -> parseChannel (T.pack $ show chan) == chan + property $ \chan -> parseChannel (renderChannel chan) == chan describe "Protocol.ChannelsInfo" $ it "parsing works" $ @@ -46,11 +47,11 @@ \ }" `shouldBe` (Just $ ChannelsInfo $ HM.fromList - [ (Channel Presence "foobar", ChannelInfo $ HS.fromList [UserCountResp 42]) - , (Channel Presence "another", ChannelInfo $ HS.fromList [UserCountResp 123]) + [ (Channel Presence "foobar", ChannelInfo $ Just 42) + , (Channel Presence "another", ChannelInfo $ Just 123) ]) - describe "Protocol.ChannelInfo" $ + describe "Protocol.FullChannelInfo" $ it "parsing works" $ -- Data from https://pusher.com/docs/rest_api#successful-response-2 A.decode @@ -60,8 +61,7 @@ \ \"subscription_count\": 42\ \ }" `shouldBe` - -- TODO: Currently incomplete due to ChannelInfo being incomplete - (Just $ ChannelInfo $ HS.fromList [UserCountResp 42]) + (Just $ FullChannelInfo True (Just 42) (Just 42)) describe "Protocol.Users" $ it "parsing works" $