packages feed

pusher-http-haskell 1.2.0.1 → 1.3.0.0

raw patch · 11 files changed

+418/−440 lines, 11 filesdep ~base

Dependency ranges changed: base

Files

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