pusher-http-haskell 1.5.1.14 → 2.0.0.0

raw patch · 16 files changed

+1037/−1757 lines, 16 filesdep +http-client-tlsdep −scientificdep −transformersdep −vectordep ~aesondep ~basedep ~base16-bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: http-client-tls

Dependencies removed: scientific, transformers, vector

Dependency ranges changed: aeson, base, base16-bytestring, cryptonite, http-client, http-types, time

API changes (from Hackage documentation)

Files

• Setup.hs +1/−0
• pusher-http-haskell.cabal +44/−60
• src/Network/Pusher.hs +181/−217
• src/Network/Pusher/Data.hs +130/−356
• src/Network/Pusher/Error.hs +11/−8
• src/Network/Pusher/Internal.hs +84/−140
• src/Network/Pusher/Internal/Auth.hs +91/−106
• src/Network/Pusher/Internal/HTTP.hs +106/−91
• src/Network/Pusher/Internal/Util.hs +20/−45
• src/Network/Pusher/Protocol.hs +82/−86
• src/Network/Pusher/Webhook.hs +96/−114
• test/Auth.hs +48/−46
• test/Main.hs +2/−4
• test/Protocol.hs +51/−56
• test/Push.hs +0/−354
• test/Webhook.hs +90/−74

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,92 +1,76 @@-name: pusher-http-haskell-version: 1.5.1.14 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/WillSewell/pusher-http-haskell-bug-reports: https://github.com/WillSewell/pusher-http-haskell/issues-synopsis: Haskell client library for the Pusher Channels HTTP API+name:          pusher-http-haskell+version:       2.0.0.0+license:       MIT+license-file:  LICENSE+copyright:     (c) Will Sewell, 2016+maintainer:    me@willsewell.com+author:        Will Sewell+stability:     stable+tested-with:   ghc >=8.6.5+homepage:      https://github.com/WillSewell/pusher-http-haskell+bug-reports:   https://github.com/WillSewell/pusher-http-haskell/issues+synopsis:      Haskell client library for the Pusher Channels HTTP API description:     Functions that correspond to endpoints of the Pusher Channels     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+category:      Network+build-type:    Simple -    if impl(ghc >=8.0.0)-        ghc-options: -Wcompat -Wmissing-signatures-    else-        ghc-options: -fwarn-hi-shadowing -fwarn-missing-signatures -fwarn-tabs+library     exposed-modules:         Network.Pusher         Network.Pusher.Internal         Network.Pusher.Internal.Auth         Network.Pusher.Internal.HTTP         Network.Pusher.Protocol++    hs-source-dirs:     src+    other-modules:+        Network.Pusher.Data+        Network.Pusher.Error+        Network.Pusher.Internal.Util+        Network.Pusher.Webhook++    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    ghc-options:        -Wcompat -Wmissing-signatures -Wall     build-depends:-        aeson >=0.8 && <1.6,-        base >=4.7 && <4.15,+        aeson >=1.0 && <1.6,+        base >=4.11 && <4.15,         bytestring ==0.10.*,         base16-bytestring ==0.1.*,-        cryptonite >= 0.6 && <0.28,+        cryptonite >=0.6 && <0.28,         hashable >=1.2 && <1.4,-        http-client >=0.4 && <0.8,+        http-client >=0.4.30 && <0.8,+        http-client-tls ==0.3.*,         http-types >=0.8 && <0.13,-        memory >= 0.7 && <0.16,+        memory >=0.7 && <0.16,         text ==1.2.*,         time >=1.5 && <1.11,-        transformers >=0.4 && <0.6,-        unordered-containers ==0.2.*,-        vector >=0.10 && <0.13-    default-language: Haskell2010-    default-extensions: OverloadedStrings-    hs-source-dirs: src-    other-modules:-        Network.Pusher.Data-        Network.Pusher.Error-        Network.Pusher.Internal.Util-        Network.Pusher.Webhook-    ghc-options: -Wall+        unordered-containers ==0.2.*  test-suite tests+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     test+    other-modules:+        Auth+        Protocol+        Webhook -    if impl(ghc >=8.0.0)-        ghc-options: -Wcompat -Wmissing-signatures-    else-        ghc-options: -fwarn-hi-shadowing -fwarn-missing-signatures -fwarn-tabs-    type: exitcode-stdio-1.0-    main-is: Main.hs+    default-language:   Haskell2010+    default-extensions: OverloadedStrings+    ghc-options:        -Wcompat -Wmissing-signatures -Wall     build-depends:         aeson -any,         base -any,         bytestring -any,-        base16-bytestring -any,-        cryptonite -any,         hspec -any,-        http-client -any,-        http-types -any,         pusher-http-haskell -any,         QuickCheck -any,-        time -any,         text -any,-        transformers -any,-        unordered-containers -any,-        vector -any,-        scientific -any-    default-language: Haskell2010-    default-extensions: OverloadedStrings-    hs-source-dirs: test-    other-modules:-        Auth-        Protocol-        Webhook-        Push-    ghc-options: -Wall+        unordered-containers -any

@@ -1,247 +1,211 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-|-Module      : Network.Pusher-Description : Haskell interface to the Pusher Channels HTTP API-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental -Exposes the functions necessary for interacting with the Pusher Channels HTTP-API, as well as functions for generating auth signatures for private and-presence channels.--First create a 'Pusher' data structure with your Pusher Channels 'Credentials',-and then call the functions defined in this module to make the HTTP requests.--If any of the requests fail, the return values of the functions will result in-a 'Left' 'PusherError' when run.--An example of how you would use these functions:--@-  let-    credentials = 'Credentials'-      { 'credentialsAppID'     = 123-      , 'credentialsAppKey'    = "wrd12344rcd234"-      , 'credentialsAppSecret' = "124df34d545v"-      , 'credentialsCluster'   = Nothing-      }-  pusher <- 'getPusher' credentials--  triggerRes <--    'trigger' pusher ['Channel' 'Public' "my-channel"] "my-event" "my-data" Nothing+-- |+-- Module      : Network.Pusher+-- Description : Haskell interface to the Pusher Channels HTTP API+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable+--+-- Exposes the functions necessary for interacting with the Pusher Channels HTTP+-- API, as well as functions for generating auth signatures for private and+-- presence channels.+--+-- First create a 'Settings'. The easiest way of doing this is by using+-- 'defaultSettings'. From that you can use 'newPusher' to create a 'Pusher'+-- instance and then call the functions defined in this module to make the HTTP+-- requests.+--+-- If any of the requests fail, the return values of the functions will result in+-- a 'Left' 'PusherError' when run.+--+-- An example of how you would use these functions:+--+-- @+--   let+--     settings =+--       'defaultSettings'+--         { 'pusherAddress' = 'Cluster' "mt1",+--           'pusherAppID' = 123,+--           'pusherToken' = 'Token' "wrd12344rcd234" "124df34d545v"+--         }+--   pusher <- 'newPusher' settings+--+--   result <-+--     'trigger' pusher ["my-channel"] "my-event" "my-data" Nothing+--+--   case result of+--     Left e -> putStrLn $ displayException e+--     Right resp -> print resp+--+-- @+--+-- There are simple working examples in the example/ directory.+--+-- See https://pusher.com/docs/channels/server_api/http-api for more detail on the+-- HTTP requests.+module Network.Pusher+  ( -- * Data types -  case triggerRes of-    Left e -> putStrLn $ displayException e-    Right resp -> print resp+    -- ** Settings+    Settings (..),+    defaultSettings,+    Token (..),+    Address (..), -  -- import qualified Data.HashMap.Strict as H-  -- import qualified Data.Aeson          as A-  let-    -- A Firebase Cloud Messaging notification payload-    fcmObject = H.fromList [("notification", A.Object $ H.fromList-                                [("title", A.String "a title")-                                ,("body" , A.String "some text")-                                ,("icon" , A.String "logo.png")-                                ]-                            )]-    Just interest = 'mkInterest' "some-interest"+    -- ** Main Pusher type+    Pusher,+    newPusher,+    newPusherWithConnManager, -    -- A Pusher Channels notification-    notification = 'Notification'-      { 'notificationInterest'     = interest-      , 'notificationWebhookURL'   = Nothing-      , 'notificationWebhookLevel' = Nothing-      , 'notificationAPNSPayload'  = Nothing-      , 'notificationGCMPayload'   = Nothing-      , 'notificationFCMPayload'   = Just $ 'FCMPayload' fcmObject-      }+    -- * HTTP Requests -  notifyRes <- 'notify' pusher notification+    -- ** Trigger events+    trigger, -@+    -- ** Channel queries+    channels,+    channel,+    users, +    -- * Authentication+    authenticatePresence,+    authenticatePrivate, -There are simple working examples in the example/ directory.+    -- * Errors+    PusherError (..), -See https://pusher.com/docs/channels/server_api/http-api for more detail on the-HTTP requests.--}-module Network.Pusher (-  -- * Data types-  -- ** Pusher config type-    Pusher(..)-  , Credentials(..)-  , Cluster(..)-  , AppID-  , AppKey-  , AppSecret-  , getPusher-  , getPusherWithHost-  , getPusherWithConnManager-  -- ** Channels-  , Channel(..)-  , ChannelName-  , ChannelType(..)-  , renderChannel-  , renderChannelPrefix-  , parseChannel-  -- ** Events-  , Event-  , EventData-  , SocketID-  -- ** Notifications-  , Notification(..)-  , Interest-  , mkInterest-  , WebhookURL-  , WebhookLevel(..)-  , APNSPayload(..)-  , GCMPayload(..)-  , FCMPayload(..)-  -- * HTTP Requests-  -- ** Trigger events-  , trigger-  -- ** Channel queries-  , channels-  , channel-  , users-  -- ** Push notifications-  , notify-  -- * Authentication-  , AuthString-  , AuthSignature-  , authenticatePresence-  , authenticatePrivate-  -- * Errors-  , PusherError(..)-  -- * Webhooks-  , parseWebhookPayload-  , WebhookEv(..)-  , WebhookPayload(..)-  , Webhooks(..)-  , parseAppKeyHdr-  , parseAuthSignatureHdr-  , parseWebhooksBody-  , verifyWebhooksBody-  , parseWebhookPayloadWith-  ) where+    -- * Webhooks+    parseWebhookPayload,+    WebhookEv (..),+    WebhookPayload (..),+    Webhooks (..),+    parseAppKeyHdr,+    parseAuthSignatureHdr,+    parseWebhooksBody,+    verifyWebhooksBody,+    parseWebhookPayloadWith,+  )+where -import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Except (ExceptT(ExceptT), runExceptT)+import Control.Monad.IO.Class+  ( MonadIO,+    liftIO,+  )+import qualified Data.Aeson as A+import qualified Data.ByteString as B import qualified Data.Text as T--import qualified Data.ByteString.Char8 as BC import Network.Pusher.Data-       (APNSPayload(..), AppID, AppKey, AppSecret, Channel(..),-        ChannelName, ChannelType(..), Cluster(..), Credentials(..), Event,-        EventData, FCMPayload(..), GCMPayload(..), Interest,-        Notification(..), Pusher(..), SocketID, WebhookLevel(..),-        WebhookURL, getPusher, getPusherWithConnManager, getPusherWithHost,-        mkInterest, parseChannel, renderChannel, renderChannelPrefix)-import Network.Pusher.Error (PusherError(..))+  ( Address (..),+    Pusher (..),+    Settings (..),+    Token (..),+    defaultSettings,+    newPusher,+    newPusherWithConnManager,+  )+import Network.Pusher.Error (PusherError (..)) import qualified Network.Pusher.Internal as Pusher-import Network.Pusher.Internal.Auth-       (AuthSignature, AuthString, authenticatePresence,-        authenticatePrivate)+import qualified Network.Pusher.Internal.Auth as Auth import qualified Network.Pusher.Internal.HTTP as HTTP-import Network.Pusher.Internal.Util (getTime)+import Network.Pusher.Internal.Util (getSystemTimeSeconds) import Network.Pusher.Protocol-       (ChannelInfoQuery, ChannelsInfo, ChannelsInfoQuery,-        FullChannelInfo, Users)+  ( ChannelInfoQuery,+    ChannelsInfo,+    ChannelsInfoQuery,+    FullChannelInfo,+    Users,+  ) import Network.Pusher.Webhook-       (WebhookEv(..), WebhookPayload(..), Webhooks(..), parseAppKeyHdr,-        parseAuthSignatureHdr, parseWebhookPayloadWith, parseWebhooksBody,-        verifyWebhooksBody)+  ( WebhookEv (..),+    WebhookPayload (..),+    Webhooks (..),+    parseAppKeyHdr,+    parseAuthSignatureHdr,+    parseWebhookPayloadWith,+    parseWebhooksBody,+    verifyWebhooksBody,+  ) --- |Trigger an event to one or more channels.+-- | Trigger an event to one or more channels. trigger ::-     MonadIO m-  => Pusher-  -> [Channel]-  -- ^The list of channels to trigger to.-  -> Event-  -> EventData-  -- ^Often encoded JSON.-  -> Maybe SocketID-  -- ^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+  MonadIO m =>+  Pusher ->+  -- | The list of channels to trigger to.+  [T.Text] ->+  -- | Event name.+  T.Text ->+  -- | Event data. Often encoded JSON.+  T.Text ->+  -- | An optional socket ID of a connection you wish to exclude.+  Maybe T.Text ->+  m (Either PusherError ())+trigger pusher chans event dat socketId = do+  (requestParams, requestBody) <-+    Pusher.mkTriggerRequest pusher chans event dat socketId+      <$> getSystemTimeSeconds+  liftIO $ HTTP.post (pConnectionManager pusher) requestParams requestBody --- |Query a list of channels for information.+-- | Query a list of channels for information. channels ::-     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+  MonadIO m =>+  Pusher ->+  -- | A channel prefix you wish to filter on.+  T.Text ->+  -- | Data you wish to query for, currently just the user count.+  ChannelsInfoQuery ->+  -- | The returned data.+  m (Either PusherError ChannelsInfo)+channels pusher prefixFilter attributes = do+  requestParams <-+    Pusher.mkChannelsRequest pusher prefixFilter attributes+      <$> getSystemTimeSeconds+  liftIO $ HTTP.get (pConnectionManager pusher) requestParams --- |Query for information on a single channel.+-- | Query for information on a single channel. channel ::-     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+  MonadIO m =>+  Pusher ->+  B.ByteString ->+  -- | Can query user count and also subscription count (if enabled).+  ChannelInfoQuery ->+  m (Either PusherError FullChannelInfo)+channel pusher chan attributes = do+  requestParams <-+    Pusher.mkChannelRequest pusher chan attributes <$> getSystemTimeSeconds+  liftIO $ HTTP.get (pConnectionManager pusher) requestParams --- |Get a list of users in a presence channel.-users :: 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+-- | Get a list of users in a presence channel.+users :: MonadIO m => Pusher -> B.ByteString -> m (Either PusherError Users)+users pusher chan = do+  requestParams <- Pusher.mkUsersRequest pusher chan <$> getSystemTimeSeconds+  liftIO $ HTTP.get (pConnectionManager pusher) requestParams --- |Send a push notification.-notify :: MonadIO m => Pusher -> Notification -> m (Either PusherError ())-notify pusher notification =-  liftIO $-  runExceptT $ do-    (requestParams, requestBody) <--      ExceptT $ Pusher.mkNotifyRequest pusher notification <$> getTime-    HTTP.post (pusherConnectionManager pusher) requestParams requestBody+-- | Generate an auth signature of the form "app_key:auth_sig" for a user of a+--  private channel.+authenticatePrivate :: Pusher -> T.Text -> T.Text -> B.ByteString+authenticatePrivate pusher = Auth.authenticatePrivate (pToken pusher) --- |Parse webhooks from a list of HTTP headers and a HTTP body given their--- 'AppKey' matches the one in our Pusher Channels credentials and the webhook--- is correctly encrypted by the corresponding 'AppSecret'.+-- | Generate an auth signature of the form "app_key:auth_sig" for a user of a+--  presence channel.+authenticatePresence ::+  A.ToJSON a => Pusher -> T.Text -> T.Text -> a -> B.ByteString+authenticatePresence pusher = Auth.authenticatePresence (pToken pusher)++-- | Parse webhooks from a list of HTTP headers and a HTTP body given their+--  app key matches the one in our Pusher Channels credentials and the webhook+--  is correctly encrypted by the corresponding app secret. parseWebhookPayload ::-     Pusher-  -> [(BC.ByteString, BC.ByteString)]-  -> BC.ByteString-  -> Maybe WebhookPayload+  Pusher ->+  [(B.ByteString, B.ByteString)] ->+  B.ByteString ->+  Maybe WebhookPayload parseWebhookPayload pusher =-  let credentials = pusherCredentials pusher-      ourAppKey = credentialsAppKey credentials-      ourAppSecret = credentialsAppSecret credentials+  let token = pToken pusher+      ourAppKey = tokenKey token+      ourAppSecret = tokenSecret token       lookupKeysSecret whAppKey =-        if whAppKey == ourAppKey-          then Just ourAppSecret-          else Nothing-  in parseWebhookPayloadWith lookupKeysSecret+        if whAppKey == ourAppKey then Just ourAppSecret else Nothing+   in parseWebhookPayloadWith lookupKeysSecret

@@ -1,370 +1,144 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}--{-|-Module      : Network.Pusher.Data-Description : Data structure representing Pusher Channels concepts and config-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental--You must create an instance of the Pusher datatype with your particular Pusher-Channels app credentials in order to run the main API functions.--The other types represent channels and event fields.--}-module Network.Pusher.Data (-  -- * Pusher config data type-    AppID-  , AppKey-  , AppSecret-  , Pusher(..)-  , Credentials(..)-  , Cluster(..)-  , clusterMt1-  , clusterEu-  , clusterAp1-  , clusterAp2-  , getPusher-  , getPusherWithHost-  , getPusherWithConnManager-  -- * Channels-  , Channel(..)-  , ChannelName-  , ChannelType(..)-  , renderChannel-  , renderChannelPrefix-  , parseChannel-  -- Events-  , Event-  , EventData-  , SocketID-  -- * Notifications-  , Notification(..)-  , Interest-  , mkInterest-  , WebhookURL-  , WebhookLevel(..)-  , APNSPayload(..)-  , GCMPayload(..)-  , FCMPayload(..)-  ) where+-- |+-- Module      : Network.Pusher.Data+-- Description : Data structures representing Channels concepts and settings+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable+module Network.Pusher.Data+  ( Settings (..),+    defaultSettings,+    Token (..),+    Address (..),+    Pusher (..),+    newPusher,+    newPusherWithConnManager,+  )+where -import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson ((.:), (.:?), (.=))+import Control.Monad.IO.Class (MonadIO)+import Data.Aeson ((.:), (.:?)) import qualified Data.Aeson as A import qualified Data.ByteString as B-import Data.Char (isAlphaNum)-import Data.Foldable (asum)-import qualified Data.HashSet as HS-import Data.Hashable (Hashable)-import Data.Maybe (fromMaybe)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8)-import qualified Data.Vector as V-import GHC.Generics (Generic)-import Network.HTTP.Client-       (Manager, defaultManagerSettings, newManager)--import Network.Pusher.Internal.Util-       (failExpectArray, failExpectObj, failExpectSingletonArray,-        failExpectStr, show')--type AppID = Integer--type AppKey = B.ByteString--type AppSecret = B.ByteString---- |All the required configuration needed to interact with the API.-data Pusher = Pusher-  { pusherHost :: T.Text-  , pusherPath :: T.Text-  , pusherNotifyHost :: T.Text-  , pusherNotifyPath :: T.Text-  , pusherCredentials :: Credentials-  , pusherConnectionManager :: Manager-  }---- |The credentials for the current app.-data Credentials = Credentials-  { 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") <*>-    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 cred = do-  connManager <- getConnManager-  return $ getPusherWithConnManager connManager Nothing Nothing cred---- |Get a Pusher instance that uses a specific API endpoint.-getPusherWithHost :: MonadIO m => T.Text -> T.Text -> Credentials -> m Pusher-getPusherWithHost apiHost notifyHost cred = do-  connManager <- getConnManager-  return $-    getPusherWithConnManager connManager (Just apiHost) (Just notifyHost) 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 -> Maybe T.Text -> Credentials -> Pusher-getPusherWithConnManager connManager apiHost notifyAPIHost cred =-  let path = "/apps/" <> show' (credentialsAppID cred) <> "/"-      mCluster = credentialsCluster cred-      notifyPath =-        "/server_api/v1/apps/" <> show' (credentialsAppID cred) <> "/"-  in Pusher-     { pusherHost = fromMaybe (mkHost mCluster) apiHost-     , pusherPath = path-     , pusherNotifyHost =-         fromMaybe "http://nativepush-cluster1.pusher.com" notifyAPIHost-     , pusherNotifyPath = notifyPath-     , pusherCredentials = cred-     , pusherConnectionManager = connManager-     }---- |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 channel.-data ChannelType-  = Public-  | Private-  | Presence-  deriving (Eq, Generic, Show)--instance Hashable ChannelType--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 :: ChannelName-  } deriving (Eq, Generic, Show)--instance Hashable Channel--instance A.FromJSON Channel where-  parseJSON s =-    case s of-      A.String txt -> return $ parseChannel txt-      _ -> failExpectStr s--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-  -- 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-    -- If the prefix appears at the start, then the first element will be empty-      in if length split > 1 && T.null (head split)-           then Just $ Channel chanType (T.concat $ tail split)-           else Nothing--type Event = T.Text+import Data.Word (Word16, Word32)+import Network.HTTP.Client (Manager)+import Network.HTTP.Client.TLS (newTlsManager)+import Network.Pusher.Internal.Util (show') -type EventData = T.Text+-- | All the required configuration needed to interact with the API.+data Settings+  = Settings+      { pusherAddress :: Address,+        pusherAppID :: Word32,+        pusherToken :: Token,+        pusherUseTLS :: Bool+      } -type SocketID = T.Text+instance A.FromJSON Settings where+  parseJSON =+    A.withObject "Settings" $ \v -> do+      cluster <- (encodeUtf8 <$>) <$> v .:? "cluster"+      host <- (encodeUtf8 <$>) <$> v .:? "host"+      port <- v .:? "port"+      let address = case (cluster, host, port) of+            (Just c, Nothing, Nothing) -> Just $ Cluster c+            (Nothing, Just h, Just p) -> Just $ HostPort h p+            (Nothing, Nothing, Nothing) -> Nothing+            _ -> fail "`cluster` is mutually exclusive with `host` and `port`"+      appID <- v .: "app_id"+      token <- v .: "token"+      useTLS <- v .:? "use_tls"+      let settings =+            defaultSettings+              { pusherAppID = appID,+                pusherToken = token+              }+      pure $ setOptionals address useTLS settings+    where+      setOptionals maybeAddress maybeUseTLS =+        setAddress maybeAddress . setUseTLS maybeUseTLS+      setAddress (Just address) settings = settings {pusherAddress = address}+      setAddress Nothing settings = settings+      setUseTLS (Just useTLS) settings = settings {pusherUseTLS = useTLS}+      setUseTLS Nothing settings = settings --- |Up to 164 characters where each character is ASCII upper or lower case, a--- number or one of _=@,.;+-- | A convenient way of creating an instance of 'Settings'. Another+-- benefit is it prevents breaking changes when fields are added to+-- 'Settings', see <https://www.yesodweb.com/book/settings-types>.You+-- must set 'pusherAppID' and 'pusherToken'. Currently 'pusherAddress'+-- defaults to the @mt1@ cluster. ----- Note: hyphen - is NOT valid as it is reserved for the possibility of marking--- interest names with prefixes such as private- or presence-.-newtype Interest =-  Interest T.Text-  deriving (Eq, Show)--mkInterest :: T.Text -> Maybe Interest-mkInterest txt-  | 0 < T.length txt &&-      T.length txt <= 164 &&-      T.all (\c -> isAlphaNum c || HS.member c permitted) txt =-    Just . Interest $ txt-  | otherwise = Nothing-  where-    permitted = HS.fromList "_=@,.;"--instance A.FromJSON Interest where-  parseJSON v =-    case v of-      A.String s ->-        case mkInterest s of-          Nothing ->-            fail $-            "An Interest contains invalid characters or is too long: " ++ show s-          Just istr -> pure istr-      _ -> failExpectStr v--instance A.ToJSON Interest where-  toJSON (Interest txt) = A.String txt---- |URL to which Pusher Channels will send information about sent push--- notifications.-type WebhookURL = T.Text---- |Level of detail sent to WebhookURL. Defaults to Info.-data WebhookLevel-  = Info -- ^ Errors only-  | Debug -- ^ Everything-  deriving (Eq, Show)--instance A.FromJSON WebhookLevel where-  parseJSON v =-    case v of-      A.String s-        | s == "INFO" -> pure Info-        | s == "DEBUG" -> pure Debug-      _ -> failExpectStr v--instance A.ToJSON WebhookLevel where-  toJSON w =-    A.String $-    case w of-      Info -> "INFO"-      Debug -> "DEBUG"---- |Apple push notification service payload.-data APNSPayload =-  -- TODO: Replace JSON object with a stronger encoding-  APNSPayload A.Object-  deriving (Eq, Show)--instance A.FromJSON APNSPayload where-  parseJSON v =-    case v of-      A.Object o -> pure . APNSPayload $ o-      _ -> failExpectObj v--instance A.ToJSON APNSPayload where-  toJSON (APNSPayload o) = A.Object o---- |Google Cloud Messaging payload.-data GCMPayload =-  -- TODO: Replace JSON object with a stronger encoding-  GCMPayload A.Object-  deriving (Eq, Show)--instance A.FromJSON GCMPayload where-  parseJSON v =-    case v of-      A.Object o -> pure . GCMPayload $ o-      _ -> failExpectObj v--instance A.ToJSON GCMPayload where-  toJSON (GCMPayload o) = A.Object o+-- Example:+--+-- @+-- defaultSettings+--   { 'pusherAppID' = 123,+--     'pusherToken' = 'Token' { 'tokenKey' = "key", 'tokenSecret' "secret" }+--   }+-- @+defaultSettings :: Settings+defaultSettings =+  Settings+    { pusherAddress = Cluster "mt1",+      pusherAppID = 1,+      pusherToken = Token "" "",+      pusherUseTLS = True+    } --- |Firebase Cloud Messaging payload.-data FCMPayload =-  -- TODO: Replace JSON object with a stronger encoding-  FCMPayload A.Object-  deriving (Eq, Show)+-- | A Channels key and secret pair for a particular app.+data Token+  = Token+      { tokenKey :: B.ByteString,+        tokenSecret :: B.ByteString+      } -instance A.FromJSON FCMPayload where-  parseJSON v =-    case v of-      A.Object o -> pure . FCMPayload $ o-      _ -> failExpectObj v+instance A.FromJSON Token where+  parseJSON =+    A.withObject "Token" $ \v -> do+      key <- encodeUtf8 <$> v .: "key"+      secret <- encodeUtf8 <$> v .: "secret"+      pure $ Token key secret -instance A.ToJSON FCMPayload where-  toJSON (FCMPayload o) = A.Object o+-- | Typically you will want to connect directly to a standard Pusher Channels+-- 'Cluster'.+data Address+  = -- | The cluster the current app resides on. Common clusters include:+    -- @mt1@, @eu@, @ap1@, @ap2@.+    Cluster B.ByteString+  | -- | Used to connect to a raw address:port.+    HostPort B.ByteString Word16 -data Notification = Notification-  { notificationInterest :: Interest-  , notificationWebhookURL :: Maybe WebhookURL-  , notificationWebhookLevel :: Maybe WebhookLevel-  , notificationAPNSPayload :: Maybe APNSPayload-  , notificationGCMPayload :: Maybe GCMPayload-  , notificationFCMPayload :: Maybe FCMPayload-  } deriving (Eq, Show)+-- | The core handle to the Pusher API.+data Pusher+  = Pusher+      { pUseTLS :: Bool,+        pHost :: B.ByteString,+        pPort :: Word16,+        pPath :: B.ByteString,+        pToken :: Token,+        pConnectionManager :: Manager+      } -instance A.FromJSON Notification where-  parseJSON (A.Object v) =-    Notification <$>-    (do interests <- v A..: "interests"-        case interests of-          A.Array arr-            | V.length arr == 1 -> A.parseJSON $ V.head arr-            | otherwise -> failExpectSingletonArray interests-          v' -> failExpectArray v') <*>-    v .:? "webhook_url" <*>-    v .:? "webhook_level" <*>-    v .:? "apns" <*>-    v .:? "gcm" <*>-    v .:? "fcm"-  parseJSON v = failExpectObj v+-- | Use this to get a Pusher instance.+newPusher :: MonadIO m => Settings -> m Pusher+newPusher settings = do+  connManager <- newTlsManager+  return $ newPusherWithConnManager connManager settings -instance A.ToJSON Notification where-  toJSON (Notification interests mWebhookURL mWebhookLevel mAPNS mGCMP mFCMP) =-    let requiredFields = ["interests" .= [interests]]-        consOptionals =-          consJust "webhook_level" mWebhookLevel .-          consJust "webhook_url" mWebhookURL .-          consJust "apns" mAPNS . consJust "gcm" mGCMP . consJust "fcm" mFCMP-        fields = consOptionals requiredFields-    in A.object fields-      -- Cons a attribute value pair if Just-    where-      consJust attr = maybe id ((:) . (attr .=))+-- | Get a Pusher instance with a given connection manager. This can be useful+--  if you want to share a connection with your application code.+newPusherWithConnManager :: Manager -> Settings -> Pusher+newPusherWithConnManager connectionManager settings =+  let (host, port) = case pusherAddress settings of+        HostPort h p -> (h, p)+        Cluster c -> ("api-" <> c <> ".pusher.com", if pusherUseTLS settings then 443 else 80)+      path = "/apps/" <> show' (pusherAppID settings) <> "/"+   in Pusher+        { pUseTLS = pusherUseTLS settings,+          pHost = host,+          pPort = port,+          pPath = path,+          pToken = pusherToken settings,+          pConnectionManager = connectionManager+        }

@@ -1,17 +1,20 @@ module Network.Pusher.Error-  ( PusherError(..)-  ) where+  ( PusherError (..),+  )+where  import Control.Exception (Exception) import qualified Data.Text as T+import Data.Word (Word16)  data PusherError-  = PusherArgumentError T.Text-  -- ^Data from the caller is not valid.-  | PusherNon200ResponseError T.Text-  -- ^Received non 200 response code from Pusher.-  | PusherInvalidResponseError T.Text-  -- ^Received unexpected data from Pusher.+  = -- | Received non 200 response code from Pusher.+    Non200Response+      { non200ResponseStatusCode :: Word16,+        non200ResponseBody :: T.Text+      }+  | -- | Received unexpected data from Pusher.+    InvalidResponse T.Text   deriving (Show)  instance Exception PusherError

@@ -1,166 +1,110 @@-{-# LANGUAGE CPP #-}--{-|-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+-- Description : Pure functions called by the public interface+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable module Network.Pusher.Internal-  ( mkTriggerRequest-  , mkChannelsRequest-  , mkChannelRequest-  , mkUsersRequest-  , mkNotifyRequest-  ) where+  ( mkTriggerRequest,+    mkChannelsRequest,+    mkChannelRequest,+    mkUsersRequest,+  )+where -import Control.Monad (when) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Maybe (maybeToList)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8)--import Network.Pusher.Data-       (Channel, ChannelType, Credentials(..), Event, EventData,-        Notification(..), Pusher(..), SocketID, renderChannel,-        renderChannelPrefix)-import Network.Pusher.Error (PusherError(..))+import Data.Word (Word64)+import Network.HTTP.Types (Query)+import Network.Pusher.Data (Pusher (..)) import Network.Pusher.Internal.Auth (makeQS) import Network.Pusher.Internal.HTTP-       (RequestBody, RequestParams(RequestParams), RequestQueryString)+  ( RequestParams (RequestParams),+  ) import Network.Pusher.Protocol-       (ChannelInfoQuery, ChannelsInfoQuery, toURLParam)+  ( ChannelInfoQuery,+    ChannelsInfoQuery,+    toURLParam,+  )  mkTriggerRequest ::-     Pusher-  -> [Channel]-  -> Event-  -> EventData-  -> Maybe SocketID-  -> 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")+  Pusher ->+  [T.Text] ->+  T.Text ->+  T.Text ->+  Maybe T.Text ->+  Word64 ->+  (RequestParams, A.Value)+mkTriggerRequest pusher channels event dat socketId timestamp =   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)+          [ ("name", A.String event),+            ("channels", A.toJSON (map A.String channels)),+            ("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 10000 bytes long")-  return (mkPostRequest pusher "events" [] bodyBS time, body)+   in (mkPostRequest pusher "events" [] bodyBS timestamp, body)  mkChannelsRequest ::-     Pusher-  -> Maybe ChannelType-  -> T.Text-  -> ChannelsInfoQuery-  -> Int-  -> RequestParams-mkChannelsRequest pusher channelTypeFilter prefixFilter attributes time =-  let prefix = maybe "" renderChannelPrefix channelTypeFilter <> prefixFilter-      params =-        [ ("info", encodeUtf8 $ toURLParam attributes)-        , ("filter_by_prefix", encodeUtf8 prefix)+  Pusher ->+  T.Text ->+  ChannelsInfoQuery ->+  Word64 ->+  RequestParams+mkChannelsRequest pusher prefixFilter attributes timestamp =+  let params =+        [ ("info", Just $ encodeUtf8 $ toURLParam attributes),+          ("filter_by_prefix", Just $ encodeUtf8 prefixFilter)         ]-  in mkGetRequest pusher "channels" params time+   in mkGetRequest pusher "channels" params timestamp  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--mkUsersRequest :: Pusher -> Channel -> Int -> RequestParams-mkUsersRequest pusher chan time =-  let subPath = "channels/" <> renderChannel chan <> "/users"-  in mkGetRequest pusher subPath [] time+  Pusher -> B.ByteString -> ChannelInfoQuery -> Word64 -> RequestParams+mkChannelRequest pusher chan attributes timestamp =+  let params = [("info", Just $ encodeUtf8 $ toURLParam attributes)]+      subPath = "channels/" <> chan+   in mkGetRequest pusher subPath params timestamp -mkNotifyRequest ::-     Pusher-  -> Notification-  -> Int-  -> Either PusherError (RequestParams, RequestBody)-mkNotifyRequest pusher notification time = do-  let body = A.toJSON notification-      bodyBS = BL.toStrict $ A.encode body-  when (B.length bodyBS > 10000) $-    Left $ PusherArgumentError "Body must be less than 10000KB"-  return $ (mkNotifyPostRequest pusher "notifications" [] bodyBS time, body)+mkUsersRequest :: Pusher -> B.ByteString -> Word64 -> RequestParams+mkUsersRequest pusher chan timestamp =+  let subPath = "channels/" <> chan <> "/users"+   in mkGetRequest pusher subPath [] timestamp -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+mkGetRequest ::+  Pusher ->+  B.ByteString ->+  Query ->+  Word64 ->+  RequestParams+mkGetRequest pusher subPath params = mkRequest pusher "GET" subPath params ""  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--mkNotifyPostRequest ::-     Pusher-  -> T.Text-  -> RequestQueryString-  -> B.ByteString-  -> Int-  -> RequestParams-mkNotifyPostRequest pusher subPath params bodyBS time =-  let (ep, fullPath) = mkNotifyEndpoint 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 ::-     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)---- |Build a full endpoint for push notifications from the details in Pusher and--- the subPath.-mkNotifyEndpoint ::-     Pusher-  -> T.Text -- ^ The subpath of the specific request.-  -> (T.Text, T.Text) -- ^ The full endpoint and just the path component.-mkNotifyEndpoint pusher subPath =-  let fullPath = pusherNotifyPath pusher <> subPath-      endpoint = pusherNotifyHost pusher <> fullPath-  in (endpoint, fullPath)+  Pusher ->+  B.ByteString ->+  Query ->+  B.ByteString ->+  Word64 ->+  RequestParams+mkPostRequest pusher = mkRequest pusher "POST" -mkQS ::-     Pusher-  -> T.Text-  -> T.Text-  -> RequestQueryString-  -> B.ByteString-  -> Int-  -> RequestQueryString-mkQS pusher =-  let credentials = pusherCredentials pusher-  in makeQS (credentialsAppKey credentials) (credentialsAppSecret credentials)+mkRequest ::+  Pusher ->+  B.ByteString ->+  B.ByteString ->+  Query ->+  B.ByteString ->+  Word64 ->+  RequestParams+mkRequest pusher method subPath params bodyBS timestamp =+  let useTLS = pUseTLS pusher+      host = pHost pusher+      port = pPort pusher+      path = pPath pusher <> subPath+      qs = makeQS (pToken pusher) method path params bodyBS timestamp+   in RequestParams useTLS host port path qs

@@ -1,143 +1,128 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-|-Module      : Network.Pusher.Internal.Auth-Description : Functions to perform authentication (generate auth signatures)-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental--This module contains helper functions for authenticating HTTP requests, as well-as publically facing functions for authentication private and presence channel-users; these functions are re-exported in the main Pusher module.--}+-- |+-- Module      : Network.Pusher.Internal.Auth+-- Description : Functions to perform authentication (generate auth signatures)+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable+--+-- This module contains helper functions for authenticating HTTP requests, as+-- well as publicly facing functions for authentication private and presence+-- channel users; these functions are re-exported in the main Pusher module. module Network.Pusher.Internal.Auth-  ( AuthString-  , AuthSignature-  , authenticatePresence-  , authenticatePresenceWithEncoder-  , authenticatePrivate-  , makeQS-  ) where+  ( authenticatePresence,+    authenticatePresenceWithEncoder,+    authenticatePrivate,+    makeQS,+  )+where -import qualified Data.Aeson as A-import Data.Char (toLower)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import Data.Text.Encoding (encodeUtf8)-import GHC.Exts (sortWith)-#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 as Hash import qualified Crypto.MAC.HMAC as HMAC+import qualified Data.Aeson as A+import qualified Data.Aeson.Text as A+import Data.Bifunctor (first) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BC+import Data.Char (toLower) import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL--import Network.Pusher.Data-       (AppKey, AppSecret, Channel, Credentials(..), SocketID,-        renderChannel)-import Network.Pusher.Internal.HTTP (RequestQueryString)+import Data.Word (Word64)+import GHC.Exts (sortWith)+import Network.HTTP.Types (Query)+import Network.Pusher.Data (Token (..)) import Network.Pusher.Internal.Util (show') --- |Generate the required query string parameters required to send API requests--- to Pusher.+-- | Generate the required query string parameters required to send API requests+--  to Pusher. makeQS ::-     AppKey-  -> AppSecret-  -> T.Text-  -> T.Text-  -> RequestQueryString -- ^Any additional parameters.-  -> B.ByteString-  -> Int -- ^Current UNIX timestamp.-  -> RequestQueryString-makeQS appKey appSecret method fullPath params body ts-    -- Generate all required parameters and add them to the list of existing ones-    -- Parameters are:-    -- - In alphabetical order-    -- - Keys are lower case- =+  Token ->+  B.ByteString ->+  B.ByteString ->+  -- | Any additional parameters.+  Query ->+  B.ByteString ->+  Word64 ->+  Query+makeQS token method path params body timestamp =+  -- Generate all required parameters and add them to the list of existing ones+  -- Parameters are:+  -- - In alphabetical order+  -- - Keys are lower case   let allParams =         alphabeticalOrder . lowercaseKeys . (params ++) $-        [ ("auth_key", appKey)-        , ("auth_timestamp", show' ts)-        , ("auth_version", "1.0")-        , ( "body_md5"-          , B16.encode $ BA.convert (Hash.hash body :: Hash.Digest Hash.MD5))-        ]-    -- Generate the auth signature from the list of parameters-    -- - Method name is upper case-      authSig =-        authSignature appSecret $-        B.intercalate-          "\n"-          [ encodeUtf8 . T.toUpper $ method-          , encodeUtf8 fullPath-          , formQueryString allParams+          [ ("auth_key", Just $ tokenKey token),+            ("auth_timestamp", Just $ show' timestamp),+            ("auth_version", Just "1.0"),+            ( "body_md5",+              Just+                $ B16.encode+                $ BA.convert (Hash.hash body :: Hash.Digest Hash.MD5)+            )           ]-    -- Add the auth string to the list-  in ("auth_signature", authSig) : allParams+      -- Generate the auth signature from the list of parameters+      authSig =+        authSignature (tokenSecret token) $+          B.intercalate+            "\n"+            [method, path, formQueryString allParams]+   in -- Add the auth string to the list+      (("auth_signature", Just authSig) : allParams)   where     alphabeticalOrder = sortWith fst-    lowercaseKeys = map (\(k, v) -> (BC.map toLower k, v))---- |Render key-value tuple mapping of query string parameters into a string.-formQueryString :: RequestQueryString -> B.ByteString-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+    lowercaseKeys = map (first (BC.map toLower)) --- |A Pusher auth signature.-type AuthSignature = B.ByteString+-- | Render key-value tuple mapping of query string parameters into a string.+formQueryString :: Query -> B.ByteString+formQueryString = B.intercalate "&" . map formQueryItem+  where+    formQueryItem (k, Just v) = k <> "=" <> v+    formQueryItem (k, Nothing) = k --- |Create a Pusher auth signature of a string using the provided credentials.-authSignature :: AppSecret -> AuthString -> AuthSignature+-- | Create a Pusher auth signature of a string using the provided credentials.+authSignature :: B.ByteString -> B.ByteString -> B.ByteString authSignature appSecret authString =   B16.encode $-  BA.convert (HMAC.hmac appSecret authString :: HMAC.HMAC Hash.SHA256)+    BA.convert (HMAC.hmac appSecret authString :: HMAC.HMAC Hash.SHA256) --- |Generate an auth signature of the form "app_key:auth_sig" for a user of a--- private channel.-authenticatePrivate :: Credentials -> SocketID -> Channel -> AuthSignature-authenticatePrivate cred socketID channel =+-- | Generate an auth signature of the form "app_key:auth_sig" for a user of a+--  private channel.+authenticatePrivate :: Token -> T.Text -> T.Text -> B.ByteString+authenticatePrivate token socketID channel =   let sig =         authSignature-          (credentialsAppSecret cred)-          (encodeUtf8 $ socketID <> ":" <> renderChannel channel)-  in credentialsAppKey cred <> ":" <> sig+          (tokenSecret token)+          (encodeUtf8 $ socketID <> ":" <> channel)+   in tokenKey token <> ":" <> sig --- |Generate an auth signature of the form "app_key:auth_sig" for a user of a--- presence channel.+-- | 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+  A.ToJSON a => Token -> T.Text -> T.Text -> a -> B.ByteString authenticatePresence =   authenticatePresenceWithEncoder     (TL.toStrict . TL.toLazyText . A.encodeToTextBuilder . A.toJSON) --- |As above, but allows the encoder of the user data to be specified. This is--- useful for testing because the encoder can be mocked; aeson's encoder enodes--- JSON object fields in arbitrary orders, which makes it impossible to test.+-- | As above, but allows the encoder of the user data to be specified. This is+--  useful for testing because the encoder can be mocked; aeson's encoder enodes+--  JSON object fields in arbitrary orders, which makes it impossible to test. authenticatePresenceWithEncoder ::-     (a -> T.Text) -- ^The encoder of the user data.-  -> Credentials-  -> SocketID-  -> Channel-  -> a-  -> AuthSignature-authenticatePresenceWithEncoder userEncoder cred socketID channel userData =+  -- | The encoder of the user data.+  (a -> T.Text) ->+  Token ->+  T.Text ->+  T.Text ->+  a ->+  B.ByteString+authenticatePresenceWithEncoder userEncoder token socketID channel userData =   let authString =         encodeUtf8 $-        socketID <> ":" <> renderChannel channel <> ":" <> userEncoder userData-      sig = authSignature (credentialsAppSecret cred) authString-  in credentialsAppKey cred <> ":" <> sig+          socketID <> ":" <> channel <> ":" <> userEncoder userData+      sig = authSignature (tokenSecret token) authString+   in tokenKey token <> ":" <> sig

