push-notify-apn 0.1.1.0 → 0.1.2.0

raw patch · 4 files changed

+292/−79 lines, 4 filesdep +lifted-basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: lifted-base

API changes (from Hackage documentation)

Files

• changelog.md +12/−0
• push-notify-apn.cabal +4/−2
• src/Network/PushNotify/APN.hs +207/−77
• test/Network/PushNotify/APNSpec.hs +69/−0

@@ -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 ======= 

@@ -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

@@ -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 }

@@ -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 ($)