push-notify-apn (empty) → 0.1.0.2
raw patch · 8 files changed
+703/−0 lines, 8 filesdep +aesondep +basedep +base16-bytestringsetup-changed
Dependencies added: aeson, base, base16-bytestring, binary, bytestring, containers, data-default, http2, http2-client, optparse-applicative, push-notify-apn, random, text, time, tls, x509, x509-store
Files
- LICENSE +30/−0
- README.md +46/−0
- Setup.hs +2/−0
- app/Main.hs +69/−0
- changelog.md +4/−0
- push-notify-apn.cabal +65/−0
- src/Network/PushNotify/APN.hs +485/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Memrange UG (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Hans-Christian Esperer nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,46 @@+# push-notify-apn++push-notify-apn is a library and command line utility that can be used to send+push notifications to mobile devices running iOS. Push notifications are small+messages that can be sent to apps on smart phones and tablets+without the need to keep open a long lived TCP connection per app, dramatically+reducing the power consumption in standby mode.++The library is still in an experimental state. Bug and success reports+as well as feature and pull requests are very welcome.++Sending a message is as simple as:++ let sandbox = True -- Development environment+ timeout = 10 -- Minutes to keep the connection open+ session <- newSession "my.key" "my.crt"+ "/etc/ssl/ca_certificates.txt" sandbox+ timeout "my.bundle.id"+ let payload = alertMessage "Title" "Hello From Haskell"+ message = newMessage payload+ token = base16EncodedToken "the-token"+ success <- sendMessage session token payload+ print success++# command line utility++The command line utility can be used for testing your app. Use like this:++ sendapn -c ../apn.crt -k ../apn.key -a \+ /etc/ssl/certs/ca-certificates.crt -b your.bundle.id -s \+ -t your-token -m "Your-message"++The -s flag means "sandbox", i.e., for apps that are deployed in a+development environment.++# credentials++apn.crt and apn.key are the certificate and private key of your+APN certificate from apple. To extract them from a .p12 file,+use openssl:++ openssl pkcs12 -in mycredentials.p12 -out apn.crt -nokeys+ openssl pkcs12 -in mycredentials.p12 -nodes -out apn.key -nocerts+ +ca-certificates.crt is a truststore that contains the root certificates+that are used to verify the apn server's server certificates.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent+import Data.Semigroup ((<>))+import Options.Applicative++import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as T++import Network.PushNotify.APN+++data ApnOptions = ApnOptions+ { certpath :: String+ , keypath :: String+ , capath :: String+ , topic :: String+ , token :: String+ , sandbox :: Bool+ , text :: String }++p :: Parser ApnOptions+p = ApnOptions+ <$> strOption+ ( short 'c'+ <> metavar "CERTIFICATE"+ <> help "Path to the certificate" )+ <*> strOption+ ( short 'k'+ <> metavar "PRIVATEKEY"+ <> help "Path to the certificate's private key" )+ <*> strOption+ ( short 'a'+ <> metavar "CATRUSTSTORE"+ <> help "Path to the CA truststore" )+ <*> strOption+ ( short 'b'+ <> metavar "BUNDLEID"+ <> help "Bundle ID of the app to send the notification to. Must correspond to the certificate." )+ <*> strOption+ ( short 't'+ <> metavar "TOKEN"+ <> help "Token of the device to send the notification to" )+ <*> switch+ ( long "sandbox"+ <> short 's'+ <> help "Whether to use the sandbox (non-production deployments)" )+ <*> strOption+ ( short 'm'+ <> metavar "MESSAGE"+ <> help "Message to send to the device" )+ ++main :: IO ()+main = send =<< execParser opts+ where+ opts = info (p <**> helper)+ ( fullDesc+ <> progDesc "Sends a push notification to an apple device"+ <> header "apn- a test for the apn library" )++send :: ApnOptions -> IO ()+send o = do+ session <- newSession (keypath o) (certpath o) (capath o) (sandbox o) 10 (B8.pack $ topic o)+ let payload = alertMessage "push-notify-apn" (T.pack $ text o)+ message = newMessage payload+ apntoken = hexEncodedToken . T.pack . token $ o+ sendMessage session apntoken message >>= print
+ changelog.md view
@@ -0,0 +1,4 @@+0.1.0.1+=======++- Initial release
+ push-notify-apn.cabal view
@@ -0,0 +1,65 @@+name: push-notify-apn+version: 0.1.0.2+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+ push notifications to mobile devices running iOS. Push notifications are small+ messages that can be sent to apps on smart phones and tablets+ without the need to keep open a long lived TCP connection per app, dramatically+ reducing the power consumption in standby mode.+homepage: https://github.com/memrange/apn#readme+license: BSD3+license-file: LICENSE+author: Hans-Christian Esperer+maintainer: hc@hcesperer.org+copyright: 2017 Memrange UG+category: Network, Cloud, Mobile+build-type: Simple+extra-source-files: README.md+ , changelog.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Network.PushNotify.APN+ build-depends: base >= 4.7 && < 5+ , aeson+ , base16-bytestring+ , binary+ , bytestring+ , containers+ , data-default+ , http2+ , http2-client+ , random+ , text+ , time+ , tls+ , x509+ , x509-store++ default-language: Haskell2010++executable sendapn+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , push-notify-apn+ , bytestring+ , optparse-applicative+ , text+ default-language: Haskell2010++test-suite apn-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , push-notify-apn+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/memrange/push-notify-apn
+ src/Network/PushNotify/APN.hs view
@@ -0,0 +1,485 @@+-- |+-- Module: APN+-- Copyright: (C) 2017, memrange UG+-- License: BSD3+-- Maintainer: Hans-Christian Esperer <hc@memrange.io>+-- Stability: experimental+-- Portability: portable+--+-- Send push notifications using Apple's HTTP2 APN API+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Network.PushNotify.APN+ ( ApnSession+ , JsonAps+ , JsonApsAlert+ , JsonApsMessage+ , ApnMessageResult+ , ApnToken+ , sendMessage+ , sendSilentMessage+ , newSession+ , sendRawMessage+ , emptyMessage+ , setSound+ , clearSound+ , setCategory+ , clearCategory+ , setBadge+ , clearBadge+ , alertMessage+ , setAlertMessage+ , clearAlertMessage+ , newMessage+ , newMessageWithCustomPayload+ , hexEncodedToken+ , rawToken+ ) where++import Control.Concurrent+import Control.Concurrent.QSem+import Control.Exception+import Control.Monad+import Data.Aeson+import Data.Aeson.Types+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.Default (def)+import Data.Int+import Data.IORef+import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Time.Clock.POSIX+import Data.X509+import Data.X509.CertificateStore+import GHC.Generics+import Network.HTTP2.Client+import Network.HTTP2.Client.Helpers+import Network.TLS hiding (sendData)+import Network.TLS.Extra.Cipher+import System.Random++import qualified Data.ByteString as S+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as L+import qualified Data.List as DL+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import qualified Network.HTTP2 as HTTP2+import qualified Network.HPACK as HTTP2++-- | A session that manages connections to Apple's push notification service+data ApnSession = ApnSession+ { apnSessionPool :: !(IORef [ApnConnection])+ , apnSessionConnectionInfo :: !ApnConnectionInfo+ , apnSessionConnectionManager :: !ThreadId }++-- | Information about an APN connection+data ApnConnectionInfo = ApnConnectionInfo+ { aciCertPath :: !FilePath+ , aciCertKey :: !FilePath+ , aciCaPath :: !FilePath+ , aciHostname :: !Text+ , aciMaxConcurrentStreams :: !Int+ , aciTopic :: !ByteString }++-- | A connection to an APN API server+data ApnConnection = ApnConnection+ { apnConnectionConnection :: !Http2Client+ , apnConnectionInfo :: !ApnConnectionInfo+ , apnConnectionWorkerPool :: !QSem+ , apnConnectionLastUsed :: !Int64+ , apnConnectionFlowControlWorker :: !ThreadId }++-- | An APN token used to uniquely identify a device+newtype ApnToken = ApnToken { unApnToken :: ByteString }++-- | Create a token from a raw bytestring+rawToken+ :: ByteString+ -- ^ The bytestring that uniquely identifies a device (APN token)+ -> ApnToken+rawToken = ApnToken . B16.encode++-- | Create a token from a hex encoded text+hexEncodedToken+ :: Text+ -- ^ The base16 (hex) encoded unique identifier for a device (APN token)+ -> ApnToken+hexEncodedToken = ApnToken . TE.encodeUtf8++-- | The result of a send request+data ApnMessageResult = ApnMessageResultOk+ | ApnMessageResultFatalError+ | ApnMessageResultTemporaryError+ | ApnMessageResultTokenNoLongerValid+ deriving (Enum, Eq, Show)++-- | The specification of a push notification's message body+data JsonApsAlert = JsonApsAlert+ { jaaTitle :: !Text+ -- ^ A short string describing the purpose of the notification.+ , jaaBody :: !Text+ -- ^ The text of the alert message.+ } deriving (Generic, Show)++instance ToJSON JsonApsAlert where+ toJSON = genericToJSON defaultOptions+ { fieldLabelModifier = drop 3 . map toLower }++-- | Push notification message's content+data JsonApsMessage+ -- | Push notification message's content+ = JsonApsMessage+ { jamAlert :: !(Maybe JsonApsAlert)+ -- ^ A text to display in the notification+ , jamBadge :: !(Maybe Int)+ -- ^ A number to display next to the app's icon. If set to (Just 0), the number is removed.+ , jamSound :: !(Maybe Text)+ -- ^ A sound to play, that's located in the Library/Sounds directory of the app+ -- This should be the name of a sound file in the application's main bundle, or+ -- in the Library/Sounds directory of the app.+ , jamCategory :: !(Maybe Text)+ -- ^ The category of the notification. Must be registered by the app beforehand.+ } deriving (Generic, Show)++-- | Create an empty apn message+emptyMessage :: JsonApsMessage+emptyMessage = JsonApsMessage Nothing Nothing Nothing Nothing++-- | Set a sound for an APN message+setSound+ :: Text+ -- ^ The sound to use (either "default" or something in the application's bundle)+ -> JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+setSound s a = a { jamSound = Just s }++-- | Clear the sound for an APN message+clearSound+ :: JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+clearSound a = a { jamSound = Nothing }++-- | Set the category part of an APN message+setCategory+ :: Text+ -> JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+setCategory c a = a { jamCategory = Just c }++-- | Clear the category part of an APN message+clearCategory+ :: JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+clearCategory a = a { jamCategory = Nothing }++-- | Set the badge part of an APN message+setBadge+ :: Int+ -> JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+setBadge i a = a { jamBadge = Just i }++-- | Clear the badge part of an APN message+clearBadge+ :: JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+clearBadge a = a { jamBadge = Nothing }++-- | Create a new APN message with an alert part+alertMessage+ :: Text+ -- ^ The title of the message+ -> Text+ -- ^ The body of the message+ -> JsonApsMessage+alertMessage title text = setAlertMessage title text emptyMessage++-- | Set the alert part of an APN message+setAlertMessage+ :: Text+ -- ^ The title of the message+ -> Text+ -- ^ The body of the message+ -> JsonApsMessage+ -- ^ The message to alter+ -> JsonApsMessage+setAlertMessage title text a = a { jamAlert = Just jam }+ where+ jam = JsonApsAlert title text++-- | Remove the alert part of an APN message+clearAlertMessage+ :: JsonApsMessage+ -- ^ The message to modify+ -> JsonApsMessage+clearAlertMessage a = a { jamAlert = Nothing }++instance ToJSON JsonApsMessage where+ toJSON = genericToJSON defaultOptions+ { fieldLabelModifier = drop 3 . map toLower }++-- | A push notification message+data JsonAps+ -- | A push notification message+ = JsonAps+ { jaAps :: !JsonApsMessage+ -- ^ The main content of the message+ , jaAppSpecificContent :: !(Maybe Text)+ -- ^ Extra information to be used by the receiving app+ } deriving (Generic, Show)++instance ToJSON JsonAps where+ toJSON = genericToJSON defaultOptions+ { fieldLabelModifier = drop 2 . map toLower }++-- | Prepare a new apn message consisting of a+-- standard message without a custom payload+newMessage+ :: JsonApsMessage+ -- ^ The standard message to include+ -> JsonAps+newMessage = flip JsonAps Nothing++-- | Prepare a new apn message consisting of a+-- standard message and a custom payload+newMessageWithCustomPayload+ :: JsonApsMessage+ -- ^ The message+ -> Text+ -- ^ The custom payload+ -> JsonAps+newMessageWithCustomPayload message payload =+ JsonAps message (Just payload)++-- | Start a new session for sending APN messages. A session consists of a+-- connection pool of connections to the APN servers, while each connection has a+-- pool of workers that create HTTP2 streams to send individual push+-- notifications.+newSession+ :: FilePath+ -- ^ Path to the client certificate key+ -> FilePath+ -- ^ Path to the client certificate+ -> FilePath+ -- ^ Path to the CA+ -> Bool+ -- ^ Sandbox?+ -> 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+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+ connections <- newIORef []+ connectionManager <- forkIO $ manage 1800 connections+ return $ ApnSession connections connInfo connectionManager++getConnection :: ApnSession -> IO ApnConnection+getConnection s = do+ let pool = apnSessionPool s+ ci = apnSessionConnectionInfo s+ connections <- readIORef pool+ let len = length connections+ if len == 0+ then do+ conn <- newConnection ci+ atomicModifyIORef' pool (\a -> (conn:a, ()))+ return conn+ 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++replaceNth n newVal (x:xs)+ | n == 0 = newVal:xs+ | otherwise = x:replaceNth (n-1) newVal 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)) ([],[]))+ mapM_ closeApnConnection expiredOnes+ threadDelay 60000000+++closeApnConnection :: ApnConnection -> IO ()+closeApnConnection apnConnection = do+ putStrLn "Closing connection, sending goaway"+ _gtfo (apnConnectionConnection apnConnection) HTTP2.NoError ""++newConnection :: ApnConnectionInfo -> IO ApnConnection+newConnection aci = do+ putStrLn "Starting new connection..."+ Just castore <- readCertificateStore $ aciCaPath aci+ Right credential <- credentialLoadX509 (aciCertPath aci) (aciCertKey aci)+ let credentials = Credentials [credential]+ shared = def { sharedCredentials = credentials+ , sharedCAStore=castore }+ maxConcurrentStreams = aciMaxConcurrentStreams aci+ clip = ClientParams+ { clientUseMaxFragmentLength=Nothing+ , clientServerIdentification=(T.unpack hostname, undefined)+ , clientUseServerNameIndication=True+ , clientWantSessionResume=Nothing+ , clientShared=shared+ , clientHooks=def+ { onCertificateRequest=const . return . Just $ credential }+ , clientDebug=DebugParams { debugSeed=Nothing, debugPrintSeed=const $ return () }+ , clientSupported=def+ { supportedVersions=[ TLS12 ]+ , supportedCiphers=ciphersuite_strong }+ }++ conf = [ (HTTP2.SettingsMaxFrameSize, 16384)+ , (HTTP2.SettingsMaxConcurrentStreams, maxConcurrentStreams)+ , (HTTP2.SettingsMaxHeaderBlockSize, 4096)+ , (HTTP2.SettingsInitialWindowSize, 65536)+ , (HTTP2.SettingsEnablePush, 1)+ ]++ hostname = aciHostname aci+ client <- newHttp2Client (T.unpack hostname) 443 4096 4096 clip conf+ flowWorker <- forkIO $ forever $ do+ updated <- _updateWindow $ _incomingFlowControl client+ when updated $ putStrLn "sending flow-control update"+ 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++-- | Send a raw payload as a push notification message (advanced)+sendRawMessage+ :: ApnSession+ -- ^ Session to use+ -> ApnToken+ -- ^ Device to send the message to+ -> ByteString+ -- ^ The message to send+ -> IO ApnMessageResult+sendRawMessage s token payload = 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++-- | Send a push notification message.+sendMessage+ :: ApnSession+ -- ^ Session to use+ -> ApnToken+ -- ^ Device to send the message to+ -> JsonAps+ -- ^ The message to send+ -> IO ApnMessageResult+sendMessage s token payload = 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++-- | Send a silent push notification+sendSilentMessage+ :: ApnSession+ -- ^ Session to use+ -> ApnToken+ -- ^ Device to send the message to+ -> IO ApnMessageResult+sendSilentMessage s token = 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++-- | Send a push notification message.+sendApnRaw+ :: ApnConnection+ -- ^ Connection to use+ -> ApnToken+ -- ^ Device to send the message to+ -> ByteString+ -- ^ The message to send+ -> IO (Either TooMuchConcurrency ApnMessageResult)+sendApnRaw connection token message = bracket_+ (waitQSem (apnConnectionWorkerPool connection))+ (signalQSem (apnConnectionWorkerPool connection)) $ do+ let headers = [ ( ":method", "POST" )+ , ( ":scheme", "https" )+ , ( ":authority", TE.encodeUtf8 hostname )+ , ( ":path", "/3/device/" `S.append` token1 )+ , ( "apns-topic", topic ) ]+ aci = apnConnectionInfo connection+ hostname = aciHostname aci+ topic = aciTopic aci+ client = apnConnectionConnection connection+ token1 = unApnToken token++ _startStream client $ \stream ->+ let init = _headers stream headers 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+ case errOrHeaders of+ Left err -> return ApnMessageResultTemporaryError+ Right hdrs1 -> do+ let Just status = DL.lookup ":status" hdrs1+ return $ case status of+ "200" -> ApnMessageResultOk+ "400" -> ApnMessageResultFatalError+ "403" -> ApnMessageResultFatalError+ "405" -> ApnMessageResultFatalError+ "410" -> ApnMessageResultTokenNoLongerValid+ "413" -> ApnMessageResultFatalError+ "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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"