@@ -1,120 +1,135 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections #-} -{-|-Module      : Network.Pusher.Internal.HTTP-Description : Functions for issuing HTTP requests-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental--A layer on top of the HTTP functions in the Wreq library which lifts the return-values to the typclasses we are using in this library. Non 200 responses are-converted into MonadError errors.--}+-- |+-- Module      : Network.Pusher.Internal.HTTP+-- Description : Functions for issuing HTTP requests+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable+--+-- A layer on top of the HTTP functions in the http-client library which lifts+-- the return values to the typeclasses we are using in this library. Non 200+-- responses are converted into MonadError errors. module Network.Pusher.Internal.HTTP-  ( RequestParams(..)-  , RequestQueryString-  , RequestBody-  , get-  , post-  ) where+  ( RequestParams (..),+    get,+    post,+  )+where -import Control.Arrow (second) import Control.Exception (displayException) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Except (ExceptT(ExceptT), throwE) import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8')+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding (decodeUtf8')+import Data.Word (Word16) import qualified Network.HTTP.Client as HTTP.Client+import Network.HTTP.Types (Query) import Network.HTTP.Types.Header (hContentType) import Network.HTTP.Types.Method (methodPost)-import Network.HTTP.Types.Status (statusCode, statusMessage)--import Network.Pusher.Error (PusherError(..))--data RequestParams = RequestParams-  { requestEndpoint :: T.Text-  -- ^The API endpoint, for example http://api.pusherapp.com/apps/123/events.-  , requestQueryString :: RequestQueryString-  -- ^List of query string parameters as key-value tuples.-  } deriving (Show)--type RequestQueryString = [(B.ByteString, B.ByteString)]+import Network.HTTP.Types.Status (statusCode)+import Network.Pusher.Error (PusherError (..)) -type RequestBody = A.Value+data RequestParams+  = RequestParams+      { -- | The API endpoint, for example http://api.pusherapp.com/apps/123/events.+        requestSecure :: Bool,+        requestHost :: B.ByteString,+        requestPort :: Word16,+        requestPath :: B.ByteString,+        -- | List of query string parameters as key-value tuples.+        requestQueryString :: Query+      }+  deriving (Show) --- |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.+-- | 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-  => HTTP.Client.Manager-  -> RequestParams-  -> ExceptT PusherError IO a -- ^The body of the response.-get connManager (RequestParams ep qs) = do-  req <- ExceptT $ return $ mkRequest ep qs-  resp <- doRequest connManager req-  either-    (throwE . PusherInvalidResponseError . T.pack)-    return-    (A.eitherDecode resp)+  A.FromJSON a =>+  HTTP.Client.Manager ->+  RequestParams ->+  IO (Either PusherError a)+get connManager (RequestParams secure host port path query) = do+  let req = mkRequest secure host port path query+  eitherBody <- doRequest connManager req+  return $ case eitherBody of+    Left requestError -> Left requestError+    Right body ->+      case A.eitherDecode body of+        Left decodeError ->+          Left $ InvalidResponse $+            let bodyText = decodeUtf8' body+             in case bodyText of+                  Left e ->+                    "Failed to decode body as UTF-8: "+                      <> T.pack (displayException e)+                  Right b ->+                    "Failed to decode response as JSON: "+                      <> T.pack decodeError+                      <> ". Body: "+                      <> TL.toStrict b+        Right decodedBody -> Right decodedBody --- |Issue an HTTP POST request.+-- | Issue an HTTP POST request. post ::-     A.ToJSON a-  => 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-  _ <- doRequest connManager req-  return ()+  A.ToJSON a =>+  HTTP.Client.Manager ->+  RequestParams ->+  a ->+  IO (Either PusherError ())+post connManager (RequestParams secure host port path query) body = do+  let req = mkPost (A.encode body) (mkRequest secure host port path query)+  eitherBody <- doRequest connManager req+  return $ either Left (const $ Right ()) eitherBody  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+  Bool ->+  B.ByteString ->+  Word16 ->+  B.ByteString ->+  Query ->+  HTTP.Client.Request+mkRequest secure host port path query =+  HTTP.Client.setQueryString query $+    HTTP.Client.defaultRequest+      { HTTP.Client.secure = secure,+        HTTP.Client.host = host,+        HTTP.Client.port = fromIntegral port,+        HTTP.Client.path = path+      } -#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+    }  doRequest ::-     HTTP.Client.Manager-  -> HTTP.Client.Request-  -> ExceptT PusherError IO BL.ByteString+  HTTP.Client.Manager ->+  HTTP.Client.Request ->+  IO (Either PusherError BL.ByteString) doRequest connManager req = do   response <- liftIO $ HTTP.Client.httpLbs req connManager   let status = HTTP.Client.responseStatus response-      code = statusCode status-      bodyBs :: BL.ByteString-      bodyBs = HTTP.Client.responseBody response-  if code `elem` [200, 202]-    then return bodyBs-    else let decoded = decodeUtf8' $ statusMessage status-         in throwE $-            either-              (PusherInvalidResponseError . T.pack . displayException)-              PusherNon200ResponseError-              decoded+  let body = HTTP.Client.responseBody response+  return $+    if statusCode status == 200+      then Right body+      else+        Left $+          let bodyText = decodeUtf8' body+           in case bodyText of+                Left e ->+                  InvalidResponse $+                    "Failed to decode body as UTF-8: "+                      <> T.pack (displayException e)+                Right b ->+                  Non200Response+                    (fromIntegral $ statusCode status)+                    (TL.toStrict b)

