diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,15 @@ + +0.1.2.0 +======= + +- Threading bugfix +- Migrate to http2-client-0.9.0.0 and lts-14 + +0.1.1.1 +======= + +- Improve error handling + 0.1.1.0 ======= diff --git a/push-notify-apn.cabal b/push-notify-apn.cabal --- a/push-notify-apn.cabal +++ b/push-notify-apn.cabal @@ -1,5 +1,5 @@ name: push-notify-apn -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Send push notifications to mobile iOS devices description: push-notify-apn is a library and command line utility that can be used to send @@ -12,7 +12,7 @@ license-file: LICENSE author: Hans-Christian Esperer maintainer: hc@hcesperer.org -copyright: 2017 Memrange UG +copyright: 2017-2018 Memrange UG category: Network, Cloud, Mobile build-type: Simple extra-source-files: README.md @@ -31,6 +31,7 @@ , data-default , http2 , http2-client + , lifted-base , random , semigroups , text @@ -63,6 +64,7 @@ , hspec ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 + other-modules: Network.PushNotify.APNSpec source-repository head type: git diff --git a/src/Network/PushNotify/APN.hs b/src/Network/PushNotify/APN.hs --- a/src/Network/PushNotify/APN.hs +++ b/src/Network/PushNotify/APN.hs @@ -9,6 +9,8 @@ -- Send push notifications using Apple's HTTP2 APN API {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Network.PushNotify.APN @@ -32,6 +34,7 @@ , clearBadge , clearCategory , clearSound + , addSupplementalField , closeSession , isOpen , ApnSession @@ -39,12 +42,14 @@ , JsonApsAlert , JsonApsMessage , ApnMessageResult(..) + , ApnFatalError(..) + , ApnTemporaryError(..) , ApnToken ) where import Control.Concurrent import Control.Concurrent.QSem -import Control.Exception +import Control.Exception.Lifted (Exception, bracket_, throw, throwIO) import Control.Monad import Data.Aeson import Data.Aeson.Types @@ -56,11 +61,16 @@ import Data.IORef import Data.Map.Strict (Map) import Data.Maybe +import Data.Semigroup ((<>)) import Data.Text (Text) +import Data.Time.Clock import Data.Time.Clock.POSIX +import Data.Typeable (Typeable) import Data.X509 import Data.X509.CertificateStore import GHC.Generics +import Network.HTTP2 (ErrorCodeId, + toErrorCodeId) import Network.HTTP2.Client import Network.HTTP2.Client.FrameConnection import Network.HTTP2.Client.Helpers @@ -110,7 +120,7 @@ newtype ApnToken = ApnToken { unApnToken :: ByteString } class SpecifyError a where - isAnError :: a + isAnError :: IOError -> a -- | Create a token from a raw bytestring rawToken @@ -128,16 +138,23 @@ -- ^ The resulting token hexEncodedToken = ApnToken . B16.encode . fst . B16.decode . TE.encodeUtf8 +-- | Exceptional responses to a send request +data ApnException = ApnExceptionHTTP ErrorCodeId + | ApnExceptionJSON String + | ApnExceptionMissingHeader HTTP2.HeaderName + | ApnExceptionUnexpectedResponse + deriving (Show, Typeable) + +instance Exception ApnException + -- | The result of a send request data ApnMessageResult = ApnMessageResultOk - | ApnMessageResultFatalError - | ApnMessageResultBadDeviceToken - | ApnMessageResultTemporaryError - | ApnMessageResultTokenNoLongerValid - deriving (Enum, Eq, Show) - -instance SpecifyError ApnMessageResult where - isAnError = ApnMessageResultTemporaryError + | ApnMessageResultBackoff + | ApnMessageResultFatalError ApnFatalError + | ApnMessageResultTemporaryError ApnTemporaryError + | ApnMessageResultIOError IOError + | ApnMessageResultClientError ClientError + deriving (Eq, Show) -- | The specification of a push notification's message body data JsonApsAlert = JsonApsAlert @@ -293,11 +310,17 @@ -- ^ The main content of the message , jaAppSpecificContent :: !(Maybe Text) -- ^ Extra information to be used by the receiving app + , jaSupplementalFields :: !(Map Text Value) + -- ^ Additional fields to be used by the receiving app } deriving (Generic, Show) instance ToJSON JsonAps where - toJSON = genericToJSON defaultOptions - { fieldLabelModifier = drop 2 . map toLower } + toJSON JsonAps{..} = object (staticFields <> dynamicFields) + where + dynamicFields = M.toList jaSupplementalFields + staticFields = [ "aps" .= jaAps + , "appspecificcontent" .= jaAppSpecificContent + ] -- | Prepare a new apn message consisting of a -- standard message without a custom payload @@ -306,7 +329,7 @@ -- ^ The standard message to include -> JsonAps -- ^ The resulting APN message -newMessage = flip JsonAps Nothing +newMessage aps = JsonAps aps Nothing M.empty -- | Prepare a new apn message consisting of a -- standard message and a custom payload @@ -318,8 +341,27 @@ -> JsonAps -- ^ The resulting APN message newMessageWithCustomPayload message payload = - JsonAps message (Just payload) + JsonAps message (Just payload) M.empty +-- | Add a supplemental field to be sent over with the notification +-- +-- NB: The field 'aps' must not be modified; attempting to do so will +-- cause a crash. +addSupplementalField :: ToJSON record => + Text + -- ^ The field name + -> record + -- ^ The value + -> JsonAps + -- ^ The APN message to modify + -> JsonAps + -- ^ The resulting APN message +addSupplementalField "aps" _ _ = error "The 'aps' field may not be overwritten by user code" +addSupplementalField fieldName fieldValue oldAPN = oldAPN { jaSupplementalFields = newSupplemental } + where + oldSupplemental = jaSupplementalFields oldAPN + newSupplemental = M.insert fieldName (toJSON fieldValue) oldSupplemental + -- | Start a new session for sending APN messages. A session consists of a -- connection pool of connections to the APN servers, while each connection has a -- pool of workers that create HTTP2 streams to send individual push @@ -374,45 +416,54 @@ isOpen :: ApnSession -> IO Bool isOpen = readIORef . apnSessionOpen -withConnection :: ApnSession -> (ApnConnection -> IO a) -> IO a +withConnection :: ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a withConnection s action = do - ensureOpen s + lift $ ensureOpen s let pool = apnSessionPool s - connections <- readIORef pool - let len = length connections - if len == 0 - then do - conn <- newConnection s - res <- action conn - atomicModifyIORef' pool (\a -> (conn:a, ())) - return res - else do - num <- randomRIO (0, len - 1) - currtime <- round <$> getPOSIXTime :: IO Int64 - let conn = connections !! num - conn1 = conn { apnConnectionLastUsed=currtime } - atomicModifyIORef' pool (\a -> (removeNth num a, ())) - isOpen <- readIORef (apnConnectionOpen conn) - if isOpen - then do - res <- action conn1 - atomicModifyIORef' pool (\a -> (conn1:a, ())) + mConn <- getExistingConnection pool + case mConn of + Nothing -> do + conn <- newConnection s + res <- action conn + lift $ atomicModifyIORef' pool (\a -> (conn:a, ())) return res - else withConnection s action + Just conn -> do + currtime <- round <$> lift getPOSIXTime + conn <- pure (conn { apnConnectionLastUsed=currtime }) + isOpen <- lift $ readIORef (apnConnectionOpen conn) + if isOpen + then do + res <- action conn + lift $ atomicModifyIORef' pool (\a -> (conn:a, ())) + return res + else withConnection s action + where + getExistingConnection :: (IORef [ApnConnection]) -> ClientIO (Maybe ApnConnection) + getExistingConnection pool = + do connections <- lift $ readIORef pool + let len = length connections + if len == 0 + then return Nothing + else do + num <- lift $ randomRIO (0, len - 1) + lift $ atomicModifyIORef' pool $ \conns -> + case removeNthMay num conns of + Nothing -> (conns, Nothing) + Just (myConn, conns) -> (conns, Just myConn) + checkCertificates :: ApnConnectionInfo -> IO Bool checkCertificates aci = do castore <- readCertificateStore $ aciCaPath aci credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci) return $ isJust castore && isRight credential -replaceNth n newVal (x:xs) - | n == 0 = newVal:xs - | otherwise = x:replaceNth (n-1) newVal xs - -removeNth n (x:xs) - | n == 0 = xs - | otherwise = x:removeNth (n-1) xs +removeNthMay :: Int -> [a] -> Maybe (a, [a]) +removeNthMay _ [] = Nothing +removeNthMay 0 (x:xs) = Just (x, xs) +removeNthMay n (x:xs) = fmap (second (x:)) (removeNthMay (n-1) xs) + where + second f (x, y) = (x, f y) manage :: Int64 -> IORef [ApnConnection] -> IO () manage timeout ioref = forever $ do @@ -423,11 +474,11 @@ mapM_ closeApnConnection expiredOnes threadDelay 60000000 -newConnection :: ApnSession -> IO ApnConnection +newConnection :: ApnSession -> ClientIO ApnConnection newConnection apnSession = do let aci = apnSessionConnectionInfo apnSession - Just castore <- readCertificateStore $ aciCaPath aci - Right credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci) + Just castore <- lift $ readCertificateStore $ aciCaPath aci + Right credential <- lift $ credentialLoadX509 (aciCertPath aci) (aciCertKey aci) let credentials = Credentials [credential] shared = def { sharedCredentials = credentials , sharedCAStore=castore } @@ -455,26 +506,29 @@ hostname = aciHostname aci httpFrameConnection <- newHttp2FrameConnection (T.unpack hostname) 443 (Just clip) - isOpen <- newIORef True + isOpen <- lift $ newIORef True let handleGoAway rsgaf = do - writeIORef isOpen False + lift $ writeIORef isOpen False return () client <- newHttp2Client httpFrameConnection 4096 4096 conf handleGoAway ignoreFallbackHandler linkAsyncs client - flowWorker <- forkIO $ forever $ do - updated <- _updateWindow $ _incomingFlowControl client + flowWorker <- lift $ forkIO $ forever $ do + updated <- runClientIO $ _updateWindow $ _incomingFlowControl client threadDelay 1000000 - workersem <- newQSem maxConcurrentStreams - currtime <- round <$> getPOSIXTime :: IO Int64 + workersem <- lift $ newQSem maxConcurrentStreams + currtime :: Int64 <- round <$> lift getPOSIXTime return $ ApnConnection client aci workersem currtime flowWorker isOpen closeApnConnection :: ApnConnection -> IO () -closeApnConnection connection = do - writeIORef (apnConnectionOpen connection) False +closeApnConnection connection = + -- Ignoring ClientErrors in this place. We want to close our session, so we do not need to + -- fail on this kind of errors. + void $ runClientIO $ do + lift $ writeIORef (apnConnectionOpen connection) False let flowWorker = apnConnectionFlowControlWorker connection - killThread flowWorker + lift $ killThread flowWorker _gtfo (apnConnectionConnection connection) HTTP2.NoError "" _close (apnConnectionConnection connection) @@ -489,7 +543,7 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendRawMessage s token payload = catchIOErrors $ +sendRawMessage s token payload = catchErrors $ withConnection s $ \c -> sendApnRaw c token payload @@ -503,7 +557,7 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendMessage s token payload = catchIOErrors $ +sendMessage s token payload = catchErrors $ withConnection s $ \c -> sendApnRaw c token message where message = L.toStrict $ encode payload @@ -516,7 +570,7 @@ -- ^ Device to send the message to -> IO ApnMessageResult -- ^ The response from the APN server -sendSilentMessage s token = catchIOErrors $ +sendSilentMessage s token = catchErrors $ withConnection s $ \c -> sendApnRaw c token message where message = "{\"aps\":{\"content-available\":1}}" @@ -534,10 +588,10 @@ -- ^ Device to send the message to -> ByteString -- ^ The message to send - -> IO ApnMessageResult + -> ClientIO ApnMessageResult sendApnRaw connection token message = bracket_ - (waitQSem (apnConnectionWorkerPool connection)) - (signalQSem (apnConnectionWorkerPool connection)) $ do + (lift $ waitQSem (apnConnectionWorkerPool connection)) + (lift $ signalQSem (apnConnectionWorkerPool connection)) $ do let requestHeaders = [ ( ":method", "POST" ) , ( ":scheme", "https" ) , ( ":authority", TE.encodeUtf8 hostname ) @@ -555,29 +609,105 @@ -- sendData client stream (HTTP2.setEndStream) message upload message (HTTP2.setEndHeader . HTTP2.setEndStream) client (_outgoingFlowControl client) stream osfc let pph hStreamId hStream hHeaders hIfc hOfc = - print hHeaders + lift $ print hHeaders response <- waitStream stream isfc pph let (errOrHeaders, frameResponses, _) = response case errOrHeaders of - Left err -> return ApnMessageResultTemporaryError + Left err -> throwIO (ApnExceptionHTTP $ toErrorCodeId err) Right hdrs1 -> do - let Just status = DL.lookup ":status" hdrs1 + let status = getHeaderEx ":status" hdrs1 + [Right body] = frameResponses + return $ case status of "200" -> ApnMessageResultOk - "400" -> if Right "{\"reason\":\"BadDeviceToken\"}" `DL.elem` frameResponses - then ApnMessageResultBadDeviceToken - else ApnMessageResultFatalError - "403" -> ApnMessageResultFatalError - "405" -> ApnMessageResultFatalError - "410" -> ApnMessageResultTokenNoLongerValid - "413" -> ApnMessageResultFatalError - "429" -> ApnMessageResultTemporaryError - "500" -> ApnMessageResultTemporaryError - "503" -> ApnMessageResultTemporaryError + "400" -> decodeReason ApnMessageResultFatalError body + "403" -> decodeReason ApnMessageResultFatalError body + "405" -> decodeReason ApnMessageResultFatalError body + "410" -> decodeReason ApnMessageResultFatalError body + "413" -> decodeReason ApnMessageResultFatalError body + "429" -> decodeReason ApnMessageResultTemporaryError body + "500" -> decodeReason ApnMessageResultTemporaryError body + "503" -> decodeReason ApnMessageResultTemporaryError body in StreamDefinition init handler case res of - Left _ -> return ApnMessageResultTemporaryError -- Too much concurrency + Left _ -> return ApnMessageResultBackoff -- Too much concurrency Right res1 -> return res1 -catchIOErrors :: SpecifyError a => IO a -> IO a -catchIOErrors = flip catchIOError (const $ return isAnError) + where + decodeReason :: FromJSON response => (response -> ApnMessageResult) -> ByteString -> ApnMessageResult + decodeReason ctor = either (throw . ApnExceptionJSON) id . decodeBody . L.fromStrict + where + decodeBody body = + eitherDecode body + >>= parseEither (\obj -> ctor <$> obj .: "reason") + + getHeaderEx :: HTTP2.HeaderName -> [HTTP2.Header] -> HTTP2.HeaderValue + getHeaderEx name headers = fromMaybe (throw $ ApnExceptionMissingHeader name) (DL.lookup name headers) + + +catchErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult +catchErrors = catchIOErrors . catchClientErrors + where + catchIOErrors :: IO ApnMessageResult -> IO ApnMessageResult + catchIOErrors = flip catchIOError (return . ApnMessageResultIOError) + + catchClientErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult + catchClientErrors act = + either ApnMessageResultClientError id <$> runClientIO act + + +-- The type of permanent error indicated by APNS +-- See https://apple.co/2RDCdWC table 8-6 for the meaning of each value. +data ApnFatalError = ApnFatalErrorBadCollapseId + | ApnFatalErrorBadDeviceToken + | ApnFatalErrorBadExpirationDate + | ApnFatalErrorBadMessageId + | ApnFatalErrorBadPriority + | ApnFatalErrorBadTopic + | ApnFatalErrorDeviceTokenNotForTopic + | ApnFatalErrorDuplicateHeaders + | ApnFatalErrorIdleTimeout + | ApnFatalErrorMissingDeviceToken + | ApnFatalErrorMissingTopic + | ApnFatalErrorPayloadEmpty + | ApnFatalErrorTopicDisallowed + | ApnFatalErrorBadCertificate + | ApnFatalErrorBadCertificateEnvironment + | ApnFatalErrorExpiredProviderToken + | ApnFatalErrorForbidden + | ApnFatalErrorInvalidProviderToken + | ApnFatalErrorMissingProviderToken + | ApnFatalErrorBadPath + | ApnFatalErrorMethodNotAllowed + | ApnFatalErrorUnregistered + | ApnFatalErrorPayloadTooLarge + | ApnFatalErrorOther Text + deriving (Eq, Show, Generic) + +instance FromJSON ApnFatalError where + parseJSON json = + let result = parse genericParser json + in + case result of + Success success -> return success + Error err -> case json of + String other -> return $ ApnFatalErrorOther other + _ -> fail err + + where + genericParser = genericParseJSON defaultOptions { + constructorTagModifier = drop 13, + sumEncoding = UntaggedValue + } + +-- The type of transient error indicated by APNS +-- See https://apple.co/2RDCdWC table 8-6 for the meaning of each value. +data ApnTemporaryError = ApnTemporaryErrorTooManyProviderTokenUpdates + | ApnTemporaryErrorTooManyRequests + | ApnTemporaryErrorInternalServerError + | ApnTemporaryErrorServiceUnavailable + | ApnTemporaryErrorShutdown + deriving (Enum, Eq, Show, Generic) + +instance FromJSON ApnTemporaryError where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = drop 17 } diff --git a/test/Network/PushNotify/APNSpec.hs b/test/Network/PushNotify/APNSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/PushNotify/APNSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.PushNotify.APNSpec (spec) where + +import Data.Aeson +import Network.PushNotify.APN +import Test.Hspec + +spec :: Spec +spec = do + describe "JsonApsMessage" $ + context "JSON encoder" $ do + it "encodes an APNS message with a title and body" $ + toJSON (alertMessage "hello" "world") `shouldBe` + object [ + "category" .= Null, + "sound" .= Null, + "badge" .= Null, + "alert" .= object [ + "title" .= String "hello", + "body" .= String "world" + ] + ] + it "encodes an APNS message with a title and no body" $ + toJSON (bodyMessage "hello world") `shouldBe` + object [ + "category" .= Null, + "sound" .= Null, + "badge" .= Null, + "alert" .= object [ "body" .= String "hello world" ] + ] + + describe "JsonAps" $ + context "JSON encoder" $ do + it "encodes normally when there are no supplemental fields" $ + toJSON (newMessage (alertMessage "hello" "world")) `shouldBe` object [ + "aps" .= alertMessage "hello" "world", + "appspecificcontent" .= Null + ] + + it "encodes supplemental fields" $ do + let msg = newMessage (alertMessage "hello" "world") + & addSupplementalField "foo" ("bar" :: String) + & addSupplementalField "aaa" ("qux" :: String) + + toJSON msg `shouldBe` object [ + "aaa" .= String "qux", + "aps" .= alertMessage "hello" "world", + "appspecificcontent" .= Null, + "foo" .= String "bar" + ] + + describe "ApnFatalError" $ + context "JSON decoder" $ do + it "decodes the error correctly" $ + eitherDecode "\"BadCollapseId\"" `shouldBe` Right ApnFatalErrorBadCollapseId + + it "dumps unknown error types into a wildcard result" $ + eitherDecode "\"BadcollapseId\"" `shouldBe` Right (ApnFatalErrorOther "BadcollapseId") + + it "errors on invalid JSON" $ + eitherDecode "\"crap" `shouldBe` (Left "Error in $: not enough input" :: Either String ApnFatalError) + + describe "ApnTemporaryError" $ + context "JSON decoder" $ + it "decodes the error correctly" $ + eitherDecode "\"TooManyProviderTokenUpdates\"" `shouldBe` Right ApnTemporaryErrorTooManyProviderTokenUpdates + where + (&) = flip ($)