pusher-http-haskell 1.3.0.0 → 1.4.0.0
raw patch · 9 files changed
+694/−49 lines, 9 filesdep +cryptonitedep +memorydep +scientificdep −cryptohash
Dependencies added: cryptonite, memory, scientific, vector
Dependencies removed: cryptohash
Files
- pusher-http-haskell.cabal +9/−4
- src/Network/Pusher.hs +60/−9
- src/Network/Pusher/Data.hs +172/−8
- src/Network/Pusher/Internal.hs +36/−1
- src/Network/Pusher/Internal/Auth.hs +30/−19
- src/Network/Pusher/Internal/HTTP.hs +10/−7
- src/Network/Pusher/Internal/Util.hs +14/−0
- test/Main.hs +2/−1
- test/Push.hs +361/−0
pusher-http-haskell.cabal view
@@ -1,5 +1,5 @@ name: pusher-http-haskell-version: 1.3.0.0+version: 1.4.0.0 cabal-version: >=1.18 build-type: Simple license: MIT@@ -36,14 +36,16 @@ base >=4.7 && <4.11, bytestring ==0.10.*, base16-bytestring ==0.1.*,- cryptohash ==0.11.*,+ cryptonite >= 0.6 && <0.24, hashable ==1.2.*, http-client >=0.4 && <0.6, http-types >=0.8 && <0.10,+ memory >= 0.7 && <0.15, text ==1.2.*, time >=1.5 && <1.7, transformers >=0.4 && <0.6,- unordered-containers ==0.2.*+ unordered-containers ==0.2.*,+ vector >=0.10.0.0 && <0.13 default-language: Haskell2010 default-extensions: OverloadedStrings hs-source-dirs: src@@ -72,11 +74,14 @@ QuickCheck -any, text -any, transformers -any,- unordered-containers -any+ unordered-containers -any,+ vector -any,+ scientific default-language: Haskell2010 default-extensions: OverloadedStrings hs-source-dirs: test other-modules: Auth Protocol+ Push ghc-options: -Wall
src/Network/Pusher.hs view
@@ -30,15 +30,43 @@ , credentialsCluster = Nothing } pusher <- getPusher credentials- result <-++ triggerRes <- trigger pusher [Channel Public "my-channel"] "my-event" "my-data" Nothing- case result of- Left e -> error e++ case triggerRes of+ Left e -> putStrLn $ displayException e Right resp -> print resp++ -- 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 "TITLE")+ ,("body" , A.String "BODY")+ ,("icon" , A.String "logo.png")+ ]+ )]+ Just interest = mkInterest "INTEREST"++ -- A Pusher notification+ notification = Notification+ { notificationInterest = interest+ , notificationWebhookURL = Nothing+ , notificationWebhookLevel = Nothing+ , notificationAPNSPayload = Nothing+ , notificationGCMPayload = Nothing+ , notificationFCMPayload = Just $ FCMPayload fcmObject+ }++ notifyRes <- notify pusher notification+ @ -There is a simple working example in the example/ directory. +There are simple working examples in the example/ directory.+ See https://pusher.com/docs/rest_api for more detail on the HTTP requests. -} module Network.Pusher@@ -64,6 +92,15 @@ , Event , EventData , SocketID+ -- ** Notifications+ , Notification(..)+ , Interest+ , mkInterest+ , WebhookURL+ , WebhookLevel(..)+ , APNSPayload(..)+ , GCMPayload(..)+ , FCMPayload(..) -- * HTTP Requests -- ** Trigger events , trigger@@ -71,6 +108,8 @@ , channels , channel , users+ -- ** Push notifications+ , notify -- * Authentication , AuthString , AuthSignature@@ -85,11 +124,12 @@ import qualified Data.Text as T import Network.Pusher.Data- (AppID, AppKey, AppSecret, Channel(..), ChannelName,- ChannelType(..), Credentials(..), Cluster(..), Event, EventData,- Pusher(..), SocketID, getPusher, getPusherWithHost,- getPusherWithConnManager, parseChannel, renderChannel,- renderChannelPrefix)+ (AppID, APNSPayload(..), AppKey, AppSecret, Channel(..),+ ChannelName, ChannelType(..), Credentials(..), Cluster(..), Event,+ EventData, FCMPayload(..), GCMPayload(..), Interest,+ Notification(..), Pusher(..), SocketID, WebhookLevel(..),+ WebhookURL, getPusher, getPusherWithConnManager, getPusherWithHost,+ mkInterest, parseChannel, renderChannel, renderChannelPrefix) import Network.Pusher.Error (PusherError(..)) import qualified Network.Pusher.Internal as Pusher import Network.Pusher.Internal.Auth@@ -165,3 +205,14 @@ runExceptT $ do requestParams <- liftIO $ Pusher.mkUsersRequest pusher chan <$> getTime HTTP.get (pusherConnectionManager 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
src/Network/Pusher/Data.hs view
@@ -39,24 +39,37 @@ , Event , EventData , SocketID+ -- * Notifications+ , Notification(..)+ , Interest+ , mkInterest+ , WebhookURL+ , WebhookLevel(..)+ , APNSPayload(..)+ , GCMPayload(..)+ , FCMPayload(..) ) where import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Aeson ((.:), (.:?))+import Data.Aeson ((.:), (.:?), (.=)) import qualified Data.Aeson as A import qualified Data.ByteString as B+import Data.Char import Data.Foldable (asum)+import qualified Data.HashSet as HS import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) 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- (failExpectObj, failExpectStr, show')+ (failExpectObj, failExpectSingletonArray, failExpectArray,+ failExpectStr, show') type AppID = Integer @@ -68,6 +81,8 @@ data Pusher = Pusher { pusherHost :: T.Text , pusherPath :: T.Text+ , pusherNotifyHost :: T.Text+ , pusherNotifyPath :: T.Text , pusherCredentials :: Credentials , pusherConnectionManager :: Manager }@@ -118,25 +133,35 @@ => Credentials -> m Pusher getPusher cred = do connManager <- getConnManager- return $ getPusherWithConnManager connManager Nothing cred+ return $ getPusherWithConnManager connManager Nothing Nothing cred -- |Get a Pusher instance that uses a specific API endpoint. getPusherWithHost :: MonadIO m- => T.Text -> Credentials -> m Pusher-getPusherWithHost apiHost cred = do+ => T.Text -> T.Text -> Credentials -> m Pusher+getPusherWithHost apiHost notifyHost cred = do connManager <- getConnManager- return $ getPusherWithConnManager connManager (Just apiHost) cred+ 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 -> Credentials -> Pusher-getPusherWithConnManager connManager apiHost cred =+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 }@@ -201,3 +226,142 @@ type EventData = T.Text type SocketID = T.Text++-- | Up to 164 characters where each character is ASCII upper or lower case, a+-- number or one of _=@,.;+-- 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 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+-- TODO: Replace JSON object with a stronger encoding.+data APNSPayload =+ 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+-- TODO: Replace JSON object with a stronger encoding.+data GCMPayload =+ 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++-- | Firebase Cloud Messaging payload+-- TODO: Replace JSON object with a stronger encoding.+data FCMPayload =+ FCMPayload A.Object+ deriving (Eq,Show)++instance A.FromJSON FCMPayload where+ parseJSON v =+ case v of+ A.Object o -> pure . FCMPayload $ o+ _ -> failExpectObj v++instance A.ToJSON FCMPayload where+ toJSON (FCMPayload o) = A.Object o++data Notification = Notification+ { notificationInterest :: Interest+ , notificationWebhookURL :: Maybe WebhookURL+ , notificationWebhookLevel :: Maybe WebhookLevel+ , notificationAPNSPayload :: Maybe APNSPayload+ , notificationGCMPayload :: Maybe GCMPayload+ , notificationFCMPayload :: Maybe FCMPayload+ }+ deriving (Eq,Show)++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++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 .=))
src/Network/Pusher/Internal.hs view
@@ -11,6 +11,7 @@ , mkChannelsRequest , mkChannelRequest , mkUsersRequest+ , mkNotifyRequest ) where import Control.Monad (when)@@ -24,7 +25,8 @@ import Network.Pusher.Data (Channel, ChannelType, Credentials(..), Event, EventData,- Pusher(..), SocketID, renderChannel, renderChannelPrefix)+ Pusher(..), SocketID, Notification(..), renderChannel,+ renderChannelPrefix) import Network.Pusher.Error (PusherError(..)) import Network.Pusher.Internal.Auth (makeQS) import Network.Pusher.Internal.HTTP@@ -87,6 +89,17 @@ let subPath = "channels/" <> renderChannel chan <> "/users" in mkGetRequest pusher subPath [] time +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)+ mkGetRequest :: Pusher -> T.Text -> RequestQueryString -> Int -> RequestParams mkGetRequest pusher subPath params time = let (ep, fullPath) = mkEndpoint pusher subPath@@ -104,6 +117,17 @@ 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@@ -112,6 +136,17 @@ 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) mkQS
src/Network/Pusher/Internal/Auth.hs view
@@ -23,6 +23,7 @@ ) where import qualified Data.Aeson as A+import Data.Char (toLower) import Data.Monoid ((<>)) import Data.Text.Encoding (encodeUtf8) import GHC.Exts (sortWith)@@ -31,11 +32,12 @@ #else import qualified Data.Aeson.Encode as A #endif-import qualified Crypto.Hash.MD5 as MD5-import qualified Crypto.Hash.SHA256 as SHA256+import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC+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 qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL@@ -48,8 +50,8 @@ -- |Generate the required query string parameters required to send API requests -- to Pusher.-makeQS- :: AppKey+makeQS ::+ AppKey -> AppSecret -> T.Text -> T.Text@@ -57,26 +59,35 @@ -> B.ByteString -> Int -- ^Current UNIX timestamp -> RequestQueryString-makeQS appKey appSecret method path params body ts =- let allParams- -- Generate all required parameters and add them to the list of existing- -- ones- =- sortWith fst $- params +++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+ =+ let allParams =+ alphabeticalOrder . lowercaseKeys . (params ++) $ [ ("auth_key", appKey) , ("auth_timestamp", show' ts) , ("auth_version", "1.0")- , ("body_md5", B16.encode (MD5.hash body))+ , ( "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 method, encodeUtf8 path, formQueryString allParams]+ [ encodeUtf8 . T.toUpper $ method+ , encodeUtf8 fullPath+ , formQueryString allParams+ ] -- Add the auth string to the list in ("auth_signature", 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@@ -91,7 +102,8 @@ -- |Create a Pusher auth signature of a string using the provided credentials. authSignature :: AppSecret -> AuthString -> AuthSignature authSignature appSecret authString =- B16.encode $ HMAC.hmac SHA256.hash 64 appSecret authString+ B16.encode $+ 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.@@ -105,9 +117,8 @@ -- |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+authenticatePresence ::+ A.ToJSON a => Credentials -> SocketID -> Channel -> a -> AuthSignature authenticatePresence = authenticatePresenceWithEncoder (TL.toStrict . TL.toLazyText . A.encodeToTextBuilder . A.toJSON)@@ -115,8 +126,8 @@ -- |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.+authenticatePresenceWithEncoder ::+ (a -> T.Text) -- ^The encoder of the user data. -> Credentials -> SocketID -> Channel
src/Network/Pusher/Internal/HTTP.hs view
@@ -44,7 +44,7 @@ -- ^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)] @@ -59,7 +59,7 @@ -> ExceptT PusherError IO a -- ^The body of the response get connManager (RequestParams ep qs) = do req <- ExceptT $ return $ mkRequest ep qs- resp <- doReqest connManager req+ resp <- doRequest connManager req either (throwE . PusherInvalidResponseError . T.pack) return@@ -71,7 +71,7 @@ => HTTP.Client.Manager -> RequestParams -> a -> ExceptT PusherError IO () post connManager (RequestParams ep qs) body = do req <- ExceptT $ return $ mkPost (A.encode body) <$> mkRequest ep qs- _ <- doReqest connManager req+ _ <- doRequest connManager req return () mkRequest :: T.Text@@ -96,15 +96,18 @@ , HTTP.Client.requestBody = HTTP.Client.RequestBodyLBS body } -doReqest+doRequest :: HTTP.Client.Manager -> HTTP.Client.Request -> ExceptT PusherError IO BL.ByteString-doReqest connManager req = do+doRequest connManager req = do response <- liftIO $ HTTP.Client.httpLbs req connManager let status = HTTP.Client.responseStatus response- if statusCode status == 200- then return $ HTTP.Client.responseBody response+ 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
src/Network/Pusher/Internal/Util.hs view
@@ -8,7 +8,9 @@ -} module Network.Pusher.Internal.Util ( failExpectObj+ , failExpectArray , failExpectStr+ , failExpectSingletonArray , getTime , show' ) where@@ -26,6 +28,18 @@ -- 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.
test/Main.hs view
@@ -4,6 +4,7 @@ import qualified Auth import qualified Protocol+import qualified Push main :: IO ()-main = hspec $ Auth.test >> Protocol.test+main = hspec $ Auth.test >> Protocol.test >> Push.test
+ test/Push.hs view
@@ -0,0 +1,361 @@+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)+import Data.Monoid ((<>))+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Vector as V++import Test.Hspec (Spec, describe, it)+import Test.QuickCheck+ (elements, property, Gen, vectorOf, oneof, Arbitrary(..))++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 =+ "{\+ \ \"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 =+ "{\+ \ \"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 =+ "{\+ \ \"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 =+ "{\+ \ \"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)