diff --git a/pusher-http-haskell.cabal b/pusher-http-haskell.cabal --- a/pusher-http-haskell.cabal +++ b/pusher-http-haskell.cabal @@ -1,5 +1,5 @@ name: pusher-http-haskell -version: 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 diff --git a/src/Network/Pusher.hs b/src/Network/Pusher.hs --- a/src/Network/Pusher.hs +++ b/src/Network/Pusher.hs @@ -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 diff --git a/src/Network/Pusher/Data.hs b/src/Network/Pusher/Data.hs --- a/src/Network/Pusher/Data.hs +++ b/src/Network/Pusher/Data.hs @@ -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 .=)) diff --git a/src/Network/Pusher/Internal.hs b/src/Network/Pusher/Internal.hs --- a/src/Network/Pusher/Internal.hs +++ b/src/Network/Pusher/Internal.hs @@ -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 diff --git a/src/Network/Pusher/Internal/Auth.hs b/src/Network/Pusher/Internal/Auth.hs --- a/src/Network/Pusher/Internal/Auth.hs +++ b/src/Network/Pusher/Internal/Auth.hs @@ -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 diff --git a/src/Network/Pusher/Internal/HTTP.hs b/src/Network/Pusher/Internal/HTTP.hs --- a/src/Network/Pusher/Internal/HTTP.hs +++ b/src/Network/Pusher/Internal/HTTP.hs @@ -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 diff --git a/src/Network/Pusher/Internal/Util.hs b/src/Network/Pusher/Internal/Util.hs --- a/src/Network/Pusher/Internal/Util.hs +++ b/src/Network/Pusher/Internal/Util.hs @@ -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. diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Push.hs b/test/Push.hs new file mode 100644 --- /dev/null +++ b/test/Push.hs @@ -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)