@@ -1,51 +1,26 @@-{-|-Module      : Network.Pusher.Internal.Util-Description : Various utilty functions-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental--}+-- |+-- Module      : Network.Pusher.Internal.Util+-- Description : Various utility functions+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable module Network.Pusher.Internal.Util-  ( failExpectObj-  , failExpectArray-  , failExpectStr-  , failExpectSingletonArray-  , getTime-  , show'-  ) where+  ( show',+    getSystemTimeSeconds,+  )+where -import qualified Data.Aeson as A-import qualified Data.Aeson.Types as A+import Control.Monad.IO.Class (MonadIO, liftIO) import Data.String (IsString, fromString)-import Data.Time.Clock.POSIX (getPOSIXTime)---- |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.-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 array was expected, but it was a different type of data.-failExpectArray :: A.Value -> A.Parser a-failExpectArray = fail . ("Expected JSON array, got " ++) . show---- |When decoding Aeson values, this can be used to return a failing parser--- when an array of length exactly one was expected but it was a different type--- of data.-failExpectSingletonArray :: A.Value -> A.Parser a-failExpectSingletonArray =-  fail . ("Expected JSON array with exactly one 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+import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime)+import Data.Word (Word64) --- |Generalised version of show.+-- | Generalised version of show. show' :: (Show a, IsString b) => a -> b show' = fromString . show++getSystemTimeSeconds :: MonadIO m => m Word64+getSystemTimeSeconds = do+  t <- liftIO getSystemTime+  return $ fromIntegral $ systemSeconds t

@@ -1,32 +1,31 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TupleSections #-} -{-|-Module      : Network.Pusher.Protocol-Description : Types representing Pusher messages-Copyright   : (c) Will Sewell, 2016-Licence     : MIT-Maintainer  : me@willsewell.com-Stability   : experimental--Types representing the JSON format of Pusher messages.--There are also types for query string parameters.--}+-- |+-- Module      : Network.Pusher.Protocol+-- Description : Types representing Pusher messages+-- Copyright   : (c) Will Sewell, 2016+-- Licence     : MIT+-- Maintainer  : me@willsewell.com+-- Stability   : stable+--+-- Types representing the JSON format of Pusher messages.+--+-- There are also types for query string parameters. module Network.Pusher.Protocol-  ( ChannelInfo(..)-  , ChannelInfoAttributes(..)-  , ChannelInfoQuery(..)-  , ChannelsInfo(..)-  , ChannelsInfoQuery(..)-  , ChannelsInfoAttributes(..)-  , FullChannelInfo(..)-  , User(..)-  , Users(..)-  , ToURLParam-  , toURLParam-  ) where+  ( ChannelInfo (..),+    ChannelInfoAttributes (..),+    ChannelInfoQuery (..),+    ChannelsInfo (..),+    ChannelsInfoQuery (..),+    ChannelsInfoAttributes (..),+    FullChannelInfo (..),+    User (..),+    Users (..),+    ToURLParam,+    toURLParam,+  )+where  import Data.Aeson ((.:), (.:?)) import qualified Data.Aeson as A@@ -36,16 +35,13 @@ import qualified Data.Text as T import GHC.Generics (Generic) -import Network.Pusher.Data (Channel, parseChannel)-import Network.Pusher.Internal.Util (failExpectObj)---- |Types that can be serialised to a querystring parameter value.+-- | Types that can be serialised to a querystring parameter value. class ToURLParam a where   toURLParam :: a -> T.Text --- |Enumeration of the attributes that can be queried about multiple channels.-data ChannelsInfoAttributes =-  ChannelsUserCount+-- | Enumeration of the attributes that can be queried about multiple channels.+data ChannelsInfoAttributes+  = ChannelsUserCount   deriving (Eq, Generic)  instance ToURLParam ChannelsInfoAttributes where@@ -53,12 +49,12 @@  instance Hashable ChannelsInfoAttributes --- |A set of requested 'ChannelsInfoAttributes'.-newtype ChannelsInfoQuery =-  ChannelsInfoQuery (HS.HashSet ChannelsInfoAttributes)+-- | A set of requested 'ChannelsInfoAttributes'.+newtype ChannelsInfoQuery+  = ChannelsInfoQuery (HS.HashSet ChannelsInfoAttributes)   deriving (ToURLParam) --- |Enumeration of the attributes that can be queried about a single channel.+-- | Enumeration of the attributes that can be queried about a single channel. data ChannelInfoAttributes   = ChannelUserCount   | ChannelSubscriptionCount@@ -70,74 +66,74 @@  instance Hashable ChannelInfoAttributes --- |A set of requested 'ChannelInfoAttributes'.-newtype ChannelInfoQuery =-  ChannelInfoQuery (HS.HashSet ChannelInfoAttributes)+-- | A set of requested 'ChannelInfoAttributes'.+newtype ChannelInfoQuery+  = ChannelInfoQuery (HS.HashSet ChannelInfoAttributes)   deriving (ToURLParam)  instance ToURLParam a => ToURLParam (HS.HashSet a) where   toURLParam hs = T.intercalate "," $ toURLParam <$> HS.toList hs --- |A map of channels to their 'ChannelInfo'. The result of querying channel--- info from multuple channels.-newtype ChannelsInfo =-  ChannelsInfo (HM.HashMap Channel ChannelInfo)+-- | A map of channels to their 'ChannelInfo'. The result of querying channel+--  info from multiple channels.+newtype ChannelsInfo+  = ChannelsInfo (HM.HashMap T.Text ChannelInfo)   deriving (Eq, Show)  instance A.FromJSON ChannelsInfo where-  parseJSON (A.Object v) = do-    chansV <- v .: "channels"-    case chansV of-      A.Object cs-        -- Need to go to and from list in order to map (parse) the keys-       ->-        ChannelsInfo . HM.fromList <$>-        mapM-          (\(channel, info) -> (parseChannel channel, ) <$> A.parseJSON info)-          (HM.toList cs)-      v1 -> failExpectObj v1-  parseJSON v2 = failExpectObj v2+  parseJSON =+    A.withObject "ChannelsInfo" $ \v -> do+      channelsV <- v .: "channels"+      A.withObject+        "HashMap"+        (fmap ChannelsInfo . mapM A.parseJSON)+        channelsV --- |The possible returned channel attributes when multiple when multiple--- channels are queried.-newtype ChannelInfo = ChannelInfo-  { channelInfoUserCount :: Maybe Int-  } deriving (Eq, Show)+-- | The possible returned channel attributes when multiple when multiple+--  channels are queried.+newtype ChannelInfo+  = ChannelInfo+      { channelInfoUserCount :: Maybe Int+      }+  deriving (Eq, Show)  instance A.FromJSON ChannelInfo where-  parseJSON (A.Object v) = ChannelInfo <$> v .:? "user_count"-  parseJSON v = failExpectObj v+  parseJSON =+    A.withObject "ChannelInfo" $ \v -> ChannelInfo <$> v .:? "user_count" --- |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)+-- | 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) =-    FullChannelInfo <$> v .: "occupied" <*> v .:? "user_count" <*>-    v .:? "subscription_count"-  parseJSON v = failExpectObj v+  parseJSON =+    A.withObject "FullChannelInfo" $ \v ->+      FullChannelInfo <$> v .: "occupied" <*> v .:? "user_count"+        <*> v .:? "subscription_count" --- |A list of users returned by querying for users in a presence channel.-newtype Users =-  Users [User]+-- | A list of users returned by querying for users in a presence channel.+newtype Users+  = Users [User]   deriving (Eq, Show)  instance A.FromJSON Users where-  parseJSON (A.Object v) = do-    users <- v .: "users"-    Users <$> A.parseJSON users-  parseJSON v = failExpectObj v+  parseJSON =+    A.withObject "FullChannelInfo" $ \v -> do+      users <- v .: "users"+      Users <$> A.parseJSON users --- |The data about a user returned when querying for users in a presence--- channel.-newtype 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"-  parseJSON v = failExpectObj v+  parseJSON = A.withObject "FullChannelInfo" $ \v -> User <$> v .: "id"

@@ -1,156 +1,138 @@ module Network.Pusher.Webhook-  ( Webhooks(..)-  , WebhookEv(..)-  , WebhookPayload(..)-  , parseAppKeyHdr-  , parseAuthSignatureHdr-  , parseWebhooksBody-  , verifyWebhooksBody-  , parseWebhookPayloadWith-  ) where+  ( Webhooks (..),+    WebhookEv (..),+    WebhookPayload (..),+    parseAppKeyHdr,+    parseAuthSignatureHdr,+    parseWebhooksBody,+    verifyWebhooksBody,+    parseWebhookPayloadWith,+  )+where  import qualified Crypto.Hash as HASH import qualified Crypto.MAC.HMAC as HMAC import Data.Aeson ((.:)) import qualified Data.Aeson as A-import Data.ByteArray+import Data.ByteArray (convert)+import qualified Data.ByteString as B import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BC import Data.ByteString.Lazy (fromStrict) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (toLower) import Data.Function (on)-import Data.Maybe (mapMaybe)-import Data.Text (Text)-import Data.Text.Encoding-import Data.Time (UTCTime(..))-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Network.Pusher.Data-       (AppKey, AppSecret, Channel(..), SocketID)-import Network.Pusher.Internal.Auth (AuthSignature)-import Network.Pusher.Internal.Util-import Network.Pusher.Protocol (User(..))+import Data.Maybe (listToMaybe, mapMaybe)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word64)+import Network.Pusher.Protocol (User (..)) --- |A Webhook is received by POST request from Pusher to notify your server of--- a number of 'WebhookEv's. Multiple events are received under the same--- timestamp if batch events is enabled.-data Webhooks = Webhooks-  { timeMs :: UTCTime-  , webhookEvs :: [WebhookEv]-  } deriving (Eq, Show)+-- | A Webhook is received by POST request from Pusher to notify your server of+--  a number of 'WebhookEv's. Multiple events are received under the same+--  timestamp if batch events is enabled.+data Webhooks+  = Webhooks+      { timeMs :: Word64,+        webhookEvs :: [WebhookEv]+      }+  deriving (Eq, Show)  instance A.FromJSON Webhooks where-  parseJSON o =-    case o of-      A.Object v ->-        Webhooks <$> (_unOurTime <$> A.parseJSON o) <*> (v .: "events")-      _ -> failExpectObj o---- |Exists only so we can define our own 'FromJSON' instance on--- 'NominalDiffTime'. This is useful because it didnt exist before a certain--- GHC version that we support and allows us to avoid CPP and orphan instances.-newtype OurTime = OurTime-  { _unOurTime :: UTCTime-  }--instance A.FromJSON OurTime where-  parseJSON o =-    case o of-      A.Object v ->-        A.withScientific-          "NominalDiffTime"-          (pure . OurTime . posixSecondsToUTCTime . realToFrac) =<<-        v .: "time_ms"-      _ -> failExpectObj o+  parseJSON =+    A.withObject "Webhooks" $ \v ->+      Webhooks <$> v .: "time_ms" <*> v .: "events" --- |A 'WebhookEv' is one of several events Pusher may send to your server in--- response to events your users may trigger.+-- | A 'WebhookEv' is one of several events Pusher may send to your server in+--  response to events your users may trigger. data WebhookEv-  -- |A channel has become occupied. There is > 1 subscriber.-  = ChannelOccupiedEv { onChannel :: Channel }-  -- |A channel has become vacated. There are 0 subscribers.-  | ChannelVacatedEv { onChannel :: Channel }-  -- |A new user has subscribed to a presence channel.-  | MemberAddedEv { onChannel :: Channel-                  , withUser :: User }-  -- |A user has unsubscribed from a presence channel.-  | MemberRemovedEv { onChannel :: Channel-                    , withUser :: User }-  -- |A client has sent a named client event with some json body. They have a-  -- 'SocketID' and a 'User' if they were in a presence channel.-  | ClientEv { onChannel :: Channel-             , clientEvName :: Text-             , clientEvBody :: Maybe A.Value-             , withSocketId :: SocketID-             , withPossibleUser :: Maybe User }+  = -- | A channel has become occupied. There is > 1 subscriber.+    ChannelOccupiedEv {onChannel :: T.Text}+  | -- | A channel has become vacated. There are 0 subscribers.+    ChannelVacatedEv {onChannel :: T.Text}+  | -- | A new user has subscribed to a presence channel.+    MemberAddedEv+      { onChannel :: T.Text,+        withUser :: User+      }+  | -- | A user has unsubscribed from a presence channel.+    MemberRemovedEv+      { onChannel :: T.Text,+        withUser :: User+      }+  | -- | A client has sent a named client event with some json body. They have a+    --  socket_id and a 'User' if they were in a presence channel.+    ClientEv+      { onChannel :: T.Text,+        clientEvName :: T.Text,+        clientEvBody :: Maybe A.Value,+        withSocketId :: T.Text,+        withPossibleUser :: Maybe User+      }   deriving (Eq, Show)  instance A.FromJSON WebhookEv where-  parseJSON o =-    case o of-      A.Object v -> do-        name <- v .: "name"-        case name :: Text of-          "channel_occupied" -> ChannelOccupiedEv <$> v .: "channel"-          "channel_vacated" -> ChannelVacatedEv <$> v .: "channel"-          "member_added" ->-            MemberAddedEv <$> v .: "channel" <*> (User <$> v .: "user_id")-          "member_removed" ->-            MemberRemovedEv <$> v .: "channel" <*> (User <$> v .: "user_id")-          "client_event" ->-            ClientEv <$> v .: "channel" <*> v .: "event" <*>-            (A.decode . LB.fromStrict . encodeUtf8 <$> v .: "data") <*>-            v .: "socket_id" <*>-            (fmap User <$> v .: "user_id")-          _ -> fail . ("Unknown client event. Got: " ++) . show $ o-      _ -> failExpectObj o+  parseJSON =+    A.withObject "Webhooks" $ \v -> do+      name <- v .: "name"+      case name :: T.Text of+        "channel_occupied" -> ChannelOccupiedEv <$> v .: "channel"+        "channel_vacated" -> ChannelVacatedEv <$> v .: "channel"+        "member_added" ->+          MemberAddedEv <$> v .: "channel" <*> (User <$> v .: "user_id")+        "member_removed" ->+          MemberRemovedEv <$> v .: "channel" <*> (User <$> v .: "user_id")+        "client_event" ->+          ClientEv <$> v .: "channel" <*> v .: "event"+            <*> (A.decode . LB.fromStrict . encodeUtf8 <$> v .: "data")+            <*> v .: "socket_id"+            <*> (fmap User <$> v .: "user_id")+        _ -> fail . ("Unknown client event. Got: " ++) . show $ v -data WebhookPayload = WebhookPayload {-    xPusherKey :: AppKey-  -- ^Authentication header. The oldest active token is used, identified by-  -- this key.-  , xPusherSignature :: AuthSignature-  -- ^A HMAC SHA256 formed by signing the payload with the tokens secret.-  , webhooks :: Webhooks-  } deriving (Eq, Show)+data WebhookPayload+  = WebhookPayload+      { -- | Authentication header. The oldest active token is used, identified by+        --  this key.+        xPusherKey :: B.ByteString,+        -- | A HMAC SHA256 formed by signing the payload with the tokens secret.+        xPusherSignature :: B.ByteString,+        webhooks :: Webhooks+      }+  deriving (Eq, Show) --- |Given a HTTP Header and its associated value, parse an 'AppKey'.-parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe AppKey+-- | Given a HTTP Header and its associated value, parse an app key.+parseAppKeyHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString parseAppKeyHdr key value   | on (==) (BC.map toLower) key "X-Pusher-Key" = Just value   | otherwise = Nothing --- |Given a HTTP Header and its associated value, parse a 'AuthSignature'.-parseAuthSignatureHdr :: BC.ByteString -> BC.ByteString -> Maybe AuthSignature+-- | Given a HTTP Header and its associated value, parse an auth signature.+parseAuthSignatureHdr :: BC.ByteString -> BC.ByteString -> Maybe B.ByteString parseAuthSignatureHdr key value   | on (==) (BC.map toLower) key "X-Pusher-Signature" = Just value   | otherwise = Nothing --- |Given a HTTP body, parse the contained webhooks.+-- | Given a HTTP body, parse the contained webhooks. parseWebhooksBody :: BC.ByteString -> Maybe Webhooks parseWebhooksBody = A.decode . fromStrict --- |Does a webhook body hash with our secret key to the given signature?-verifyWebhooksBody :: AppSecret -> AuthSignature -> BC.ByteString -> Bool+-- | Does a webhook body hash with our secret key to the given signature?+verifyWebhooksBody :: B.ByteString -> B.ByteString -> BC.ByteString -> Bool verifyWebhooksBody appSecret authSignature body =   let actualSignature =         B16.encode $ convert (HMAC.hmac appSecret body :: HMAC.HMAC HASH.SHA256)-  in authSignature == actualSignature--safeHead :: [a] -> Maybe a-safeHead (x:_) = Just x-safeHead _ = Nothing+   in authSignature == actualSignature --- |Given a list of http header key:values, a http body and a lookup function--- for an apps secret, parse and validate a  potential webhook payload.+-- | Given a list of http header key:values, a http body and a lookup function+--  for an apps secret, parse and validate a  potential webhook payload. parseWebhookPayloadWith ::-     (AppKey -> Maybe AppSecret)-  -> [(BC.ByteString, BC.ByteString)]-  -> BC.ByteString-  -> Maybe WebhookPayload+  (B.ByteString -> Maybe B.ByteString) ->+  [(BC.ByteString, BC.ByteString)] ->+  BC.ByteString ->+  Maybe WebhookPayload parseWebhookPayloadWith lookupKeysSecret headers body = do-  appKey <- safeHead . mapMaybe (uncurry parseAppKeyHdr) $ headers-  authSignature <- safeHead . mapMaybe (uncurry parseAuthSignatureHdr) $ headers+  appKey <- listToMaybe . mapMaybe (uncurry parseAppKeyHdr) $ headers+  authSignature <- listToMaybe . mapMaybe (uncurry parseAuthSignatureHdr) $ headers   appSecret <- lookupKeysSecret appKey   () <-     if verifyWebhooksBody appSecret authSignature body

