diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +0.1.0.1 +======= + +- Initial release diff --git a/push-notify-apn.cabal b/push-notify-apn.cabal new file mode 100644 --- /dev/null +++ b/push-notify-apn.cabal @@ -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 diff --git a/src/Network/PushNotify/APN.hs b/src/Network/PushNotify/APN.hs new file mode 100644 --- /dev/null +++ b/src/Network/PushNotify/APN.hs @@ -0,0 +1,485 @@ +-- | +-- Module: APN +-- Copyright: (C) 2017, memrange UG +-- License: BSD3 +-- Maintainer: Hans-Christian Esperer +-- 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"