Skip to content

Commit

Permalink
Added FCMResult.
Browse files Browse the repository at this point in the history
  • Loading branch information
@andreyk0
andreyk0 committed Oct 2, 2016
1 parent 09a6683 commit de2cb40
Show file tree
Hide file tree
Showing 5 changed files with 147 additions and 81 deletions.
54 changes: 28 additions & 26 deletions cli/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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


Expand All @@ -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
Expand Down Expand Up @@ -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)
Expand Down
23 changes: 20 additions & 3 deletions src/FCMClient.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,23 +10,39 @@ 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


-- | 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
Expand All @@ -41,4 +57,5 @@ fcmJSONRequest authKey jsonBytes =
, (hContentType, "application/json")
]
, requestBody = RequestBodyLBS jsonBytes
, checkStatus = (\ _ _ _ -> Nothing)
}
103 changes: 72 additions & 31 deletions src/FCMClient/JSON/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
30 changes: 18 additions & 12 deletions src/FCMClient/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
18 changes: 9 additions & 9 deletions stack.yaml
View file
Original file line number Diff line number Diff line change
@@ -1,25 +1,25 @@
# 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/

# 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
# resolver: ghcjs-0.1.0_ghc-7.10.2
# 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
Expand All @@ -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.
Expand All @@ -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

0 comments on commit de2cb40

Please sign in to comment.