diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 ======= 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.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 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 @@ -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)