@@ -1,56 +1,58 @@ module Auth where -import Test.Hspec (Spec, describe, it, shouldBe)--import Network.Pusher-       (Channel(..), ChannelType(Presence, Private), Credentials(..))+import Network.Pusher (Token (..)) import Network.Pusher.Internal.Auth-       (authenticatePresenceWithEncoder, authenticatePrivate, makeQS)+  ( authenticatePresenceWithEncoder,+    authenticatePrivate,+    makeQS,+  )+import Test.Hspec (Spec, describe, it, shouldBe)  test :: Spec test = do-  describe "Auth.makeQS" $-    it "works" $-      -- Happy case based on data from the docs: https://pusher.com/docs/channels/library_auth_reference/auth-signatures#worked-example+  describe "Auth.makeQS"+    $ it "works"+    $+    -- Happy case based on data from the docs: https://pusher.com/docs/channels/library_auth_reference/auth-signatures#worked-example     let body =           "{\"name\":\"foo\",\"channels\":[\"project-3\"],\"data\":\"{\\\"some\\\":\\\"data\\\"}\"}"-    in makeQS-         (credentialsAppKey credentials)-         (credentialsAppSecret credentials)-         "POST"-         "/apps/3/events"-         []-         body-         1353088179 `shouldBe`-       [ ( "auth_signature"-         , "da454824c97ba181a32ccc17a72625ba02771f50b50e1e7430e47a1f3f457e6c")-       , ("auth_key", "278d425bdf160c739803")-       , ("auth_timestamp", "1353088179")-       , ("auth_version", "1.0")-       , ("body_md5", "ec365a775a4cd0599faeb73354201b6f")-       ]-  describe "Auth.authenticatePrivate" $-    it "works" $-      -- Data from https://pusher.com/docs/channels/library_auth_reference/auth-signatures#worked-example-    authenticatePrivate credentials "1234.1234" (Channel Private "foobar") `shouldBe`-    "278d425bdf160c739803:58df8b0c36d6982b82c3ecf6b4662e34fe8c25bba48f5369f135bf843651c3a4"-  describe "Auth.authenticatePresenceWithEncoder" $-    it "works for presence channels" $-      -- Data from https://pusher.com/docs/channels/library_auth_reference/auth-signatures#presence-channels+     in makeQS+          token+          "POST"+          "/apps/3/events"+          []+          body+          1353088179+          `shouldBe` [ ( "auth_signature",+                         Just "da454824c97ba181a32ccc17a72625ba02771f50b50e1e7430e47a1f3f457e6c"+                       ),+                       ("auth_key", Just "278d425bdf160c739803"),+                       ("auth_timestamp", Just "1353088179"),+                       ("auth_version", Just "1.0"),+                       ("body_md5", Just "ec365a775a4cd0599faeb73354201b6f")+                     ]+  describe "Auth.authenticatePrivate"+    $ it "works"+    $+    -- Data from https://pusher.com/docs/channels/library_auth_reference/auth-signatures#worked-example+    authenticatePrivate token "1234.1234" "private-foobar"+      `shouldBe` "278d425bdf160c739803:58df8b0c36d6982b82c3ecf6b4662e34fe8c25bba48f5369f135bf843651c3a4"+  describe "Auth.authenticatePresenceWithEncoder"+    $ it "works for presence channels"+    $+    -- Data from https://pusher.com/docs/channels/library_auth_reference/auth-signatures#presence-channels     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"+     in authenticatePresenceWithEncoder+          (const userData)+          token+          "1234.1234"+          "presence-foobar"+          ("doesn't matter" :: String)+          `shouldBe` "278d425bdf160c739803:afaed3695da2ffd16931f457e338e6c9f2921fa133ce7dac49f529792be6304c" -credentials :: Credentials-credentials =-  Credentials-  { credentialsAppID = 3-  , credentialsAppKey = "278d425bdf160c739803"-  , credentialsAppSecret = "7ad3773142a6692b25b8"-  , credentialsCluster = Nothing-  }+token :: Token+token =+  Token+    { tokenKey = "278d425bdf160c739803",+      tokenSecret = "7ad3773142a6692b25b8"+    }

@@ -1,11 +1,9 @@ module Main where -import Test.Hspec (hspec)- import qualified Auth import qualified Protocol-import qualified Push+import Test.Hspec (hspec) import qualified Webhook  main :: IO ()-main = hspec $ Auth.test >> Protocol.test >> Push.test >> Webhook.test+main = hspec $ Auth.test >> Protocol.test >> Webhook.test

