diff --git a/cli/Main.hs b/cli/Main.hs index 5a63af5..3257ced 100644 --- a/cli/Main.hs +++ b/cli/Main.hs @@ -26,8 +26,6 @@ import Data.Default.Class import Data.Monoid import FCMClient import FCMClient.Types -import Network.HTTP.Client -import Network.HTTP.Types import System.IO @@ -37,9 +35,10 @@ main = runWithArgs $ \CliArgs{..} -> do let sendMessage msgMod = do let msg = msgMod def putStrLn $ (LUTF8.toString . encode) msg - res <- fcmCallJSON (UTF8.fromString cliAuthKey) msg :: IO (Response Object) - putStrLn $ show res - putStrLn $ (LUTF8.toString . encode) (responseBody res) + 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 @@ -89,30 +88,33 @@ callFCMConduit :: (MonadIO m, MonadResource m) -> 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 m -> recovering retPolicy [logRet] (const $ sendMessage m) + 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 - logRet = logRetries (\ (_ :: HttpException) -> return True) - (\ _ e _ -> liftIO $ hPutStrLn stderr $ "HTTP error: " <> (show e)) - - sendMessage :: (Value, FCMMessage) -> IO Value - sendMessage (jm,m) = do - res <- fcmCallJSON authKey m - - let mkRes t = object [ ("type", t) - , ("message", jm) - , ("response", responseBody res) - ] - - return $ if ( responseStatus res == status200) - then mkRes "Success" - else mkRes "ServerError" - + 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) diff --git a/src/FCMClient.hs b/src/FCMClient.hs index c313a9b..f8ed915 100644 --- a/src/FCMClient.hs +++ b/src/FCMClient.hs @@ -10,10 +10,14 @@ module FCMClient ( ) 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 @@ -21,12 +25,24 @@ 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, J.FromJSON res) +fcmCallJSON :: (J.ToJSON req) => B.ByteString -- ^ authorization key -> req -- ^ FCM JSON message, a typed model or a document object - -> IO (Response res) + -> IO FCMResult fcmCallJSON authKey fcmMessage = - httpJSON (fcmJSONRequest authKey (J.encode 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 @@ -41,4 +57,5 @@ fcmJSONRequest authKey jsonBytes = , (hContentType, "application/json") ] , requestBody = RequestBodyLBS jsonBytes + , checkStatus = (\ _ _ _ -> Nothing) } diff --git a/src/FCMClient/JSON/Types.hs b/src/FCMClient/JSON/Types.hs index 57668da..b659bdd 100644 --- a/src/FCMClient/JSON/Types.hs +++ b/src/FCMClient/JSON/Types.hs @@ -39,17 +39,24 @@ module FCMClient.JSON.Types ( , fcmDryRun , fcmData , fcmNotification -, FCMResponse( FCMResponseOk - , FCMResponseInvalidJSON - , FCMResponseInvalidAuth - , FCMResponseServerError ) -, _FCMResponseOk -, _FCMResponseInvalidJSON -, _FCMResponseInvalidAuth -, _FCMResponseServerError -, fcmResponseBody -, fcmResponseErrorMessage -, fcmResponseRetryAfter +, FCMResult ( FCMResultSuccess + , FCMResultError + ) +, _FCMResultSuccess +, _FCMResultError +, FCMClientError ( FCMErrorResponseInvalidJSON + , FCMErrorResponseInvalidAuth + , FCMServerError + , FCMClientJSONError + , FCMClientHTTPError + ) +, fcmErrorMessage +, fcmErrorHttpStatus +, _FCMErrorResponseInvalidJSON +, _FCMErrorResponseInvalidAuth +, _FCMServerError +, _FCMClientJSONError +, _FCMClientHTTPError , FCMResponseBody(..) , FCMMessageResponse , _FCMMessageResponse @@ -84,7 +91,7 @@ import Data.Default.Class import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Text (Text) -import Data.Time.Clock +import Network.HTTP.Types (Status) type FCMData = Map Text Text @@ -469,22 +476,56 @@ instance FromJSON FCMResponseBody where <|> (FCMTopicResponse <$> parseJSON o) -data FCMResponse = FCMResponseOk { _fcmResponseBody :: !FCMResponseBody - - -- | value of the Retry-After header - -- could be set if some of the messages exceeded rate - , _fcmResponseRetryAfter :: !(Maybe UTCTime) - } - | FCMResponseInvalidJSON { _fcmResponseErrorMessage :: !Text - } - | FCMResponseInvalidAuth { _fcmResponseErrorMessage :: !Text - } - | FCMResponseServerError { _fcmResponseErrorMessage :: !Text - -- | value of the Retry-After header - -- could be set if topic or some of the messages exceeded rate - , _fcmResponseRetryAfter :: !(Maybe UTCTime) - } - deriving (Eq, Show) - -$(makeLenses ''FCMResponse) -$(makePrisms ''FCMResponse) +-- | 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) diff --git a/src/FCMClient/Types.hs b/src/FCMClient/Types.hs index ca03fed..59878fa 100644 --- a/src/FCMClient/Types.hs +++ b/src/FCMClient/Types.hs @@ -42,18 +42,24 @@ module FCMClient.Types ( , J.fcmData , J.fcmNotification , fcmWithNotification - -, J.FCMResponse( J.FCMResponseOk - , J.FCMResponseInvalidJSON - , J.FCMResponseInvalidAuth - , J.FCMResponseServerError ) -, J._FCMResponseOk -, J._FCMResponseInvalidJSON -, J._FCMResponseInvalidAuth -, J._FCMResponseServerError -, J.fcmResponseBody -, J.fcmResponseErrorMessage -, J.fcmResponseRetryAfter +, 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 diff --git a/stack.yaml b/stack.yaml index d118d37..a9eaf31 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,5 @@ # This file was automatically generated by 'stack init' -# +# # Some commonly used options have been documented as comments in this file. # For advanced use and comprehensive documentation of the format, please see: # http://docs.haskellstack.org/en/stable/yaml_configuration/ @@ -7,7 +7,7 @@ # Resolver to choose a 'specific' stackage snapshot or a compiler version. # A snapshot resolver dictates the compiler version and the set of packages # to be used for project dependencies. For example: -# +# # resolver: lts-3.5 # resolver: nightly-2015-09-21 # resolver: ghc-7.10.2 @@ -15,11 +15,11 @@ # resolver: # name: custom-snapshot # location: "./custom-snapshot.yaml" -resolver: lts-7.0 +resolver: lts-7.2 # User packages to be built. # Various formats can be used as shown in the example below. -# +# # packages: # - some-directory # - https://example.com/foo/bar/baz-0.0.2.tar.gz @@ -31,7 +31,7 @@ resolver: lts-7.0 # subdirs: # - auto-update # - wai -# +# # A package marked 'extra-dep: true' will only be built if demanded by a # non-dependency (i.e. a user package), and its test suites and benchmarks # will not be run. This is useful for tweaking upstream packages. @@ -49,18 +49,18 @@ extra-package-dbs: [] # Control whether we use the GHC we find on the path # system-ghc: true -# +# # Require a specific version of stack, using version ranges # require-stack-version: -any # Default # require-stack-version: ">=1.1" -# +# # Override the architecture used by stack, especially useful on Windows # arch: i386 # arch: x86_64 -# +# # Extra directories used by stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] -# +# # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor