fcm-client (empty) → 0.1.0.0
raw patch · 10 files changed
+1387/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, aeson-casing, async, base, bytestring, conduit, conduit-extra, containers, data-default-class, fcm-client, http-client, http-conduit, http-types, lens, optparse-applicative, resourcet, retry, scientific, stm-conduit, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, utf8-string
Files
- LICENSE +30/−0
- README.md +5/−0
- Setup.hs +2/−0
- cli/CliArgs.hs +216/−0
- cli/Main.hs +150/−0
- fcm-client.cabal +89/−0
- src/FCMClient.hs +60/−0
- src/FCMClient/JSON/Types.hs +531/−0
- src/FCMClient/Types.hs +206/−0
- test/Spec.hs +98/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrey Kartashov (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andrey Kartashov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# fcm-client++Simple model/client for [firebase cloud messaging](https://firebase.google.com/docs/cloud-messaging/concept-options#notifications_and_data_messages).++[Example](cli/Main.hs)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cli/CliArgs.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE RecordWildCards #-}++module CliArgs+ ( CliArgs (..)+ , CliCmd (..)+ , CliJsonBatchArgs (..)+ , runWithArgs+ ) where++import Control.Lens+import Data.List.NonEmpty (nonEmpty)+import FCMClient.Types+import Options.Applicative+import System.Environment++import qualified Data.Aeson as J+import qualified Data.ByteString.Lazy.Char8 as LB+import qualified Data.Text as T+import qualified FCMClient.JSON.Types as J++data CliArgs = CliArgs { cliAuthKey :: String+ , cliCmd :: CliCmd+ }++data CliJsonBatchArgs = CliJsonBatchArgs { cliBatchInput :: (Maybe FilePath)+ , cliBatchOutput :: (Maybe FilePath)+ , cliBatchConc :: Int+ }++data CliCmd = CliCmdSendJsonBatch CliJsonBatchArgs+ | CliCmdSendMessage (FCMMessage -> FCMMessage)+++parseArgs :: Maybe String -- ^ default auth key from shell env+ -> Parser CliArgs+parseArgs maybeAuthKey = CliArgs+ <$> strOption+ ( long "auth-key"+ <> short 'k'+ <> ( case maybeAuthKey+ of Nothing -> mempty+ Just ak -> value ak+ )+ <> help "Auth key, defaults to FCM_AUTH_KEY environmental variable." )+ <*> subparser ( command "message" (info (helper <*> parseCliCmdSendMessage)+ (progDesc "Send test message."))++ <> command "batch" (info (helper <*> (CliCmdSendJsonBatch <$> parseCliJsonBatchArgs))+ (progDesc "Send message batch."))+ )+++parseCliJsonBatchArgs :: Parser CliJsonBatchArgs+parseCliJsonBatchArgs = CliJsonBatchArgs+ <$> (optional $ strOption+ ( long "input"+ <> short 'i'+ <> help "Batch input file, one JSON object per line (or STDIN)."))+ <*> (optional $ strOption+ ( long "output"+ <> short 'o'+ <> help "Batch input file (or STDOUT)."))+ <*> (option (auto >>= (\c -> if (c < 1) then error "Concurrency must be >= 1" else return c))+ ( long "concurrency"+ <> short 'c'+ <> value 1+ <> showDefaultWith show+ <> help "How many HTTP requests to run in concurrently."))+++parseCliCmdSendMessage :: Parser CliCmd+parseCliCmdSendMessage = CliCmdSendMessage+ <$> ( ( fmap (set fcmTo)+ (optionalText+ ( long "to"+ <> short 't'+ <> help "message to (reg token, notification key or topic)"))+ <|> fmap (set fcmRegistrationIDs)+ (textList+ ( long "registration-id"+ <> short 'r'+ <> help "Registration token or ID, up to 1000, for multicast messaging."))+ <|> fmap (set fcmCondition)+ (optionalText+ ( long "condition"+ <> short 'c'+ <> help "The message target. Supported condition: Topic, formatted as \"'yourTopic' in topics\". This value is case-insensitive. Supported operators: &&, ||. Maximum two operators per topic message supported."))+ )++ <..> fmap (set $ fcmCollapseKey)+ (optionalText+ ( long "collapse-key"+ <> help "Identifies a group of messages that can be collapsed, so that only the last message gets sent when delivery can be resumed."))++ <..> fmap (set $ J.fcmPriority)+ (optionalText+ ( long "priority"+ <> help "Sets the priority of the message. Valid values are 'normal' and 'high'. On iOS, these correspond to APNs priorities 5 and 10."))++ <..> fmap (set $ fcmContentAvailable)+ (switch+ ( long "content-available"+ <> help "On iOS, use this field to represent content-available in the APNS payload. When a notification or message is sent and this is set to true, an inactive client app is awoken. On Android, data messages wake the app by default. On Chrome, currently not supported."))++ <..> fmap (set $ fcmDelayWhileIdle)+ (switch+ ( long "delay-while-idle"+ <> help "When this parameter is set to true, it indicates that the message should not be sent until the device becomes active. The default value is false."))++ <..> fmap (set $ fcmTimeToLive)+ (optional $ option auto+ ( long "time-to-live"+ <> help "This parameter specifies how long (in seconds) the message should be kept in FCM storage if the device is offline. The maximum time to live supported is 4 weeks, and the default value is 4 weeks. For more information, see Setting the lifespan of a message."))++ <..> fmap (set $ fcmRestrictedPackageName)+ (optionalText+ ( long "restricted-package-name"+ <> help "This parameter specifies the package name of the application where the registration tokens must match in order to receive the message."))++ <..> fmap (set $ fcmDryRun)+ (switch+ ( long "dry-run"+ <> help "This parameter, when set to true, allows developers to test a request without actually sending a message. The default value is false."))++ <..> fmap (set $ fcmData)+ (fmap (J.decode . LB.pack) (strOption+ ( long "data"+ <> short 'd'+ <> help "This parameter specifies the custom key-value pairs of the message's payload. For example, with data:{\"score\":\"3x1\"}: On iOS, if the message is sent via APNS, it represents the custom data fields. If it is sent via FCM connection server, it would be represented as key value dictionary in AppDelegate application:didReceiveRemoteNotification:. On Android, this would result in an intent extra named score with the string value 3x1. The key should not be a reserved word (\"from\" or any word starting with \"google\" or \"gcm\"). Do not use any of the words defined in this table (such as collapse_key). ONLY values in string types are supported. You have to convert values in objects or other non-string data types (e.g., integers or booleans) to string.")))++ <..> fmap (set $ fcmWithNotification . fcmTitle)+ (optionalText+ ( long "title"+ <> short 'T'+ <> help "notification title text"))++ <..> fmap (set $ fcmWithNotification . fcmBody)+ (optionalText+ ( long "body"+ <> short 'b'+ <> help "notification body text"))++ <..> fmap (set $ fcmWithNotification . fcmIcon)+ (optionalText+ ( long "icon"+ <> help "Indicates notification icon."))++ <..> fmap (set $ fcmWithNotification . fcmSound)+ (optionalText+ ( long "sound"+ <> help "IOS: Indicates a sound to play when the device receives a notification. Sound files can be in the main bundle of the client app or in the Library/Sounds folder of the app's data container. See the iOS Developer Library for more information. Android: Indicates a sound to play when the device receives a notification. Supports default or the filename of a sound resource bundled in the app. Sound files must reside in /res/raw/. ."))++ <..> fmap (set $ fcmWithNotification . fcmTag)+ (optionalText+ ( long "tag"+ <> help "Android: Indicates whether each notification results in a new entry in the notification drawer on Android. If not set, each request creates a new notification. If set, and a notification with the same tag is already being shown, the new notification replaces the existing one in the notification drawer."))++ <..> fmap (set $ fcmWithNotification . J.fcmColor)+ (optionalText+ ( long "color"+ <> help "Android: Indicates color of the icon, expressed in #rrggbb format"))++ <..> fmap (set $ fcmWithNotification . fcmBadge)+ (optionalText+ ( long "badge"+ <> help "Indicates the badge on the client app home icon."))++ <..> fmap (set $ fcmWithNotification . fcmClickAction)+ (optionalText+ ( long "click-action"+ <> help "IOS: Indicates the action associated with a user click on the notification. Corresponds to category in the APNs payload. Android: Indicates the action associated with a user click on the notification. When this is set, an activity with a matching intent filter is launched when user clicks the notification."))++ <..> fmap (set $ fcmWithNotification . fcmBodyLocKey)+ (optionalText+ ( long "body-loc-key"+ <> help "IOS: Indicates the key to the body string for localization. Corresponds to \"loc-key\" in the APNs payload. Android: Indicates the key to the body string for localization. Use the key in the app's string resources when populating this value."))++ <..> fmap (set $ fcmWithNotification . J.fcmBodyLocArgs)+ (optionalText+ ( long "body-loc-args"+ <> help "IOS: Indicates the string value to replace format specifiers in the body string for localization. Corresponds to \"loc-args\" in the APNs payload. Android: Indicates the string value to replace format specifiers in the body string for localization. For more information, see Formatting and Styling."))++ <..> fmap (set $ fcmWithNotification . J.fcmTitleLocKey)+ (optionalText+ ( long "title-loc-key"+ <> help "IOS: Indicates the key to the title string for localization. Corresponds to \"title-loc-key\" in the APNs payload. Android: Indicates the key to the title string for localization. Use the key in the app's string resources when populating this value."))++ <..> fmap (set $ fcmWithNotification . J.fcmTitleLocArgs)+ (optionalText+ ( long "title-loc-args"+ <> help "IOS: Indicates the string value to replace format specifiers in the title string for localization.Corresponds to \"title-loc-args\" in the APNs payload. Android: Indicates the string value to replace format specifiers in the title string for localization. For more information, see Formatting strings."))+ )++ where optionalText opt = fmap (fmap T.pack) $ optional $ strOption opt+ textList opt = fmap nonEmpty $ many $ fmap T.pack $ strOption opt+++-- | Chains functions through Applicative+(<..>) :: (Applicative f)+ => f (b -> c)+ -> f (a -> b)+ -> f (a -> c)+(<..>) bc ab = pure (.) <*> bc <*> ab+++runWithArgs:: (CliArgs -> IO ())+ -> IO ()+runWithArgs rwa = do+ maybeAuthKey <- lookupEnv "FCM_AUTH_KEY"++ let opts = info (helper <*> parseArgs maybeAuthKey) ( fullDesc+ <> progDesc "Simple FCM CLI client, send a test message or a JSON batch from a file."+ <> header "Simple FCM CLI client, send a test message or a JSON batch from a file."+ )++ execParser opts >>= rwa
+ cli/Main.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import CliArgs+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Control.Retry+import Data.Aeson+import Data.Conduit+import Data.Conduit.Async+import Data.Default.Class+import FCMClient+import FCMClient.Types+import System.IO++import qualified Control.Concurrent.Async as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.UTF8 as LUTF8+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL++main :: IO ()+main = runWithArgs $ \CliArgs{..} -> do++ let sendMessage msgMod = do+ let msg = msgMod def+ putStrLn $ (LUTF8.toString . encode) msg+ res <- fcmCallJSON (UTF8.fromString cliAuthKey) msg+ case res+ of FCMResultSuccess b -> putStrLn $ (LUTF8.toString . encode) b+ FCMResultError e -> putStrLn $ show e++ sendMessageBatch CliJsonBatchArgs{..} = do+ let buf c = buffer' cliBatchConc c++ (batchInputConduit cliBatchInput .| parseInputConduit)+ `buf`+ (callFCMConduit (UTF8.fromString cliAuthKey) .| runInParallel cliBatchConc)+ `buf`+ (encodeOutputConduit .| batchOutputConduit cliBatchOutput)+++ case cliCmd+ of CliCmdSendMessage msgMod -> sendMessage msgMod+ CliCmdSendJsonBatch bargs -> runResourceT $ runCConduit $ sendMessageBatch bargs++++-- | Attempts to parse input, one JSON object per line,+-- either succeeds and gives result or fails and gives json-serializable error.+--+-- Input can contain JSON fields that are not FCM-related, they'll be stripped out when we make+-- an FCM request but original input will be propagated to the output, this allows for addition+-- of request tracking/debugging fields that makes it easier to interpret results.+parseInputConduit :: (MonadIO m)+ => Conduit BS.ByteString m (Either (BS.ByteString, String) (Value, FCMMessage))+parseInputConduit = CB.lines .| CL.map (\line -> do+ jObj <- case eitherDecode' $ LBS.fromStrict line+ of Right v -> Right v+ Left e -> Left (line, e)+ case fromJSON jObj+ of Success m -> Right (jObj, m)+ Error e -> Left (line, e)+ )+++encodeOutputConduit :: (MonadIO m)+ => Conduit Value m BS.ByteString+encodeOutputConduit =+ CL.map (LBS.toStrict . encode)+ =$= ( awaitForever $ \l -> do yield l+ yield "\n" )+++-- | Convert each input line into a JSON object containing original input and results of the call.+callFCMConduit :: (MonadIO m, MonadResource m)+ => BS.ByteString -- ^ authorization key+ -> Conduit (Either (BS.ByteString,String) (Value, FCMMessage)) m (A.Async Value)+callFCMConduit authKey = CL.mapM $ \input -> liftIO . A.async $+ case input+ of Left (i,e) -> return $ object [ ("type", "ParserError")+ , ("error", toJSON e)+ , ("input", toJSON (UTF8.toString i))+ ]+ Right (jm, m) -> fmap (resToVal jm) $ retrying retPolicy (const $ shouldRetry) (const $ fcmCallJSON authKey m)++ where retPolicy = constantDelay 1000000 <> limitRetries 5++ shouldRetry (FCMResultSuccess _) = return False++ shouldRetry (FCMResultError e) = do+ liftIO $ hPutStrLn stderr $ "Client error: " <> (show e)+ return $ case e+ of FCMServerError _ _ -> True+ FCMClientHTTPError _ -> True+ _ -> False+++ resToVal :: Value -> FCMResult -> Value+ resToVal jm fr =+ let mkRes t r = object [ ("type", t)+ , ("message", jm)+ , ("response", r)+ ]+ in case fr+ of FCMResultSuccess b -> mkRes "Success" (toJSON b)+ FCMResultError e -> mkRes "Error" (toJSON . show $ e)+++runInParallel :: (MonadIO m)+ => Int -- ^ level+ -> Conduit (A.Async a) m a+runInParallel n = parC []+ where parC !xs = do+ let moreCnt = n - (length xs)+ moreXs <- CL.take moreCnt+ let xs' = xs ++ moreXs+ if null xs'+ then return ()+ else do (a,res) <- liftIO $ A.waitAny xs'+ yield res+ parC $ filter (/= a) xs'++++batchInputConduit :: (MonadResource m)+ => Maybe FilePath+ -> Producer m BS.ByteString+batchInputConduit (Just fp) = CB.sourceFile fp+batchInputConduit Nothing = do+ liftIO $ do hSetBinaryMode stdin True+ hSetBuffering stdin (BlockBuffering Nothing)+ CB.sourceHandle stdin+++batchOutputConduit :: (MonadResource m)+ => Maybe FilePath+ -> Consumer BS.ByteString m ()+batchOutputConduit (Just fp) = CB.sinkFile fp+batchOutputConduit Nothing = do+ liftIO $ do hSetBinaryMode stdout True+ hSetBuffering stdout (BlockBuffering Nothing)+ CB.sinkHandle stdout
+ fcm-client.cabal view
@@ -0,0 +1,89 @@+name: fcm-client+version: 0.1.0.0+synopsis: Admin API for Firebase Cloud Messaging+description: Please see README.md+homepage: https://github.com/holmusk/fcm-client#readme+license: BSD3+license-file: LICENSE+author: Andrey Kartashov, Holmusk+maintainer: hi@holmusk.com+copyright: 2016-2018 Andrey Kartashov, 2018 Holmusk+category: Library+build-type: Simple+extra-doc-files: README.md+cabal-version: 2.0+tested-with: GHC == 8.4.3++source-repository head+ type: git+ location: https://github.com/holmusk/fcm-client++library+ hs-source-dirs: src+ exposed-modules: FCMClient+ , FCMClient.JSON.Types+ , FCMClient.Types++ build-depends: base >= 4.9 && < 5.0+ , aeson+ , aeson-casing+ , bytestring+ , containers+ , data-default-class+ , http-client+ , http-conduit+ , http-types+ , lens+ , scientific+ , text+ , time++ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs++executable fcm-client+ hs-source-dirs: cli+ main-is: Main.hs+ other-modules: CliArgs++ build-depends: base >= 4.9 && < 5.0+ , aeson+ , async+ , data-default-class+ , bytestring+ , conduit+ , conduit-extra+ , fcm-client+ , http-client+ , http-types+ , lens+ , resourcet+ , retry+ , optparse-applicative+ , stm-conduit+ , text+ , utf8-string++ ghc-options: -Wall -fwarn-tabs -threaded -O2+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs++ build-depends: base >= 4.9 && < 5.0+ , aeson+ , containers+ , data-default-class+ , fcm-client+ , HUnit+ , lens+ , QuickCheck+ , test-framework+ , test-framework-hunit+ , test-framework-quickcheck2+ , text++ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs -fno-warn-orphans -fno-warn-missing-signatures
+ src/FCMClient.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+++-- | Firebase Cloud Messaging google client.+-- https://firebase.google.com/docs/cloud-messaging/concept-options#notifications_and_data_messages+module FCMClient (+ fcmCallJSON+, fcmJSONRequest+) where+++import Control.Exception+import qualified Data.Aeson as J+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import FCMClient.Types+import Network.HTTP.Client+import Network.HTTP.Simple+import Network.HTTP.Types+++-- | Makes an FCM JSON request, expects a JSON response.+-- https://firebase.google.com/docs/cloud-messaging/http-server-ref#send-downstream+fcmCallJSON :: (J.ToJSON req)+ => B.ByteString -- ^ authorization key+ -> req -- ^ FCM JSON message, a typed model or a document object+ -> IO FCMResult+fcmCallJSON authKey fcmMessage =+ handle (\ (he :: HttpException) -> return $ FCMResultError . FCMClientHTTPError . T.pack . show $ he) $ do+ hRes <- httpLBS (fcmJSONRequest authKey (J.encode fcmMessage))+ return $ decodeRes (responseBody hRes) (responseStatus hRes)++ where decodeRes rb rs | rs == status200 = case J.eitherDecode' rb+ of Left e -> FCMResultError $ FCMClientJSONError (T.pack e)+ Right b -> FCMResultSuccess b+ | rs == status400 = FCMResultError $ FCMErrorResponseInvalidJSON (textBody rb)+ | rs == status401 = FCMResultError $ FCMErrorResponseInvalidAuth+ | statusIsServerError rs = FCMResultError $ FCMServerError rs (textBody rb)+ | otherwise = FCMResultError $ FCMClientHTTPError $ "Unexpected response [" <> (T.pack . show $ rs) <> "]: " <> (textBody rb)++ textBody b = (T.decodeUtf8 . L.toStrict) b+++-- | Constructs an FCM JSON request, body and additional parameters such as+-- proxy or http manager can be set for a customized HTTP call.+fcmJSONRequest :: B.ByteString -- ^ authorization key+ -> L.ByteString -- ^ JSON POST data+ -> Request+fcmJSONRequest authKey jsonBytes =+ "https://fcm.googleapis.com/fcm/send"+ { method = "POST"+ , requestHeaders = [ (hAuthorization, "key=" <> authKey)+ , (hContentType, "application/json")+ ]+ , requestBody = RequestBodyLBS jsonBytes+ }
+ src/FCMClient/JSON/Types.hs view
@@ -0,0 +1,531 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+++-- | Google Firebase Cloud Messaging model / JSON conversions.+-- https://firebase.google.com/docs/cloud-messaging/http-server-ref+--+-- Data types in this module map field for field in the google docs.+-- See FCMClient.Types module for some wrapper functions on top of raw JSON types.+--+module FCMClient.JSON.Types (+ FCMData+, FCMNotification+, fcmTitle+, fcmBody+, fcmIcon+, fcmSound+, fcmTag+, fcmColor+, fcmBadge+, fcmClickAction+, fcmBodyLocKey+, fcmBodyLocArgs+, fcmTitleLocKey+, fcmTitleLocArgs+, FCMMessage+, fcmTo+, fcmRegistrationIDs+, fcmCondition+, fcmCollapseKey+, fcmPriority+, fcmContentAvailable+, fcmDelayWhileIdle+, fcmTimeToLive+, fcmRestrictedPackageName+, fcmDryRun+, fcmData+, fcmNotification+, FCMResult ( FCMResultSuccess+ , FCMResultError+ )+, _FCMResultSuccess+, _FCMResultError+, FCMClientError ( FCMErrorResponseInvalidJSON+ , FCMErrorResponseInvalidAuth+ , FCMServerError+ , FCMClientJSONError+ , FCMClientHTTPError+ )+, fcmErrorMessage+, fcmErrorHttpStatus+, _FCMErrorResponseInvalidJSON+, _FCMErrorResponseInvalidAuth+, _FCMServerError+, _FCMClientJSONError+, _FCMClientHTTPError+, FCMResponseBody(..)+, FCMMessageResponse+, _FCMMessageResponse+, _FCMTopicResponse+, fcmCanonicalIds+, fcmFailure+, fcmMulticastId+, fcmResults+, fcmSuccess+, FCMMessageResponseResult(..)+, _FCMMessageResponseResultOk+, _FCMMessageResponseResultError+, FCMMessageResponseResultOk+, fcmMessageId+, fcmRegistrationId+, FCMTopicResponse(..)+, FCMTopicResponseOk+, _FCMTopicResponseOk+, _FCMTopicResponseError+, fcmTopicMessageId+, FCMError(..)+) where+++import Control.Applicative+import Control.Lens.TH+import Data.Aeson+import Data.Aeson.Casing+import Data.Aeson.TH+import Data.Aeson.Types+import Data.Default.Class+import Data.List.NonEmpty (NonEmpty)+import Data.Map (Map)+import Data.Text (Text)+import Network.HTTP.Types (Status)+++type FCMData = Map Text Text+++-- | FCM Notification as defined in https://firebase.google.com/docs/cloud-messaging/http-server-ref#notification-payload-support+-- Abstract type, use lens API to access fields. Record fields are kept private and used for JSON conversion.+data FCMNotification =+ FCMNotification {++ -- | title Optional, string+ -- Indicates notification title. This field is not visible on iOS phones and tablets.+ _fcmTitle :: !(Maybe Text)++ -- | body Optional, string+ -- Indicates notification body text.+ , _fcmBody :: !(Maybe Text)++ -- | icon Optional, string+ -- Android: Indicates notification icon. Sets value to myicon for drawable resource myicon.+ , _fcmIcon :: !(Maybe Text)++ -- | sound Optional, string+ -- IOS: Indicates a sound to play when the device receives a notification. Sound+ -- files can be in the main bundle of the client app or in the+ -- Library/Sounds folder of the app's data container. See the iOS Developer+ -- Library for more information.+ -- Android: Indicates a sound to play when the device receives a+ -- notification. Supports default or the filename of a sound resource+ -- bundled in the app. Sound files must reside in /res/raw/.+ , _fcmSound :: !(Maybe Text)++ -- | tag Optional, string+ -- Android: Indicates whether each notification results in a new entry in the+ -- notification drawer on Android. If not set, each request creates a new+ -- notification. If set, and a notification with the same tag is already being+ -- shown, the new notification replaces the existing one in the notification+ -- drawer.+ , _fcmTag :: !(Maybe Text)++ -- | color Optional, string+ -- Android: Indicates color of the icon, expressed in #rrggbb format+ , _fcmColor:: !(Maybe Text)++ -- | badge Optional, string+ -- Indicates the badge on the client app home icon.+ , _fcmBadge :: !(Maybe Text)++ -- | click_action Optional, string+ -- IOS: Indicates the action associated with a user click on the notification.+ -- Corresponds to category in the APNs payload.+ -- Android: Indicates the action associated with a user click on the+ -- notification. When this is set, an activity with a matching intent+ -- filter is launched when user clicks the notification.+ , _fcmClickAction :: !(Maybe Text)++ -- | body_loc_key Optional, string+ -- IOS: Indicates the key to the body string for localization. Corresponds to+ -- "loc-key" in the APNs payload.+ -- Android: Indicates the key to the body string for localization. Use the+ -- key in the app's string resources when populating this value.+ , _fcmBodyLocKey :: !(Maybe Text)++ -- | body_loc_args Optional, JSON array as string+ -- IOS: Indicates the string value to replace format specifiers in the body string+ -- for localization. Corresponds to "loc-args" in the APNs payload.+ -- Android: Indicates the string value to replace format specifiers in the+ -- body string for localization. For more information, see Formatting and+ -- Styling.+ , _fcmBodyLocArgs :: !(Maybe Text)++ -- | title_loc_key Optional, string+ -- IOS: Indicates the key to the title string for localization. Corresponds to+ -- "title-loc-key" in the APNs payload.+ -- Android: Indicates the key to the title string for localization. Use the+ -- key in the app's string resources when populating this value.+ , _fcmTitleLocKey :: !(Maybe Text)+++ -- | title_loc_args Optional, JSON array as string+ -- IOS: Indicates the string value to replace format specifiers in the title+ -- string for localization.Corresponds to "title-loc-args" in the APNs+ -- payload.+ -- Android: Indicates the string value to replace format specifiers in the+ -- title string for localization. For more information, see Formatting+ -- strings.+ , _fcmTitleLocArgs:: !(Maybe Text)+ } deriving (Eq, Show)++$(makeLenses ''FCMNotification)+$(deriveJSON (aesonPrefix snakeCase) { omitNothingFields = True } ''FCMNotification)+++instance Default FCMNotification where+ def = FCMNotification Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+++-- | FCM Message as defined in https://firebase.google.com/docs/cloud-messaging/http-server-ref#send-downstream+-- Abstract type, use lens API to access fields. Record fields are kept private and used for JSON conversion.+data FCMMessage =+ FCMMessage {+ -- | to Optional, string+ -- This parameter specifies the recipient of a message.+ -- The value must be a registration token, notification key, or topic.+ -- Do not set this field when sending to multiple topics. See condition.+ _fcmTo :: !(Maybe Text)++ -- | registration_ids String array+ -- This parameter specifies a list of devices (registration tokens, or IDs)+ -- receiving a multicast message. It must contain at least 1 and at most 1000+ -- registration tokens.+ -- Use this parameter only for multicast messaging, not for single+ -- recipients. Multicast messages (sending to more than 1 registration tokens) are+ -- allowed using HTTP JSON format only.+ , _fcmRegistrationIDs :: !(Maybe (NonEmpty Text))++ -- | condition Optional, string+ -- This parameter specifies a logical expression of conditions that determine+ -- the message target. Supported condition: Topic, formatted as "'yourTopic' in+ -- topics". This value is case-insensitive. Supported operators: &&, ||. Maximum+ -- two operators per topic message supported.+ , _fcmCondition :: !(Maybe Text)++ -- | collapse_key Optional, string+ -- This parameter identifies a group of messages (e.g., with collapse_key:+ -- "Updates Available") that can be collapsed, so that only the last message gets+ -- sent when delivery can be resumed. This is intended to avoid sending too many+ -- of the same messages when the device comes back online or becomes active (see+ -- delay_while_idle).+ -- Note that there is no guarantee of the order in which messages get sent.+ -- Note: A maximum of 4 different collapse keys is allowed at any given time.+ -- This means a FCM connection server can simultaneously store 4 different+ -- send-to-sync messages per client app. If you exceed this number, there is no+ -- guarantee which 4 collapse keys the FCM connection server will keep.+ , _fcmCollapseKey :: !(Maybe Text)++ -- | priority Optional, string+ -- Sets the priority of the message. Valid values are "normal" and "high." On+ -- iOS, these correspond to APNs priorities 5 and 10. By default, messages are+ -- sent with normal priority. Normal priority optimizes the client app's+ -- battery consumption and should be used unless immediate delivery is+ -- required. For messages with normal priority, the app may receive the message+ -- with unspecified delay. When a message is sent with high priority, it is+ -- sent immediately, and the app can wake a sleeping device and open a network+ -- connection to your server. For more information, see Setting the priority+ -- of a message.+ , _fcmPriority :: !(Maybe Text)++ -- | content_available Optional, JSON boolean+ -- On iOS, use this field to represent content-available in the APNS+ -- payload. When a notification or message is sent and this is set to true,+ -- an inactive client app is awoken. On Android, data messages wake the app+ -- by default. On Chrome, currently not supported.+ , _fcmContentAvailable :: !(Maybe Bool)++ -- | delay_while_idle Optional, JSON boolean+ -- When this parameter is set to true, it indicates that the message should+ -- not be sent until the device becomes active. The default value is false.+ , _fcmDelayWhileIdle :: !(Maybe Bool)++ -- | time_to_live Optional, JSON number+ -- This parameter specifies how long (in seconds) the message should be kept in+ -- FCM storage if the device is offline. The maximum time to live supported is+ -- 4 weeks, and the default value is 4 weeks. For more information, see Setting+ -- the lifespan of a message.+ , _fcmTimeToLive :: !(Maybe Word)++ -- | restricted_package_name Optional, string+ -- This parameter specifies the package name of the application where the+ -- registration tokens must match in order to receive the message.+ , _fcmRestrictedPackageName :: !(Maybe Text)++ -- | dry_run Optional, JSON boolean+ -- This parameter, when set to true, allows developers to test a request+ -- without actually sending a message. The default value is false.+ , _fcmDryRun :: !(Maybe Bool)++ -- Payload++ -- | data Optional, JSON object+ -- This parameter specifies the custom key-value pairs of the message's+ -- payload. For example, with data:{"score":"3x1"}: On iOS, if the message is+ -- sent via APNS, it represents the custom data fields. If it is sent via FCM+ -- connection server, it would be represented as key value dictionary in+ -- AppDelegate application:didReceiveRemoteNotification:. On Android, this+ -- would result in an intent extra named score with the string value 3x1. The+ -- key should not be a reserved word ("from" or any word starting with+ -- "google" or "gcm"). Do not use any of the words defined in this table (such+ -- as collapse_key). Values in string types are recommended. You have to+ -- convert values in objects or other non-string data types (e.g., integers or+ -- booleans) to string.+ , _fcmData :: !(Maybe FCMData)++ -- | notification Optional, JSON object+ -- This parameter specifies the predefined, user-visible key-value pairs of+ -- the notification payload. See Notification payload support for detail.+ -- For more information about notification message and data message+ -- options, see Payload.+ , _fcmNotification :: !(Maybe FCMNotification)+ } deriving (Eq, Show)+++$(makeLenses ''FCMMessage)+$(deriveJSON (aesonPrefix snakeCase) { omitNothingFields = True } ''FCMMessage)+++instance Default FCMMessage where+ def = FCMMessage Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing+++-- | String specifying the error that occurred when processing the message+-- for the recipient. The possible values can be found in table 9.+-- https://firebase.google.com/docs/cloud-messaging/http-server-ref#table9+data FCMError =+ FCMErrorDeviceMessageRate+ | FCMErrorInternalServerError+ | FCMErrorInvalidDataKey+ | FCMErrorInvalidPackageName+ | FCMErrorInvalidRegistration+ | FCMErrorInvalidTtl+ | FCMErrorMessageTooBig+ | FCMErrorMismatchSenderId+ | FCMErrorMissingRegistration+ | FCMErrorNotRegistered+ | FCMErrorTopicsMessageRate+ | FCMErrorUnavailable+ | FCMErrorOther Text -- ^ used if we can't parse any of the above+ deriving (Eq, Show)++instance ToJSON FCMError where+ toJSON FCMErrorDeviceMessageRate = object [ ("error", "DeviceMessageRate") ]+ toJSON FCMErrorInternalServerError = object [ ("error", "InternalServerError") ]+ toJSON FCMErrorInvalidDataKey = object [ ("error", "InvalidDataKey") ]+ toJSON FCMErrorInvalidPackageName = object [ ("error", "InvalidPackageName") ]+ toJSON FCMErrorInvalidRegistration = object [ ("error", "InvalidRegistration") ]+ toJSON FCMErrorInvalidTtl = object [ ("error", "InvalidTtl") ]+ toJSON FCMErrorMessageTooBig = object [ ("error", "MessageTooBig") ]+ toJSON FCMErrorMismatchSenderId = object [ ("error", "MismatchSenderId") ]+ toJSON FCMErrorMissingRegistration = object [ ("error", "MissingRegistration") ]+ toJSON FCMErrorNotRegistered = object [ ("error", "NotRegistered") ]+ toJSON FCMErrorTopicsMessageRate = object [ ("error", "TopicsMessageRate") ]+ toJSON FCMErrorUnavailable = object [ ("error", "Unavailable") ]+ toJSON (FCMErrorOther e) = object [ ("error", toJSON e) ]+++instance FromJSON FCMError where+ parseJSON (Object v) = fmap ( \(n :: Text) ->+ case n+ of "DeviceMessageRate" -> FCMErrorDeviceMessageRate+ "InternalServerError" -> FCMErrorInternalServerError+ "InvalidDataKey" -> FCMErrorInvalidDataKey+ "InvalidPackageName" -> FCMErrorInvalidPackageName+ "InvalidRegistration" -> FCMErrorInvalidRegistration+ "InvalidTtl" -> FCMErrorInvalidTtl+ "MessageTooBig" -> FCMErrorMessageTooBig+ "MismatchSenderId" -> FCMErrorMismatchSenderId+ "MissingRegistration" -> FCMErrorMissingRegistration+ "NotRegistered" -> FCMErrorNotRegistered+ "TopicsMessageRate" -> FCMErrorTopicsMessageRate+ "Unavailable" -> FCMErrorUnavailable+ e -> FCMErrorOther e+ ) (v .: "error")++ parseJSON x = typeMismatch "Object" x++++data FCMMessageResponseResultOk =+ FCMMessageResponseResultOkPayload {+ -- | String specifying a unique ID for each successfully processed message.+ _fcmMessageId :: !Text++ -- | Optional string specifying the canonical registration token for the+ -- client app that the message was processed and sent to. Sender should use+ -- this value as the registration token for future requests. Otherwise, the+ -- messages might be rejected.+ , _fcmRegistrationId :: !(Maybe Text)+ } deriving (Eq, Show)++$(makeLenses ''FCMMessageResponseResultOk)+$(deriveJSON (aesonPrefix snakeCase) { omitNothingFields = True } ''FCMMessageResponseResultOk)++instance Default FCMMessageResponseResultOk where+ def = FCMMessageResponseResultOkPayload "" Nothing++data FCMMessageResponseResult =+ FCMMessageResponseResultOk !FCMMessageResponseResultOk+ | FCMMessageResponseResultError !FCMError+ deriving (Eq, Show)++$(makePrisms ''FCMMessageResponseResult)++instance ToJSON FCMMessageResponseResult where+ toJSON (FCMMessageResponseResultOk b) = toJSON b+ toJSON (FCMMessageResponseResultError e) = toJSON e+ toEncoding (FCMMessageResponseResultOk b) = toEncoding b+ toEncoding (FCMMessageResponseResultError e) = toEncoding e++instance FromJSON FCMMessageResponseResult where+ parseJSON o = (FCMMessageResponseResultOk <$> parseJSON o)+ <|> (FCMMessageResponseResultError <$> parseJSON o)+++data FCMMessageResponse =+ FCMMessageResponsePayload {+ -- | Required, number Unique ID (number) identifying the multicast message.+ _fcmMulticastId :: !Integer++ -- | Required, number Number of messages that were processed without an error.+ , _fcmSuccess :: !Integer++ -- | Required, number Number of messages that could not be processed.+ , _fcmFailure :: !Integer++ -- | Required, number Number of results that contain a canonical+ -- registration token. See the registration overview for more discussion of+ -- this topic.+ , _fcmCanonicalIds :: !Integer++ -- | Optional, array object Array of objects representing the status of+ -- the messages processed. The objects are listed in the same order as the+ -- request (i.e., for each registration ID in the request, its result is+ -- listed in the same index in the response).+ , _fcmResults :: !(Maybe (NonEmpty FCMMessageResponseResult))+ } deriving (Eq, Show)++$(makeLenses ''FCMMessageResponse)+$(deriveJSON (aesonPrefix snakeCase) { omitNothingFields = True } ''FCMMessageResponse)++instance Default FCMMessageResponse where+ def = FCMMessageResponsePayload 0 0 0 0 Nothing++data FCMTopicResponseOk =+ FCMTopicResponseOkPayload {+ -- | Optional, number The topic message ID when FCM has successfully+ -- received the request and will attempt to deliver to all subscribed+ -- devices.+ _fcmTopicMessageId :: !Integer+ } deriving (Eq, Show)++$(makeLenses ''FCMTopicResponseOk )+$(deriveJSON (aesonDrop 9 snakeCase) { omitNothingFields = True } ''FCMTopicResponseOk)++instance Default FCMTopicResponseOk where+ def = FCMTopicResponseOkPayload 0++data FCMTopicResponse =+ FCMTopicResponseOk !FCMTopicResponseOk+ | FCMTopicResponseError !FCMError+ deriving (Eq, Show)++$(makePrisms ''FCMTopicResponse)+++instance ToJSON FCMTopicResponse where+ toJSON (FCMTopicResponseOk o) = toJSON o+ toJSON (FCMTopicResponseError e) = toJSON e++ toEncoding (FCMTopicResponseOk o) = toEncoding o+ toEncoding (FCMTopicResponseError e) = toEncoding e++instance FromJSON FCMTopicResponse where+ parseJSON o = (FCMTopicResponseOk <$> parseJSON o)+ <|> (FCMTopicResponseError <$> parseJSON o)+++data FCMResponseBody = FCMMessageResponse !FCMMessageResponse+ | FCMTopicResponse !FCMTopicResponse+ deriving (Eq, Show)++$(makePrisms ''FCMResponseBody)++instance ToJSON FCMResponseBody where+ toJSON (FCMMessageResponse m) = toJSON m+ toJSON (FCMTopicResponse t) = toJSON t++ toEncoding (FCMMessageResponse m) = toEncoding m+ toEncoding (FCMTopicResponse t) = toEncoding t++instance FromJSON FCMResponseBody where+ parseJSON o = (FCMMessageResponse <$> parseJSON o)+ <|> (FCMTopicResponse <$> parseJSON o)+++-- | Types of FCM errors.+data FCMClientError =+ -- | Indicates that the request could not be parsed as JSON, or it+ -- contained invalid fields (for instance, passing a string where a number+ -- was expected). The exact failure reason is described in the response and+ -- the problem should be addressed before the request can be retried.+ FCMErrorResponseInvalidJSON { _fcmErrorMessage :: !Text+ }++ -- | There was an error authenticating the sender account.+ | FCMErrorResponseInvalidAuth++ -- | Errors in the 500-599 range (such as 500 or 503) indicate that there+ -- was an internal error in the FCM connection server while trying to+ -- process the request, or that the server is temporarily unavailable (for+ -- example, because of timeouts). Sender must retry later, honoring any+ -- Retry-After header included in the response. Application servers must+ -- implement exponential back-off.+ | FCMServerError { _fcmErrorHttpStatus :: !Status+ , _fcmErrorMessage :: !Text+ }++ -- | Client couldn't parse JSON response from server.+ | FCMClientJSONError { _fcmErrorMessage :: !Text+ }++ -- | Unexpected HTTP response or some other HTTP error.+ | FCMClientHTTPError { _fcmErrorMessage :: !Text+ }+ deriving (Show)++$(makeLenses ''FCMClientError)+$(makePrisms ''FCMClientError)+++-- | Result of an RPC call.+--+-- Successful response doesn't imply all the messages were delivered,+-- e.g. some may need to be re-sent if a rate limit was exceeded.+--+-- Error cases enumerate all, client and server error conditions.+--+data FCMResult =+ -- | Successful response (http 200).+ -- Doesn't imply all the messages were delivered,+ -- response body may contain error codes.+ FCMResultSuccess !FCMResponseBody++ -- | Didn't receive JSON response, there were an error of some kind.+ | FCMResultError !FCMClientError+ deriving (Show)++$(makePrisms ''FCMResult)
+ src/FCMClient/Types.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+++-- | Google Firebase Cloud Messaging model / JSON conversions.+-- https://firebase.google.com/docs/cloud-messaging/http-server-ref+--+-- This module re-exports JSON types with a few convenience wrappers+-- around selected fields.+--+module FCMClient.Types (+ J.FCMData+, FCMPriority(..)+, FCMLocValue(..)+, J.FCMNotification+, J.fcmTitle+, J.fcmBody+, J.fcmIcon+, J.fcmSound+, J.fcmTag+, J.fcmColor+, J.fcmBadge+, J.fcmClickAction+, J.fcmBodyLocKey+, fcmBodyLocArgs+, J.fcmTitleLocKey+, fcmTitleLocArgs+, J.FCMMessage+, J.fcmTo+, J.fcmRegistrationIDs+, J.fcmCondition+, J.fcmCollapseKey+, fcmPriority+, fcmContentAvailable+, fcmDelayWhileIdle+, J.fcmTimeToLive+, J.fcmRestrictedPackageName+, fcmDryRun+, J.fcmData+, J.fcmNotification+, fcmWithNotification+, J.FCMResult ( J.FCMResultSuccess+ , J.FCMResultError+ )+, J._FCMResultSuccess+, J._FCMResultError+, J.FCMClientError ( J.FCMErrorResponseInvalidJSON+ , J.FCMErrorResponseInvalidAuth+ , J.FCMServerError+ , J.FCMClientJSONError+ , J.FCMClientHTTPError+ )+, J.fcmErrorMessage+, J.fcmErrorHttpStatus+, J._FCMErrorResponseInvalidJSON+, J._FCMErrorResponseInvalidAuth+, J._FCMServerError+, J._FCMClientJSONError+, J._FCMClientHTTPError+, J.FCMResponseBody(..)+, J.FCMMessageResponse+, J._FCMMessageResponse+, J._FCMTopicResponse+, J.fcmCanonicalIds+, J.fcmFailure+, J.fcmMulticastId+, J.fcmResults+, J.fcmSuccess+, J.FCMMessageResponseResult(..)+, J._FCMMessageResponseResultOk+, J._FCMMessageResponseResultError+, J.FCMMessageResponseResultOk+, J.fcmMessageId+, J.fcmRegistrationId+, J.FCMTopicResponse(..)+, J.FCMTopicResponseOk+, J._FCMTopicResponseOk+, J._FCMTopicResponseError+, J.fcmTopicMessageId+, J.FCMError(..)+) where+++import Control.Lens+import Data.Aeson+import Data.Aeson.Types as J+import Data.Default.Class+import Data.List.NonEmpty (nonEmpty)+import Data.Maybe+import Data.Scientific (Scientific)+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as TE+import qualified FCMClient.JSON.Types as J+++++data FCMPriority = FCMPriorityNormal+ | FCMPriorityHigh+ deriving (Eq, Show, Ord)++-- A subset of JSON values suitable for string localization format+data FCMLocValue = FCMLocString !Text+ | FCMLocNumber !Scientific+ | FCMLocBool !Bool+ deriving (Eq, Read, Show, Ord)++instance ToJSON FCMLocValue where+ toJSON (FCMLocString x) = toJSON x+ toJSON (FCMLocNumber x) = toJSON x+ toJSON (FCMLocBool x) = toJSON x++ toEncoding (FCMLocString x) = toEncoding x+ toEncoding (FCMLocNumber x) = toEncoding x+ toEncoding (FCMLocBool x) = toEncoding x++instance FromJSON FCMLocValue where+ parseJSON (J.String x) = return $ FCMLocString x+ parseJSON (J.Number x) = return $ FCMLocNumber x+ parseJSON (J.Bool x) = return $ FCMLocBool x+ parseJSON _ = fail "FCMLocValue"+++-- | Shortcut for string localized parameters+instance IsString FCMLocValue where+ fromString = FCMLocString . T.pack+++-- | Utility function, Aeson-convert to Text (some JSON string fields are expected to contain JSON).+aesonTxtPr :: (Applicative f, Choice p, ToJSON a1, FromJSON a)+ => p [a] (f [a1])+ -> p (Maybe Text) (f (Maybe Text))+aesonTxtPr =+ (prism' (fmap (LT.toStrict . TE.decodeUtf8)) (Just . (fmap (TE.encodeUtf8 . LT.fromStrict)))) .+ (prism' (fmap (encode) . nonEmpty) (Just . fromMaybe [] . decode . fromMaybe ""))+++-- | Typed lens focused on localized notification body arguments.+fcmBodyLocArgs :: (Applicative f)+ => ([FCMLocValue] -> f [FCMLocValue])+ -> J.FCMNotification -> f J.FCMNotification+fcmBodyLocArgs = J.fcmBodyLocArgs . aesonTxtPr++++-- | Typed lens focused on localized notification title arguments.+fcmTitleLocArgs :: (Applicative f)+ => ([FCMLocValue] -> f [FCMLocValue])+ -> J.FCMNotification -> f J.FCMNotification+fcmTitleLocArgs = J.fcmTitleLocArgs . aesonTxtPr++++-- | Typed lens focused on message priority.+fcmPriority :: (Applicative f)+ => (FCMPriority -> f FCMPriority)+ -> J.FCMMessage -> f J.FCMMessage+fcmPriority = J.fcmPriority . (prism' fcmPriorityToText (Just .textToFcmPriority))+ where fcmPriorityToText FCMPriorityNormal = Nothing+ fcmPriorityToText FCMPriorityHigh = Just "high"+ textToFcmPriority (Just "high") = FCMPriorityHigh+ textToFcmPriority _ = FCMPriorityNormal++++maybeBoolPr :: (Applicative f)+ => (Bool -> f Bool)+ -> (Maybe Bool) -> f (Maybe Bool)+maybeBoolPr = prism' (\x -> if x then Just x else Nothing) (Just . fromMaybe False)+++-- | Sets content available field when True, sets Nothing when False.+fcmContentAvailable :: (Applicative f)+ => (Bool -> f Bool)+ -> J.FCMMessage -> f J.FCMMessage+fcmContentAvailable = J.fcmContentAvailable . maybeBoolPr+++-- | Sets delay while idle field when True, sets Nothing when False.+fcmDelayWhileIdle :: (Applicative f)+ => (Bool -> f Bool)+ -> J.FCMMessage -> f J.FCMMessage+fcmDelayWhileIdle = J.fcmDelayWhileIdle . maybeBoolPr+++-- | Sets dry run field when True, sets Nothing when False.+fcmDryRun :: (Applicative f)+ => (Bool -> f Bool)+ -> J.FCMMessage -> f J.FCMMessage+fcmDryRun = J.fcmDryRun . maybeBoolPr+++-- | Creates default empty notification if missing+fcmWithNotification :: (Applicative f)+ => (J.FCMNotification -> f J.FCMNotification)+ -> J.FCMMessage -> f J.FCMMessage+fcmWithNotification = J.fcmNotification . justNotif+ where justNotif f maybeN = case maybeN+ of Nothing -> fmap Just (f def)+ Just n -> fmap Just (f n)
+ test/Spec.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main+where+++import Control.Lens+import Data.Aeson+import Data.Default.Class+import qualified Data.Map as Map+import FCMClient.Types+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.HUnit+import Test.HUnit+++main = defaultMain tests++tests = [ testGroup "JSON" [+ testCase "notification" test_notificationJSON+ , testCase "message" test_messageJSON+ , testCase "response" test_responseJSON+ ]+ ]++test_notificationJSON = do+ (encode (def :: FCMNotification)) @?= "{}"++ (encode $ fcmBody .~ (Just "fcm body") $ def) @?=+ "{\"body\":\"fcm body\"}"++ (encode $ fcmColor .~ (Just "#001122") $ def) @?=+ "{\"color\":\"#001122\"}"++ (encode $ fcmTitleLocKey .~ (Just $ "loc title") $+ fcmTitleLocArgs .~ ([]) $+ def) @?=+ "{\"title_loc_key\":\"loc title\"}"++ (encode $ fcmTitleLocKey .~ (Just $ "loc title") $+ fcmTitleLocArgs .~ ([FCMLocString "locStr", FCMLocNumber 1.0, FCMLocBool True]) $+ def) @?=+ "{\"title_loc_key\":\"loc title\",\"title_loc_args\":\"[\\\"locStr\\\",1,true]\"}"+++ (encode $ fcmBodyLocKey .~ (Just $ "loc body") $+ fcmBodyLocArgs .~ (["locStr", FCMLocNumber 1.0, FCMLocBool True]) $+ def) @?=+ "{\"body_loc_key\":\"loc body\",\"body_loc_args\":\"[\\\"locStr\\\",1,true]\"}"+++test_messageJSON = do+ (encode (def :: FCMMessage)) @?= "{}"++ (encode $ fcmCollapseKey .~ (Just "ckey") $+ fcmTimeToLive .~ (Just 3) $+ fcmData .~ (Just (Map.fromList [("foo","bar")])) $+ def) @?=+ "{\"collapse_key\":\"ckey\",\"time_to_live\":3,\"data\":{\"foo\":\"bar\"}}"++ (encode $ fcmPriority .~ FCMPriorityHigh $ def) @?=+ "{\"priority\":\"high\"}"++ (encode $ fcmPriority .~ FCMPriorityNormal $ def) @?= "{}"++ (encode $ fcmContentAvailable .~ False $ def) @?= "{}"++ (encode $ fcmContentAvailable .~ True $ def) @?= "{\"content_available\":true}"++ (decode "{\"content_available\":true}") ^.. (_Just . fcmContentAvailable) @?= [True]++ (encode $ def &+ ( (fcmContentAvailable .~ True)+ . ( fcmWithNotification %~ ( (fcmBody .~ Just "n body")+ . (fcmTitle .~ Just "n title")+ )+ )+ )+ ) @?= "{\"content_available\":true,\"notification\":{\"title\":\"n title\",\"body\":\"n body\"}}"+++test_responseJSON = do+ (encode (FCMMessageResponse def)) @?= "{\"multicast_id\":0,\"success\":0,\"failure\":0,\"canonical_ids\":0}"++ (encode (FCMTopicResponseOk def)) @?= "{\"message_id\":0}"++ (decode "{\"message_id\":6538060933731373360}") ^..+ (_Just . _FCMTopicResponse . _FCMTopicResponseOk . fcmTopicMessageId ) @?= [6538060933731373360]++ let jRes = "{\"multicast_id\":4984205480219716339,\"success\":0,\"failure\":1,\"canonical_ids\":0,\"results\":[{\"error\":\"NotRegistered\"}]}"++ (decode jRes) ^..+ (_Just . _FCMMessageResponse . fcmResults . _Just . traverse . _FCMMessageResponseResultError ) @?=+ [FCMErrorNotRegistered]++ (decode jRes) ^.. (_Just . _FCMMessageResponse . fcmMulticastId ) @?= [4984205480219716339]