diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,10 +1,3 @@ - -0.1.2.0 -======= - -- Threading bugfix -- Migrate to http2-client-0.9.0.0 and lts-14 - 0.1.1.1 ======= 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.2.0 +version: 0.2.0.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 @@ -31,7 +31,6 @@ , data-default , http2 , http2-client - , lifted-base , random , semigroups , text 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 @@ -10,7 +10,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Network.PushNotify.APN @@ -49,7 +48,7 @@ import Control.Concurrent import Control.Concurrent.QSem -import Control.Exception.Lifted (Exception, bracket_, throw, throwIO) +import Control.Exception import Control.Monad import Data.Aeson import Data.Aeson.Types @@ -63,7 +62,6 @@ 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 @@ -153,9 +151,11 @@ | ApnMessageResultFatalError ApnFatalError | ApnMessageResultTemporaryError ApnTemporaryError | ApnMessageResultIOError IOError - | ApnMessageResultClientError ClientError deriving (Eq, Show) +instance SpecifyError ApnMessageResult where + isAnError = ApnMessageResultIOError + -- | The specification of a push notification's message body data JsonApsAlert = JsonApsAlert { jaaTitle :: !(Maybe Text) @@ -416,41 +416,31 @@ isOpen :: ApnSession -> IO Bool isOpen = readIORef . apnSessionOpen -withConnection :: ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a +withConnection :: ApnSession -> (ApnConnection -> IO a) -> IO a withConnection s action = do - lift $ ensureOpen s + ensureOpen s let pool = apnSessionPool s - mConn <- getExistingConnection pool - case mConn of - Nothing -> do - conn <- newConnection s - res <- action conn - lift $ atomicModifyIORef' pool (\a -> (conn:a, ())) + 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, ())) return res - 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) - + else withConnection s action checkCertificates :: ApnConnectionInfo -> IO Bool checkCertificates aci = do @@ -458,13 +448,14 @@ credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci) return $ isJust castore && isRight credential -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) +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 + manage :: Int64 -> IORef [ApnConnection] -> IO () manage timeout ioref = forever $ do currtime <- round <$> getPOSIXTime :: IO Int64 @@ -474,11 +465,11 @@ mapM_ closeApnConnection expiredOnes threadDelay 60000000 -newConnection :: ApnSession -> ClientIO ApnConnection +newConnection :: ApnSession -> IO ApnConnection newConnection apnSession = do let aci = apnSessionConnectionInfo apnSession - Just castore <- lift $ readCertificateStore $ aciCaPath aci - Right credential <- lift $ credentialLoadX509 (aciCertPath aci) (aciCertKey aci) + Just castore <- readCertificateStore $ aciCaPath aci + Right credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci) let credentials = Credentials [credential] shared = def { sharedCredentials = credentials , sharedCAStore=castore } @@ -506,29 +497,26 @@ hostname = aciHostname aci httpFrameConnection <- newHttp2FrameConnection (T.unpack hostname) 443 (Just clip) - isOpen <- lift $ newIORef True + isOpen <- newIORef True let handleGoAway rsgaf = do - lift $ writeIORef isOpen False + writeIORef isOpen False return () client <- newHttp2Client httpFrameConnection 4096 4096 conf handleGoAway ignoreFallbackHandler linkAsyncs client - flowWorker <- lift $ forkIO $ forever $ do - updated <- runClientIO $ _updateWindow $ _incomingFlowControl client + flowWorker <- forkIO $ forever $ do + updated <- _updateWindow $ _incomingFlowControl client threadDelay 1000000 - workersem <- lift $ newQSem maxConcurrentStreams - currtime :: Int64 <- round <$> lift getPOSIXTime + workersem <- newQSem maxConcurrentStreams + currtime <- round <$> getPOSIXTime :: IO Int64 return $ ApnConnection client aci workersem currtime flowWorker isOpen closeApnConnection :: ApnConnection -> IO () -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 +closeApnConnection connection = do + writeIORef (apnConnectionOpen connection) False let flowWorker = apnConnectionFlowControlWorker connection - lift $ killThread flowWorker + killThread flowWorker _gtfo (apnConnectionConnection connection) HTTP2.NoError "" _close (apnConnectionConnection connection) @@ -543,7 +531,7 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendRawMessage s token payload = catchErrors $ +sendRawMessage s token payload = catchIOErrors $ withConnection s $ \c -> sendApnRaw c token payload @@ -557,7 +545,7 @@ -- ^ The message to send -> IO ApnMessageResult -- ^ The response from the APN server -sendMessage s token payload = catchErrors $ +sendMessage s token payload = catchIOErrors $ withConnection s $ \c -> sendApnRaw c token message where message = L.toStrict $ encode payload @@ -570,7 +558,7 @@ -- ^ Device to send the message to -> IO ApnMessageResult -- ^ The response from the APN server -sendSilentMessage s token = catchErrors $ +sendSilentMessage s token = catchIOErrors $ withConnection s $ \c -> sendApnRaw c token message where message = "{\"aps\":{\"content-available\":1}}" @@ -588,10 +576,10 @@ -- ^ Device to send the message to -> ByteString -- ^ The message to send - -> ClientIO ApnMessageResult + -> IO ApnMessageResult sendApnRaw connection token message = bracket_ - (lift $ waitQSem (apnConnectionWorkerPool connection)) - (lift $ signalQSem (apnConnectionWorkerPool connection)) $ do + (waitQSem (apnConnectionWorkerPool connection)) + (signalQSem (apnConnectionWorkerPool connection)) $ do let requestHeaders = [ ( ":method", "POST" ) , ( ":scheme", "https" ) , ( ":authority", TE.encodeUtf8 hostname ) @@ -609,7 +597,7 @@ -- sendData client stream (HTTP2.setEndStream) message upload message (HTTP2.setEndHeader . HTTP2.setEndStream) client (_outgoingFlowControl client) stream osfc let pph hStreamId hStream hHeaders hIfc hOfc = - lift $ print hHeaders + print hHeaders response <- waitStream stream isfc pph let (errOrHeaders, frameResponses, _) = response case errOrHeaders of @@ -644,17 +632,8 @@ 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 - +catchIOErrors :: SpecifyError a => IO a -> IO a +catchIOErrors = flip catchIOError (return . isAnError) -- The type of permanent error indicated by APNS -- See https://apple.co/2RDCdWC table 8-6 for the meaning of each value.