diff --git a/apns-http2.cabal b/apns-http2.cabal --- a/apns-http2.cabal +++ b/apns-http2.cabal @@ -1,29 +1,31 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: db7c14d46fbfd626dfd55743886a8027e59c28ee11fce7ea2e14e693bacba209 name: apns-http2 -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Apple Push Notification service HTTP/2 integration. category: Network -homepage: https://github.com/ConferHealth/apns-http2#readme +homepage: https://github.com/ConferOpenSource/apns-http2#readme author: Confer Health, Inc. -maintainer: oss@confer.health -copyright: 2017 Confer Health, Inc. +maintainer: oss@vitalbio.com +copyright: 2017 Confer Health, Inc., 2020 Vital Biosciences license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 library hs-source-dirs: src - default-extensions: FlexibleContexts FlexibleInstances LambdaCase NamedFieldPuns NoMonomorphismRestriction OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections ViewPatterns ghc-options: -Wall -O2 build-depends: - base >= 4.7 && < 5 - , aeson + aeson , async + , base >=4.7 && <5 , bytestring , conduit , conduit-extra @@ -57,12 +59,14 @@ main-is: Main.hs hs-source-dirs: example - default-extensions: FlexibleContexts FlexibleInstances LambdaCase NamedFieldPuns NoMonomorphismRestriction OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables TemplateHaskell TupleSections ViewPatterns ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: - base >= 4.7 && < 5 - , aeson + aeson + , aeson-qq + , apns-http2 , async + , base >=4.7 && <5 + , base16-bytestring , bytestring , conduit , conduit-extra @@ -83,9 +87,8 @@ , tls , x509 , x509-store - , x509-validation - , aeson-qq - , apns-http2 - , base16-bytestring , x509-system + , x509-validation + other-modules: + Paths_apns_http2 default-language: Haskell2010 diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Main where +import Control.Concurrent (threadDelay) import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) import Data.Aeson (encode) import Data.Aeson.QQ (aesonQQ) @@ -7,6 +13,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy as BL +import Data.Foldable (for_) import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.IO as TIO @@ -49,28 +56,34 @@ Left connectError -> putStrLn $ "Failed to connect: " <> show connectError Right connection -> do - now <- getCurrentTime - let _apnsPushData_deviceToken = deviceToken - _apnsPushData_expiration = addUTCTime (86400*2) now - _apnsPushData_priority = Nothing - _apnsPushData_topic = topic - _apnsPushData_collapseId = Nothing - _apnsPushData_payload = BL.toStrict $ encode [aesonQQ| - { - "aps": { - "alert": { - "title": "Hello, APNs!", - "body": "If you're reading this you're too close to a working integration" + for_ [1..(100 :: Int)] $ \ _ -> do + now <- getCurrentTime + let _apnsPushData_deviceToken = deviceToken + _apnsPushData_expiration = addUTCTime (86400*2) now + _apnsPushData_priority = Nothing + _apnsPushData_topic = topic + _apnsPushData_collapseId = Nothing + _apnsPushData_payload = BL.toStrict $ encode [aesonQQ| + { + "aps": { + "alert": { + "title": "Hello, APNs!", + "body": "If you're reading this you're too close to a working integration" + }, + "badge": 1 }, - "badge": 1 + "additionalStuff": "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX", + "additionalStuff5": "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" } - } - |] + |] - _apnsConnection_submitPush connection $ ApnsPush (ApnsPushData {..}) $ \ res -> do - putStrLn . ("push result: " <>) . show $ res - putStrLn "closing connection" - _apnsConnection_close connection + _apnsConnection_submitPush connection $ ApnsPush (ApnsPushData {..}) $ \ res -> do + putStrLn . ("push result: " <>) . show $ res + + threadDelay 2000000 + + putStrLn "closing connection" + _apnsConnection_close connection terminationReason <- takeMVar terminationMv putStrLn . ("Connection terminated: " <>) . show $ terminationReason diff --git a/src/Network/Apns/Internal.hs b/src/Network/Apns/Internal.hs --- a/src/Network/Apns/Internal.hs +++ b/src/Network/Apns/Internal.hs @@ -1,3 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Network.Apns.Internal where import Control.Applicative ((<|>)) @@ -23,12 +32,13 @@ import Data.Aeson ((.:), (.:?), Value, eitherDecode', withObject) import Data.Aeson.Types (Parser, parseEither) import Data.Bifunctor (first) +import Data.Bool (bool) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (byteStringHex, toLazyByteString) import qualified Data.ByteString.Char8 as BSC8 import qualified Data.ByteString.Lazy as BL -import Data.Conduit (ConduitM, Producer, (.|), ($$), awaitForever, yield) +import Data.Conduit (ConduitT, (.|), awaitForever, yield, runConduit) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.TQueue (sinkTBMQueue, sourceTBMQueue) @@ -59,7 +69,6 @@ , ApnsPushResult(..) , ApnsTerminationReason(..) ) -import Network.BSD (getProtocolNumber) import qualified Network.HPACK as HP import qualified Network.HTTP2 as H2 import Network.Socket (Socket) @@ -207,10 +216,8 @@ connectSocket :: ExceptT ApnsConnectionError IO Socket connectSocket = do - tcp <- liftIO $ getProtocolNumber "tcp" let hints = Socket.defaultHints { Socket.addrFlags = [Socket.AI_ADDRCONFIG] - , Socket.addrProtocol = tcp , Socket.addrSocketType = Socket.Stream } addressInfos <- liftIO $ Socket.getAddrInfo (Just hints) (Just _apnsConnectionParams_hostName) (Just . show $ _apnsConnectionParams_portNumber) @@ -358,6 +365,7 @@ unless (connWindow <= 0) $ do let toWriteSize = min maxFrameSize . min connWindow . view writableStream_windowSize $ ws (toWriteBs, remainingBs) = BS.splitAt toWriteSize . view writableStream_remaining $ ws + didWriteSize = BS.length toWriteBs if BS.null remainingBs then do @@ -369,10 +377,10 @@ processorDebug $ "stream " <> (pack . show) sid <> " writing " <> (pack . show) toWriteSize <> " bytes with " <> (pack . show) (BS.length remainingBs) <> " bytes to go" processorWrite (H2.encodeInfo id sid) (H2.DataFrame toWriteBs) modifying (state_writableStreams . at sid . _Just) - $ over writableStream_windowSize (subtract toWriteSize) + $ over writableStream_windowSize (subtract didWriteSize) . set writableStream_remaining remainingBs - modifying state_connectionWindow (subtract toWriteSize) + modifying state_connectionWindow (subtract didWriteSize) go wses @@ -726,11 +734,11 @@ -- |Reader thread. Before this exits, some debug log will be emitted, the socket will be shut down for reads, and the reader queue will be closed. reader :: (Text -> IO ()) -> TLS.Context -> Socket -> TBMQueue ReaderEvent -> IO () reader debugLog tlsContext sock readerQueue = do - res <- try + res <- try $ runConduit $ sourceTls - $$ decodeH2Frames H2.defaultSettings + .| decodeH2Frames H2.defaultSettings .| CL.iterM (debugLog . ("received: " <>) . pack . show) - .| sinkTBMQueue readerQueue True + .| sinkTBMQueue readerQueue atomically $ closeTBMQueue readerQueue invokeWithoutException $ Socket.shutdown sock Socket.ShutdownReceive @@ -743,20 +751,23 @@ debugLog "reader ended normally" where - sourceTls :: Producer IO ByteString + sourceTls :: forall i. ConduitT i ByteString IO () sourceTls = liftIO (TLS.recvData tlsContext) >>= \ case bs | BS.null bs -> pure () | otherwise -> yield bs >> sourceTls - decodeH2Frames :: H2.Settings -> ConduitM ByteString ReaderEvent IO () + decodeH2Frames :: H2.Settings -> ConduitT ByteString ReaderEvent IO () decodeH2Frames settings = do let continue (eventMay, settings') = traverse_ yield eventMay >> decodeH2Frames settings' either yield continue <=< runExceptT $ do headerBytes <- lift $ BL.toStrict <$> CB.take H2.frameHeaderLength when (BS.length headerBytes < H2.frameHeaderLength) $ - throwError (ReadH2Error H2.ProtocolError "Insufficient header bytes" ApnsTerminatedInsufficientHeaderBytes) + bool + (throwError (ReadH2Error H2.ProtocolError "Insufficient header bytes" ApnsTerminatedInsufficientHeaderBytes)) + (throwError (ReadH2Error H2.StreamClosed "Closed with no data" ApnsTerminatedSilentlyClosed)) + (BS.null headerBytes) (frameType, frameHeader) <- either (\ h2Error -> throwError $ ReadH2Error (H2.errorCodeId h2Error) (BSC8.pack . show $ h2Error) (ApnsTerminatedHttp2Error h2Error)) pure $ @@ -790,9 +801,9 @@ -- |Writer thread. Before this exits, some debug log will be emitted, the socket will be shut down for writes, and the writer queue will be closed. writer :: (Text -> IO ()) -> TLS.Context -> Socket -> TBMQueue (H2.EncodeInfo, H2.FramePayload) -> IO () writer debugLog tlsContext sock writerQueue = do - res <- try + res <- try $ runConduit $ sourceTBMQueue writerQueue - $$ CL.iterM (debugLog . ("sending: " <>) . pack . show) + .| CL.iterM (debugLog . ("sending: " <>) . pack . show) .| CL.concatMap (map BL.fromStrict . uncurry H2.encodeFrameChunks) .| awaitForever (TLS.sendData tlsContext) @@ -807,4 +818,3 @@ throwIO ex Right _ -> debugLog "writer ended normally" - diff --git a/src/Network/Apns/Types.hs b/src/Network/Apns/Types.hs --- a/src/Network/Apns/Types.hs +++ b/src/Network/Apns/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- |Public types for using the APNs integration. module Network.Apns.Types ( ApnsPushData(..), apnsPushData_deviceToken, apnsPushData_expiration, apnsPushData_priority, apnsPushData_topic, apnsPushData_collapseId, apnsPushData_payload @@ -145,7 +148,7 @@ -- |The result of a push delivery attempt. data ApnsPushResult = ApnsPushDelivered ByteString - -- ^The push was successfully delivered to APNs along with its assigned @apns-id@. It may or may not be delivered to the target device, at the discretion + -- ^The push was successfully delivered to APNs along with its assigned @apns-id@. It may or may not be delivered to the target device, at the discretion -- of APNs. | ApnsPushErrored ApnsError -- ^APNs rejected the push notification. See the 'ApnsError' for more detail. @@ -179,10 +182,12 @@ = ApnsTerminatedLocally -- ^The APNs connection was locally closed using '_apnsConnection_close'. | ApnsTerminatedRemotely (Either ByteString ApnsErrorReason) - -- ^The APNs connection was remotely closed by APNs. The APNs error reason is given as @Right@ if available, otherwise some other error string + -- ^The APNs connection was remotely closed by APNs. The APNs error reason is given as @Right@ if available, otherwise some other error string -- given as @Left@. | ApnsTerminatedHttp2Error HTTP2Error -- ^The APNs connection was terminated due to an HTTP/2 protocol error. + | ApnsTerminatedSilentlyClosed + -- ^The APNs connection was terminated because a foreign entity closed the TCP stream and no reason was provided. | ApnsTerminatedInsufficientHeaderBytes -- ^The APNs connection was terminated because the TCP stream ended before being able to read all the header bytes for an HTTP/2 frame. | ApnsTerminatedInsufficientPayloadBytes FrameTypeId