@@ -3,73 +3,68 @@ 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(Presence, Private, Public), parseChannel,-        renderChannel) import Network.Pusher.Protocol-       (ChannelInfo(..), ChannelsInfo(..), FullChannelInfo(..), User(..),-        Users(..))+  ( ChannelInfo (..),+    ChannelsInfo (..),+    FullChannelInfo (..),+    User (..),+    Users (..),+  )+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.QuickCheck (Arbitrary (..), elements) -newtype TestChannel =-  TestChannel Channel+newtype TestChannel+  = TestChannel T.Text   deriving (Show)  instance Arbitrary TestChannel where   arbitrary = do-    let testChannelType = elements [Public, Private, Presence]-        channel = Channel <$> testChannelType <*> (T.pack <$> arbitrary)-    TestChannel <$> channel+    channelPrefix <- elements ["public", "private", "presence"]+    channelSuffix <- T.pack <$> arbitrary+    return $ TestChannel $ channelPrefix <> "-" <> channelSuffix  test :: Spec test = do-  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-  describe "Protocol.ChannelsInfo" $-    it "parsing works" $-      -- Data from https://pusher.com/docs/channels/library_auth_reference/rest-api#successful-response+  describe "Protocol.ChannelsInfo"+    $ it "parsing works"+    $+    -- Data from https://pusher.com/docs/channels/library_auth_reference/rest-api#successful-response     A.decode       "{\-\         \"channels\": {\-\           \"presence-foobar\": {\-\             \"user_count\": 42\-\           },\-\           \"presence-another\": {\-\             \"user_count\": 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/channels/library_auth_reference/rest-api#successful-response+      \  \"channels\": {\+      \    \"presence-foobar\": {\+      \      \"user_count\": 42\+      \    },\+      \    \"presence-another\": {\+      \      \"user_count\": 123\+      \    }\+      \  }\+      \}"+      `shouldBe` Just+        ( ChannelsInfo $+            HM.fromList+              [ ("presence-foobar", ChannelInfo $ Just 42),+                ("presence-another", ChannelInfo $ Just 123)+              ]+        )+  describe "Protocol.FullChannelInfo"+    $ it "parsing works"+    $+    -- Data from https://pusher.com/docs/channels/library_auth_reference/rest-api#successful-response     A.decode       "{\-\         \"occupied\": true,\-\         \"user_count\": 42,\-\         \"subscription_count\": 42\-\       }" `shouldBe`-    (Just $ FullChannelInfo True (Just 42) (Just 42))-  describe "Protocol.Users" $-    it "parsing works" $-    A.decode+      \  \"occupied\": true,\+      \  \"user_count\": 42,\+      \  \"subscription_count\": 42\+      \}"+      `shouldBe` Just (FullChannelInfo True (Just 42) (Just 42))+  describe "Protocol.Users"+    $ it "parsing works"+    $ A.decode       "{\-\         \"users\": [\-\           { \"id\": \"1\" },\-\           { \"id\": \"2\" }\-\         ]\-\       }" `shouldBe`-    (Just $ Users [User "1", User "2"])+      \  \"users\": [\+      \    { \"id\": \"1\" },\+      \    { \"id\": \"2\" }\+      \  ]\+      \}"+      `shouldBe` Just (Users [User "1", User "2"])

