push-notify-apn 0.1.0.4 → 0.1.0.5
raw patch · 3 files changed
+63/−45 lines, 3 filesdep ~http2-clientPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: http2-client
API changes (from Hackage documentation)
+ Network.PushNotify.APN: instance Network.PushNotify.APN.SpecifyError Network.PushNotify.APN.ApnMessageResult
Files
- changelog.md +8/−0
- push-notify-apn.cabal +2/−2
- src/Network/PushNotify/APN.hs +53/−43
changelog.md view
@@ -1,3 +1,11 @@+0.1.0.5+=======++- Bugfix: Close the cleanup thread when closing a session+- Check if the certificates and key exist early, when the session is created+- Catch IO errors and return a temporary failure instead+- Depend explicitly on http2-client-0.3.0.2 for now+ 0.1.0.4 =======
push-notify-apn.cabal view
@@ -1,5 +1,5 @@ name: push-notify-apn-version: 0.1.0.4+version: 0.1.0.5 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@@ -30,7 +30,7 @@ , containers , data-default , http2- , http2-client+ , http2-client == 0.3.0.2 , random , text , time
src/Network/PushNotify/APN.hs view
@@ -48,9 +48,11 @@ import Data.ByteString (ByteString) import Data.Char (toLower) import Data.Default (def)+import Data.Either import Data.Int import Data.IORef import Data.Map.Strict (Map)+import Data.Maybe import Data.Text (Text) import Data.Time.Clock.POSIX import Data.X509@@ -60,6 +62,7 @@ import Network.HTTP2.Client.Helpers import Network.TLS hiding (sendData) import Network.TLS.Extra.Cipher+import System.IO.Error import System.Mem.Weak import System.Random @@ -101,11 +104,15 @@ -- | An APN token used to uniquely identify a device newtype ApnToken = ApnToken { unApnToken :: ByteString } +class SpecifyError a where+ isAnError :: a+ -- | Create a token from a raw bytestring rawToken :: ByteString -- ^ The bytestring that uniquely identifies a device (APN token) -> ApnToken+ -- ^ The resulting token rawToken = ApnToken . B16.encode -- | Create a token from a hex encoded text@@ -113,6 +120,7 @@ :: Text -- ^ The base16 (hex) encoded unique identifier for a device (APN token) -> ApnToken+ -- ^ The resulting token hexEncodedToken = ApnToken . B16.encode . fst . B16.decode . TE.encodeUtf8 -- | The result of a send request@@ -122,6 +130,9 @@ | ApnMessageResultTokenNoLongerValid deriving (Enum, Eq, Show) +instance SpecifyError ApnMessageResult where+ isAnError = ApnMessageResultTemporaryError+ -- | The specification of a push notification's message body data JsonApsAlert = JsonApsAlert { jaaTitle :: !Text@@ -161,6 +172,7 @@ -> JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message setSound s a = a { jamSound = Just s } -- | Clear the sound for an APN message@@ -168,14 +180,17 @@ :: JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message clearSound a = a { jamSound = Nothing } -- | Set the category part of an APN message setCategory :: Text+ -- ^ The category to set -> JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message setCategory c a = a { jamCategory = Just c } -- | Clear the category part of an APN message@@ -183,15 +198,17 @@ :: JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message clearCategory a = a { jamCategory = Nothing } -- | Set the badge part of an APN message setBadge :: Int- -- ^ The number to set. Use 0 to remove the number.+ -- ^ The badge number to set. The badge number is displayed next to your app's icon. Set to 0 to remove the badge number. -> JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message setBadge i a = a { jamBadge = Just i } -- | Clear the badge part of an APN message@@ -199,6 +216,7 @@ :: JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message clearBadge a = a { jamBadge = Nothing } -- | Create a new APN message with an alert part@@ -208,6 +226,7 @@ -> Text -- ^ The body of the message -> JsonApsMessage+ -- ^ The modified message alertMessage title text = setAlertMessage title text emptyMessage -- | Set the alert part of an APN message@@ -219,6 +238,7 @@ -> JsonApsMessage -- ^ The message to alter -> JsonApsMessage+ -- ^ The modified message setAlertMessage title text a = a { jamAlert = Just jam } where jam = JsonApsAlert title text@@ -228,6 +248,7 @@ :: JsonApsMessage -- ^ The message to modify -> JsonApsMessage+ -- ^ The modified message clearAlertMessage a = a { jamAlert = Nothing } instance ToJSON JsonApsMessage where@@ -254,6 +275,7 @@ :: JsonApsMessage -- ^ The standard message to include -> JsonAps+ -- ^ The resulting APN message newMessage = flip JsonAps Nothing -- | Prepare a new apn message consisting of a@@ -264,6 +286,7 @@ -> Text -- ^ The custom payload -> JsonAps+ -- ^ The resulting APN message newMessageWithCustomPayload message payload = JsonAps message (Just payload) @@ -279,17 +302,20 @@ -> FilePath -- ^ Path to the CA -> Bool- -- ^ True if the apn evelopment servers should be used, False to use the production servers+ -- ^ True if the apn development servers should be used, False to use the production servers -> Int -- ^ How many messages will be sent in parallel? This corresponds to the number of http2 streams open in parallel; 100 seems to be a default value. -> ByteString -- ^ Topic (bundle name of the app) -> IO ApnSession+ -- ^ The newly created session newSession certKey certPath caPath dev maxparallel topic = do let hostname = if dev then "api.development.push.apple.com" else "api.push.apple.com" connInfo = ApnConnectionInfo certPath certKey caPath hostname maxparallel topic+ certsOk <- checkCertificates connInfo+ when (not certsOk) $ error "Unable to load certificates and/or the private key" connections <- newIORef [] connectionManager <- forkIO $ manage 1800 connections isOpen <- newIORef True@@ -302,12 +328,13 @@ -- after it has been closed. Calling this function will close -- the worker thread, and all open connections to the APN service -- that belong to the given session. Note that sessions will be closed--- autotically when they are garbage collected, so it is not necessary+-- automatically when they are garbage collected, so it is not necessary -- to call this function. closeSession :: ApnSession -> IO () closeSession s = do isOpen <- atomicModifyIORef' (apnSessionOpen s) (\a -> (False, a)) when (not isOpen) $ error "Session is already closed"+ killThread (apnSessionConnectionManager s) let ioref = apnSessionPool s openConnections <- atomicModifyIORef' ioref (\conns -> ([], conns)) mapM_ closeApnConnection openConnections@@ -337,6 +364,12 @@ atomicModifyIORef' pool (\a -> (replaceNth num conn1 a, ())) return conn1 +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@@ -350,8 +383,6 @@ mapM_ closeApnConnection expiredOnes threadDelay 60000000 -- newConnection :: ApnConnectionInfo -> IO ApnConnection newConnection aci = do Just castore <- readCertificateStore $ aciCaPath aci@@ -387,16 +418,6 @@ updated <- _updateWindow $ _incomingFlowControl client threadDelay 1000000 --- let largestWindowSize = HTTP2.maxWindowSize - HTTP2.defaultInitialWindowSize--- _addCredit (_incomingFlowControl client) largestWindowSize--- putStrLn "addCredit called."--- _ <- forkIO $ forever $ do--- threadDelay 1000000--- _updateWindow $ _incomingFlowControl client--- putStrLn "updateWindow callde."--- -- workerpool <- createPool (return ()) (const $ return ()) 1 600 maxConcurrentStreams workersem <- newQSem maxConcurrentStreams currtime <- round <$> getPOSIXTime :: IO Int64 return $ ApnConnection client aci workersem currtime flowWorker@@ -419,12 +440,10 @@ -> ByteString -- ^ The message to send -> IO ApnMessageResult-sendRawMessage s token payload = do+ -- ^ The response from the APN server+sendRawMessage s token payload = catchIOErrors $ do c <- getConnection s- res <- sendApnRaw c token payload- case res of- Left tmc -> return ApnMessageResultTemporaryError -- TODO: Spawn new connection depending on poolsize- Right res1 -> return res1+ sendApnRaw c token payload -- | Send a push notification message. sendMessage@@ -435,13 +454,11 @@ -> JsonAps -- ^ The message to send -> IO ApnMessageResult-sendMessage s token payload = do+ -- ^ The response from the APN server+sendMessage s token payload = catchIOErrors $ do c <- getConnection s let message = L.toStrict $ encode payload- res <- sendApnRaw c token message- case res of- Left tmc -> return ApnMessageResultTemporaryError -- TODO: Spawn new connection depending on poolsize- Right res1 -> return res1+ sendApnRaw c token message -- | Send a silent push notification sendSilentMessage@@ -450,13 +467,11 @@ -> ApnToken -- ^ Device to send the message to -> IO ApnMessageResult-sendSilentMessage s token = do+ -- ^ The response from the APN server+sendSilentMessage s token = catchIOErrors $ do c <- getConnection s let message = "{\"aps\":{\"content-available\":1}}"- res <- sendApnRaw c token message- case res of- Left tmc -> return ApnMessageResultTemporaryError -- TODO: Spawn new connection depending on poolsize- Right res1 -> return res1+ sendApnRaw c token message ensureOpen :: ApnSession -> IO () ensureOpen s = do@@ -471,7 +486,7 @@ -- ^ Device to send the message to -> ByteString -- ^ The message to send- -> IO (Either TooMuchConcurrency ApnMessageResult)+ -> IO ApnMessageResult sendApnRaw connection token message = bracket_ (waitQSem (apnConnectionWorkerPool connection)) (signalQSem (apnConnectionWorkerPool connection)) $ do@@ -486,7 +501,7 @@ client = apnConnectionConnection connection token1 = unApnToken token - _startStream client $ \stream ->+ res <- _startStream client $ \stream -> let init = _headers stream headers id handler isfc osfc = do -- sendData client stream (HTTP2.setEndStream) message@@ -507,15 +522,10 @@ "429" -> ApnMessageResultTemporaryError "500" -> ApnMessageResultTemporaryError "503" -> ApnMessageResultTemporaryError --- let recv = do--- print "_waitData"--- (fh, x) <- _waitData stream--- print ("data", fmap (\bs -> (S.length bs, S.take 64 bs)) x)--- print fh--- when (not $ HTTP2.testEndStream (HTTP2.flags fh)) $ do--- print "testEndStream"--- _updateWindow isfc--- print "updateWindow"--- recv- -- recv in StreamDefinition init handler+ case res of+ Left _ -> return ApnMessageResultTemporaryError -- Too much concurrency+ Right res1 -> return res1++catchIOErrors :: SpecifyError a => IO a -> IO a+catchIOErrors = flip catchIOError (const $ return isAnError)