diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,11 +11,12 @@ Sending a message is as simple as: - let sandbox = True -- Development environment - timeout = 10 -- Minutes to keep the connection open + let sandbox = True -- Development environment + maxParallel = 10 -- Number of parallel connections to + -- the APN Servers session <- newSession "my.key" "my.crt" "/etc/ssl/ca_certificates.txt" sandbox - timeout "my.bundle.id" + maxParallel "my.bundle.id" let payload = alertMessage "Title" "Hello From Haskell" message = newMessage payload token = base16EncodedToken "the-token" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,19 @@ +0.1.0.7 +======= + +- Make compatible with latest http2-client-0.7.0.0 + +0.1.0.6 +======= + +- Use http2-client-0.5.0.0 or greater +- Detect http2 goaway frames and remove connections from the + connection pool accordingly +- Detect connection errors when sending messages and remove + connections from the pool when they happen +- Fix in the README: The parameter is not timeout, but + parallelConnections + 0.1.0.5 ======= 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.5 +version: 0.1.0.7 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 == 0.3.0.2 + , http2-client >= 0.7.0.0 && < 0.8 , 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 @@ -59,6 +59,7 @@ import Data.X509.CertificateStore import GHC.Generics import Network.HTTP2.Client +import Network.HTTP2.Client.FrameConnection import Network.HTTP2.Client.Helpers import Network.TLS hiding (sendData) import Network.TLS.Extra.Cipher @@ -99,7 +100,8 @@ , apnConnectionInfo :: !ApnConnectionInfo , apnConnectionWorkerPool :: !QSem , apnConnectionLastUsed :: !Int64 - , apnConnectionFlowControlWorker :: !ThreadId } + , apnConnectionFlowControlWorker :: !ThreadId + , apnConnectionOpen :: !(IORef Bool)} -- | An APN token used to uniquely identify a device newtype ApnToken = ApnToken { unApnToken :: ByteString } @@ -315,9 +317,9 @@ 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" + unless certsOk $ error "Unable to load certificates and/or the private key" connections <- newIORef [] - connectionManager <- forkIO $ manage 1800 connections + connectionManager <- forkIO $ manage 600 connections isOpen <- newIORef True let session = ApnSession connections connInfo connectionManager isOpen addFinalizer session $ @@ -333,7 +335,7 @@ closeSession :: ApnSession -> IO () closeSession s = do isOpen <- atomicModifyIORef' (apnSessionOpen s) (\a -> (False, a)) - when (not isOpen) $ error "Session is already closed" + unless isOpen $ error "Session is already closed" killThread (apnSessionConnectionManager s) let ioref = apnSessionPool s openConnections <- atomicModifyIORef' ioref (\conns -> ([], conns)) @@ -344,25 +346,31 @@ isOpen :: ApnSession -> IO Bool isOpen = readIORef . apnSessionOpen -getConnection :: ApnSession -> IO ApnConnection -getConnection s = do +withConnection :: ApnSession -> (ApnConnection -> IO a) -> IO a +withConnection s action = do ensureOpen s let pool = apnSessionPool s - ci = apnSessionConnectionInfo s connections <- readIORef pool let len = length connections if len == 0 then do - conn <- newConnection ci + conn <- newConnection s + res <- action conn atomicModifyIORef' pool (\a -> (conn:a, ())) - return conn + 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 -> (replaceNth num conn1 a, ())) - return conn1 + atomicModifyIORef' pool (\a -> (removeNth num a, ())) + isOpen <- readIORef (apnConnectionOpen conn) + if isOpen + then do + res <- action conn1 + atomicModifyIORef' pool (\a -> (conn1:a, ())) + return res + else withConnection s action checkCertificates :: ApnConnectionInfo -> IO Bool checkCertificates aci = do @@ -374,17 +382,22 @@ | n == 0 = newVal:xs | otherwise = x:replaceNth (n-1) newVal xs +removeNth n (x:xs) + | n == 0 = xs + | otherwise = x:removeNth (n-1) xs + manage :: Int64 -> IORef [ApnConnection] -> IO () manage timeout ioref = forever $ do currtime <- round <$> getPOSIXTime :: IO Int64 let minTime = currtime - timeout expiredOnes <- atomicModifyIORef' ioref - (foldl ( \(a,b) i -> if apnConnectionLastUsed i < minTime then (a, (i:b) ) else ( (i:a) ,b)) ([],[])) + (foldl ( \(a,b) i -> if apnConnectionLastUsed i < minTime then (a, i:b ) else ( i:a ,b)) ([],[])) mapM_ closeApnConnection expiredOnes threadDelay 60000000 -newConnection :: ApnConnectionInfo -> IO ApnConnection -newConnection aci = do +newConnection :: ApnSession -> IO ApnConnection +newConnection apnSession = do + let aci = apnSessionConnectionInfo apnSession Just castore <- readCertificateStore $ aciCaPath aci Right credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci) let credentials = Credentials [credential] @@ -413,18 +426,25 @@ ] hostname = aciHostname aci - client <- newHttp2Client (T.unpack hostname) 443 4096 4096 clip conf + httpFrameConnection <- newHttp2FrameConnection (T.unpack hostname) 443 (Just clip) + isOpen <- newIORef True + let handleGoAway rsgaf = do + writeIORef isOpen False + return () + client <- newHttp2Client httpFrameConnection 4096 4096 conf handleGoAway ignoreFallbackHandler + linkAsyncs client flowWorker <- forkIO $ forever $ do updated <- _updateWindow $ _incomingFlowControl client threadDelay 1000000 workersem <- newQSem maxConcurrentStreams currtime <- round <$> getPOSIXTime :: IO Int64 - return $ ApnConnection client aci workersem currtime flowWorker + return $ ApnConnection client aci workersem currtime flowWorker isOpen closeApnConnection :: ApnConnection -> IO () closeApnConnection connection = do + writeIORef (apnConnectionOpen connection) False let flowWorker = apnConnectionFlowControlWorker connection killThread flowWorker _gtfo (apnConnectionConnection connection) HTTP2.NoError "" @@ -441,9 +461,9 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendRawMessage s token payload = catchIOErrors $ do - c <- getConnection s - sendApnRaw c token payload +sendRawMessage s token payload = catchIOErrors $ + withConnection s $ \c -> + sendApnRaw c token payload -- | Send a push notification message. sendMessage @@ -455,10 +475,10 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendMessage s token payload = catchIOErrors $ do - c <- getConnection s - let message = L.toStrict $ encode payload - sendApnRaw c token message +sendMessage s token payload = catchIOErrors $ + withConnection s $ \c -> + sendApnRaw c token message + where message = L.toStrict $ encode payload -- | Send a silent push notification sendSilentMessage @@ -468,15 +488,15 @@ -- ^ Device to send the message to -> IO ApnMessageResult -- ^ The response from the APN server -sendSilentMessage s token = catchIOErrors $ do - c <- getConnection s - let message = "{\"aps\":{\"content-available\":1}}" - sendApnRaw c token message +sendSilentMessage s token = catchIOErrors $ + withConnection s $ \c -> + sendApnRaw c token message + where message = "{\"aps\":{\"content-available\":1}}" ensureOpen :: ApnSession -> IO () ensureOpen s = do open <- isOpen s - when (not open) $ error "Session is closed" + unless open $ error "Session is closed" -- | Send a push notification message. sendApnRaw @@ -490,7 +510,7 @@ sendApnRaw connection token message = bracket_ (waitQSem (apnConnectionWorkerPool connection)) (signalQSem (apnConnectionWorkerPool connection)) $ do - let headers = [ ( ":method", "POST" ) + let requestHeaders = [ ( ":method", "POST" ) , ( ":scheme", "https" ) , ( ":authority", TE.encodeUtf8 hostname ) , ( ":path", "/3/device/" `S.append` token1 ) @@ -502,12 +522,14 @@ token1 = unApnToken token res <- _startStream client $ \stream -> - let init = _headers stream headers id + let init = headers stream requestHeaders id handler isfc osfc = do -- sendData client stream (HTTP2.setEndStream) message - upload message client (_outgoingFlowControl client) stream osfc - hdrs <- _waitHeaders stream - let (frameHeader, streamId, errOrHeaders) = hdrs + upload message (HTTP2.setEndHeader . HTTP2.setEndStream) client (_outgoingFlowControl client) stream osfc + let pph hStreamId hStream hHeaders hIfc hOfc = + print hHeaders + response <- waitStream stream isfc pph + let (errOrHeaders, _, _) = response case errOrHeaders of Left err -> return ApnMessageResultTemporaryError Right hdrs1 -> do