@@ -1,354 +0,0 @@-{-# LANGUAGE CPP #-}--module Push where--import Data.Aeson ((.=))-import qualified Data.Aeson as A-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy.Char8 as B-import qualified Data.HashMap.Strict as HM-import Data.Maybe (fromJust)-#if !(MIN_VERSION_base(4,11,0))-import Data.Monoid ((<>))-#endif-import Data.Scientific-import qualified Data.Text as T-import qualified Data.Vector as V--import Test.Hspec (Spec, describe, it)-import Test.QuickCheck-       (Arbitrary(..), Gen, elements, oneof, property, vectorOf)--import Network.Pusher--test :: Spec-test = do-  describe "Interest names" $ do-    it "are accepted when using valid characters" $-      property $ do-        txt <- arbitraryInterestText-        return $-          case mkInterest txt of-            Nothing -> False-            Just _ -> True-    it "are rejected when using invalid characters" $-      property $ do-        txt <- arbitraryInvalidInterestText-        return $-          case mkInterest txt of-            Nothing -> True-            Just _ -> False-  describe "Notification JSON parser" $ do-    it "correctly parses a specific FCM Notification." $-      property $-      let (inputBS, expected) = validFCMDecoding-      in A.decode inputBS == Just expected-    it "Random Notifications JSON parses correctly" $-      property $ \(NotificationDecoding (bs, notification)) ->-        A.decode bs == Just notification-  describe "Notification JSON encoder" $ do-    it "encodes a specific FCM Notification correctly" $-      property $-      let (bs, notification) = validFCMDecoding-      in (A.encode notification) ==-         (A.encode . fromJust . (A.decode :: ByteString -> Maybe Notification) $-          bs)-    it "encodes random Notifications correctly" $-      -- NOTE: We put the expected string through a round trip to normalise trivial-      -- differences such as ordering and spacing in the JSON Aeson generates-      property $ \(NotificationDecoding (bs, notification)) ->-        (A.encode notification) ==-        (A.encode . fromJust . (A.decode :: ByteString -> Maybe Notification) $-         bs)---- A single example of a FCM notification which we expect to aeson decode to--- the paired Notification value.-validFCMDecoding :: (B.ByteString, Notification)-validFCMDecoding =-  let bs =-        B.unlines-          [ "{"-          , "  \"interests\": [\"interestOne\"],"-          , "  \"fcm\": {"-          , "    \"notification\": {"-          , "      \"title\": \"titleText\","-          , "      \"body\": \"bodyText\""-          , "    }"-          , "  }"-          , "}"-          ]-      notification =-        Notification-        { notificationInterest = fromJust . mkInterest $ "interestOne"-        , notificationWebhookURL = Nothing-        , notificationWebhookLevel = Nothing-        , notificationAPNSPayload = Nothing-        , notificationGCMPayload = Nothing-        , notificationFCMPayload =-            Just $-            FCMPayload $-            HM.fromList-              [ ("notification" :: T.Text) .=-                (A.Object $-                 HM.fromList-                   [ ("title" :: T.Text) .= ("titleText" :: T.Text)-                   , ("body" :: T.Text) .= ("bodyText" :: T.Text)-                   ])-              ]-        }-  in (bs, notification)---- A ByteString will decode to some value 'a'.-type Decoding a = (B.ByteString, a)--newtype NotificationDecoding =-  NotificationDecoding (Decoding Notification)-  deriving (Show)--newtype APNSDecoding =-  APNSDecoding (Decoding (Maybe APNSPayload))--newtype FCMDecoding =-  FCMDecoding (Decoding (Maybe FCMPayload))--newtype GCMDecoding =-  GCMDecoding (Decoding (Maybe GCMPayload))--instance Arbitrary APNSDecoding where-  arbitrary = do-    InterestText titleText <- arbitrary-    InterestText bodyText <- arbitrary-    NonRecJSON dataJSON <- arbitrary-    let alert :: A.Object-        alert = HM.fromList ["title" .= titleText, "body" .= bodyText]-        aps :: A.Object-        aps = HM.fromList ["alert" .= alert]-        payload :: A.Object-        payload = HM.fromList ["aps" .= aps, "data" .= dataJSON]-    let apns = APNSPayload payload-        bs :: ByteString-        bs =-          B.unlines-            [ "{"-            , "  \"aps\": {"-            , "    \"alert\": {"-            , "       \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","-            , "       \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""-            , "    }"-            , "  },"-            , "  \"data\": " <> (A.encode dataJSON)-            , "}"-            ]-    return $ APNSDecoding (bs, Just apns)--instance Arbitrary GCMDecoding where-  arbitrary = do-    InterestText titleText <- arbitrary-    InterestText bodyText <- arbitrary-    NonRecJSON dataJSON <- arbitrary-    let notification :: A.Object-        notification = HM.fromList ["title" .= titleText, "body" .= bodyText]-        payload :: A.Object-        payload =-          HM.fromList ["notification" .= notification, "data" .= dataJSON]-        gcm = GCMPayload payload-        bs :: ByteString-        bs =-          B.unlines-            [ "{"-            , "  \"notification\": {"-            , "    \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","-            , "    \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""-            , "  },"-            , "  \"data\": " <> (A.encode dataJSON)-            , "}"-            ]-    return $ GCMDecoding (bs, Just gcm)--instance Arbitrary FCMDecoding where-  arbitrary = do-    InterestText titleText <- arbitrary-    InterestText bodyText <- arbitrary-    NonRecJSON dataJSON <- arbitrary-    let notification :: A.Object-        notification = HM.fromList ["title" .= titleText, "body" .= bodyText]-        payload :: A.Object-        payload =-          HM.fromList ["notification" .= notification, "data" .= dataJSON]-        gcm = FCMPayload payload-        bs :: ByteString-        bs =-          B.unlines-            [ "{"-            , "  \"notification\": {"-            , "    \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","-            , "    \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""-            , "  },"-            , "  \"data\": " <> (A.encode dataJSON)-            , "}"-            ]-    return $ FCMDecoding (bs, Just gcm)--instance Arbitrary NotificationDecoding where-  arbitrary = do-    interestName <- arbitraryInterestText-    APNSDecoding (apnsBS, mAPNS) <- arbitrary-    GCMDecoding (gcmBS, mGCM) <- arbitrary-    FCMDecoding (fcmBS, mFCM) <- arbitrary-    let notification =-          Notification-          { notificationInterest = fromJust . mkInterest $ interestName-          , notificationWebhookURL = Nothing-          , notificationWebhookLevel = Nothing-          , notificationAPNSPayload = mAPNS-          , notificationGCMPayload = mGCM-          , notificationFCMPayload = mFCM-          }-        -- Key value pairs that are required-        requiredFields :: [(ByteString, ByteString)]-        requiredFields =-          [("interests", "[\"" <> (B.pack . T.unpack $ interestName) <> "\"]")]-        -- A function which takes an initial key value pair list and adds Just pairs and skips Nothing values.-        -- Aeson would by default encode this as "value":null which we dont want.-        consOptionals ::-             [(ByteString, ByteString)] -> [(ByteString, ByteString)]-        consOptionals =-          consJust "apns" (nullToMaybe apnsBS) .-          consJust "fcm" (nullToMaybe fcmBS) .-          consJust "gcm" (nullToMaybe gcmBS)-        fields :: [(ByteString, ByteString)]-        fields = consOptionals requiredFields-        bs :: B.ByteString-        bs =-          (\acc -> "{" <> acc <> "}") .-          B.intercalate "," . map (\(k, v) -> "\"" <> k <> "\": " <> v) $-          fields-    return $ NotificationDecoding (bs, notification)-      -- Cons an attribute value pair if Just-    where-      consJust ::-           ByteString-        -> Maybe ByteString-        -> [(ByteString, ByteString)]-        -> [(ByteString, ByteString)]-      consJust attr = maybe id (\val rest -> (attr, val) : rest)-      -- Empty ByteStrings become null-      nullToMaybe :: B.ByteString -> Maybe B.ByteString-      nullToMaybe bs-        | B.null bs = Nothing-        | otherwise = Just bs---- Valid interest names-arbitraryInterestText :: Gen T.Text-arbitraryInterestText = do-  n <- elements [1 .. 164]-  str <--    vectorOf n $-    elements $-    concat-      [['a' .. 'z'], ['A' .. 'Z'], ['0' .. '1'], ['_', '=', '@', ',', '.', ';']]-  return . T.pack $ str---- Invalid interest names-arbitraryInvalidInterestText :: Gen T.Text-arbitraryInvalidInterestText =-  T.pack <$>-  oneof-    [tooLargeInterestText, tooSmallInterestText, invalidCharactersInterestText]-  where-    tooLargeInterestText = do-      n <- elements [165 .. 265]-      vectorOf n $-        elements $-        concat-          [ ['a' .. 'z']-          , ['A' .. 'Z']-          , ['0' .. '1']-          , ['_', '=', '@', ',', '.', ';']-          ]-    tooSmallInterestText = return ""-    invalidCharactersInterestText = do-      n <- elements [1 .. 165]-      vectorOf n $ elements "!\"£$%^&*()+}{~:?><¬` `}\""---- JSON but with no nested objects or nested arrays to make generating arbitrary--- structures simpler. A better solution would be to used 'sized' or similar to--- limit the size.-newtype NonRecJSON =-  NonRecJSON A.Value--instance Arbitrary NonRecJSON where-  arbitrary =-    NonRecJSON <$>-    oneof [arbitraryJSONPrimitives, arbitraryObject, arbitraryArray]-    where-      arbitraryObject = A.Object . _unNonRecObject <$> arbitrary-      arbitraryArray = A.Array . _unNonRecArray <$> arbitrary---- Strings, numbers, bools and null. No arrays or objects-arbitraryJSONPrimitives :: Gen A.Value-arbitraryJSONPrimitives =-  oneof [arbitraryString, arbitraryNumber, arbitraryBool, arbitraryNull]-  where-    arbitraryString = A.String . _unInterestText <$> arbitrary-    arbitraryNumber = A.Number . _unOurNumber <$> arbitrary-    arbitraryBool = A.Bool <$> arbitrary-    arbitraryNull = pure A.Null---- Valid interest text has a certain size and character set although we use--- this as a general source of 'safe' random text elsewhere.-newtype InterestText = InterestText-  { _unInterestText :: T.Text-  }--instance Arbitrary InterestText where-  arbitrary =-    InterestText <$> do-      n <- elements [1 .. 164]-      str <--        vectorOf n $-        elements $-        concat-          [ ['a' .. 'z']-          , ['A' .. 'Z']-          , ['0' .. '1']-          , ['_', '=', '@', ',', '.', ';']-          ]-      return . T.pack $ str---- The internal type of JSON objects is hashmap of text keys to values.--- We only nest primitives.-newtype NonRecObject = NonRecObject-  { _unNonRecObject :: HM.HashMap T.Text A.Value-  }--instance Arbitrary NonRecObject where-  arbitrary =-    NonRecObject <$> do-      o <--        vectorOf 10 $ do-          InterestText k <- arbitrary-          v <- arbitraryJSONPrimitives-          return (k, v)-      return . HM.fromList $ o---- The internal type of JSON arrays is a Vector of values.--- We only nest primitives.-newtype NonRecArray = NonRecArray-  { _unNonRecArray :: V.Vector A.Value-  }--instance Arbitrary NonRecArray where-  arbitrary =-    NonRecArray <$> do-      xs <- vectorOf 10 arbitraryJSONPrimitives-      return . V.fromList $ xs---- The internal type of JSON numbers is a Scientific number.--- We generate arbitrary values with the 'scientific' function.-newtype OurNumber = OurNumber-  { _unOurNumber :: Scientific-  }--instance Arbitrary OurNumber where-  arbitrary = OurNumber <$> (scientific <$> arbitrary <*> arbitrary)

@@ -3,27 +3,31 @@ module Webhook where  import qualified Data.Aeson as A-import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC import qualified Data.HashMap.Strict as HM-import Data.Time.Clock.POSIX+import Data.Word (Word64) import Network.Pusher-       (AppKey, AppSecret, AuthSignature, WebhookEv(..),-        WebhookPayload(..), Webhooks(..), parseChannel,-        parseWebhookPayloadWith)-import Network.Pusher.Protocol (User(..))+  ( WebhookEv (..),+    WebhookPayload (..),+    Webhooks (..),+    parseWebhookPayloadWith,+  )+import Network.Pusher.Protocol (User (..)) import Test.Hspec (Spec, describe, it) import Test.QuickCheck (property) -data TestWebhookPayload = TestWebhookPayload {-  -- A Request recieved from Pusher Channels-    _webhookRequest :: ([(B.ByteString, B.ByteString)], B.ByteString)-  -- Must have this key-  , _hasKey :: AppKey-  -- Which must correspond to this secret-  , _hasSecret :: AppSecret-  -- And which must parse to this Payload-  , _payload :: Maybe WebhookPayload-  }+data TestWebhookPayload+  = TestWebhookPayload+      { -- A Request received from Pusher Channels+        _webhookRequest :: ([(BC.ByteString, BC.ByteString)], BC.ByteString),+        -- Must have this key+        _hasKey :: B.ByteString,+        -- Which must correspond to this secret+        _hasSecret :: B.ByteString,+        -- And which must parse to this Payload+        _payload :: Maybe WebhookPayload+      }  -- Attempt to parse the contained req. -- - It must use our appKey which must correspond to our secret.@@ -33,20 +37,22 @@ testWebhookPayloadParses (TestWebhookPayload (headers, body) hasKey correspondingSecret expectedPayload) =   let parseResult =         parseWebhookPayloadWith-          (\k ->-             if k == hasKey-               then Just correspondingSecret-               else Nothing)+          ( \k ->+              if k == hasKey+                then Just correspondingSecret+                else Nothing+          )           headers           body-  in parseResult == expectedPayload+   in parseResult == expectedPayload  -- Build a _simple_ TestWebhookPayload which contains:--- - A HTTP POST request with key and signature headers and a bytestring body--- - A mapping from the same key to the secret used to sign the body to produce the signature.+-- - A HTTP POST request with key and signature headers and a 'ByteString' body+-- - A mapping from the same key to the secret used to sign the body to produce+--   the signature. -- - A list of webhook events we expect to have in the body. ----- The caller can deliberately pass incorrect timestamps, bodys, secrets,+-- The caller can deliberately pass incorrect timestamps, bodies, secrets, -- signatures and event combinations to test whether parsing fails as expected. -- -- Parsing of values generated by this function should only succeed when:@@ -55,32 +61,32 @@ -- - The body is encrypted by the given key to produce the given signature -- -- The word _simple_ excludes cases where:--- - The HTTP request doesnt have the required headers+-- - The HTTP request doesn't have the required headers -- - The HTTP headers are different to the expected payload--- - The HTTP requests key is unknown or doesnt match our secret+-- - The HTTP requests key is unknown or doesn't match our secret mkSimpleTestWebhookPayload ::-     AppKey-  -> AppSecret-  -> POSIXTime-  -> B.ByteString-  -> AuthSignature-  -> [WebhookEv]-  -> TestWebhookPayload-mkSimpleTestWebhookPayload key secret unixTime body signature whs =+  B.ByteString ->+  B.ByteString ->+  Word64 ->+  BC.ByteString ->+  B.ByteString ->+  [WebhookEv] ->   TestWebhookPayload-  { _webhookRequest =-      ([("X-Pusher-Key", key), ("X-Pusher-Signature", signature)], body)-  , _hasKey = key-  , _hasSecret = secret-  , _payload =-      Just-        WebhookPayload-        { xPusherKey = key-        , xPusherSignature = signature-        , webhooks =-            Webhooks {timeMs = posixSecondsToUTCTime unixTime, webhookEvs = whs}-        }-  }+mkSimpleTestWebhookPayload key secret timestampMS body signature whs =+  TestWebhookPayload+    { _webhookRequest =+        ([("X-Pusher-Key", key), ("X-Pusher-Signature", signature)], body),+      _hasKey = key,+      _hasSecret = secret,+      _payload =+        Just+          WebhookPayload+            { xPusherKey = key,+              xPusherSignature = signature,+              webhooks =+                Webhooks {timeMs = timestampMS, webhookEvs = whs}+            }+    }  channelOccupiedPayload :: TestWebhookPayload channelOccupiedPayload =@@ -90,7 +96,7 @@     1502790365001     "{\"time_ms\":1502790365001,\"events\":[{\"channel\":\"foo\",\"name\":\"channel_occupied\"}]}"     "4b3d29966e4930d875ec01012e37c18070f4b779b09f71af99d1f0baaffabc98"-    [ChannelOccupiedEv {onChannel = parseChannel "foo"}]+    [ChannelOccupiedEv {onChannel = "foo"}]  channelVacatedPayload :: TestWebhookPayload channelVacatedPayload =@@ -100,7 +106,7 @@     1502790363928     "{\"time_ms\":1502790363928,\"events\":[{\"channel\":\"foo\",\"name\":\"channel_vacated\"}]}"     "c9c70dcf19e011912ecdabe8997b451a95667157d00e37c7476491e7f233c416"-    [ChannelVacatedEv {onChannel = parseChannel "foo"}]+    [ChannelVacatedEv {onChannel = "foo"}]  memberAddedPayload :: TestWebhookPayload memberAddedPayload =@@ -111,7 +117,9 @@     "{\"time_ms\":1503394956847,\"events\":[{\"channel\":\"presence-foo\",\"user_id\":\"42\",\"name\":\"member_added\"}]}"     "392bd546e8a33a826d7870bd6432f6c7dcf11ca31565575d8c72f9b02f5b0736"     [ MemberAddedEv-      {onChannel = parseChannel "presence-foo", withUser = User "42"}+        { onChannel = "presence-foo",+          withUser = User "42"+        }     ]  memberRemovedPayload :: TestWebhookPayload@@ -123,7 +131,9 @@     "{\"time_ms\":1503394971554,\"events\":[{\"channel\":\"presence-foo\",\"user_id\":\"42\",\"name\":\"member_removed\"}]}"     "9a344e8aeb2c6339999e84bacb4d50b3674599e297d01655eb2cec3f9c655763"     [ MemberRemovedEv-      {onChannel = parseChannel "presence-foo", withUser = User "42"}+        { onChannel = "presence-foo",+          withUser = User "42"+        }     ]  clientEventPayload :: TestWebhookPayload@@ -135,15 +145,15 @@     "{\"time_ms\":1503397271011,\"events\":[{\"name\":\"client_event\",\"channel\":\"presence-foo\",\"event\":\"client-event\",\"data\":\"{\\\"name\\\":\\\"John\\\",\\\"message\\\":\\\"Hello\\\"}\",\"socket_id\":\"219049.596715\",\"user_id\":\"sturdy-window-821\"}]}"     "e5ef8964e8c87c91dde0555e46fa921163aff262395c9e36c1755ffe206be547"     [ ClientEv-      { onChannel = parseChannel "presence-foo"-      , clientEvName = "client-event"-      , clientEvBody =-          Just $-          A.Object $-          HM.fromList [("name", A.String "John"), ("message", A.String "Hello")]-      , withSocketId = "219049.596715"-      , withPossibleUser = Just . User $ "sturdy-window-821"-      }+        { onChannel = "presence-foo",+          clientEvName = "client-event",+          clientEvBody =+            Just+              $ A.Object+              $ HM.fromList [("name", A.String "John"), ("message", A.String "Hello")],+          withSocketId = "219049.596715",+          withPossibleUser = Just . User $ "sturdy-window-821"+        }     ]  batchEventPayload :: TestWebhookPayload@@ -154,22 +164,28 @@     1503397088953     "{\"time_ms\":1503397088953,\"events\":[{\"channel\":\"private-foo\",\"name\":\"channel_occupied\"},{\"channel\":\"presence-foo\",\"name\":\"channel_occupied\"}]}"     "7a9803e1ca598dac4750a60fbb017d4f34fc44eaf0aea26c694ca0d7060e6477"-    [ ChannelOccupiedEv {onChannel = parseChannel "private-foo"}-    , ChannelOccupiedEv {onChannel = parseChannel "presence-foo"}+    [ ChannelOccupiedEv {onChannel = "private-foo"},+      ChannelOccupiedEv {onChannel = "presence-foo"}     ]  test :: Spec test =   describe "Webhook.parseWebhookPayloadWith" $ do-    it "parses and validates a channel_occupied event" $-      property $ testWebhookPayloadParses channelOccupiedPayload-    it "parses and validates a Channel_vacated event" $-      property $ testWebhookPayloadParses channelVacatedPayload-    it "parses and validates a member_added event" $-      property $ testWebhookPayloadParses memberAddedPayload-    it "parses and validates a member_removed event" $-      property $ testWebhookPayloadParses memberRemovedPayload-    it "parses and validates a client event" $-      property $ testWebhookPayloadParses clientEventPayload-    it "parses and validates multiple batched events" $-      property $ testWebhookPayloadParses batchEventPayload+    it "parses and validates a channel_occupied event"+      $ property+      $ testWebhookPayloadParses channelOccupiedPayload+    it "parses and validates a Channel_vacated event"+      $ property+      $ testWebhookPayloadParses channelVacatedPayload+    it "parses and validates a member_added event"+      $ property+      $ testWebhookPayloadParses memberAddedPayload+    it "parses and validates a member_removed event"+      $ property+      $ testWebhookPayloadParses memberRemovedPayload+    it "parses and validates a client event"+      $ property+      $ testWebhookPayloadParses clientEventPayload+    it "parses and validates multiple batched events"+      $ property+      $ testWebhookPayloadParses batchEventPayload