diff --git a/ApplePush.cabal b/ApplePush.cabal new file mode 100644 --- /dev/null +++ b/ApplePush.cabal @@ -0,0 +1,29 @@ +Name: ApplePush +Version: 0.1 + +Cabal-Version: >= 1.2 +Author: Chris Moos +Maintainer: Chris Moos +Synopsis: Library for Apple Push Notification Service +Category: Network +license: BSD3 +license-file: LICENSE +Build-Type: Simple +Description: This library provides an interface to send notifications with the Apple Push Notification Service. + + . + Note: Your connection to Apple's Push Notification service must be secured with SSL. Currently, Haskell's support + for SSL is incomplete, therefore you should use an SSL tunnel to connect your application to the push service, such as stunnel. + +library + build-depends: base >= 4 && < 5, haskell98, bytestring >= 0.9, + binary >= 0.5, mtl, network, json >= 0.4 + exposed-modules: ApplePush, ApplePush.Types, ApplePush.Notification, ApplePush.Helpers + hs-source-dirs: src + +Executable applepushtest + Build-Depends: base + other-modules: ApplePush + Main-Is: Main.hs + ghc-options: -threaded + Hs-Source-Dirs: src diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) Chris Moos 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +module Main where + +import Distribution.Simple +main = defaultMain diff --git a/src/ApplePush.hs b/src/ApplePush.hs new file mode 100644 --- /dev/null +++ b/src/ApplePush.hs @@ -0,0 +1,69 @@ +-- | This module implements the Apple Push Notification Service +-- +-- +-- The notification service uses 'Control.Concurrent.Chan' for asynchronous communication. +-- Call 'connectToNotificationService' and pass it a 'NotificationCallbackChan'. +-- The notification service will post a 'NotificationServerConencted' message, with a channel that you should use to send notifications with. +module ApplePush ( +module ApplePush.Types, +module ApplePush.Helpers, +module ApplePush.Notification, +connectToNotificationService +) where + +import ApplePush.Types +import ApplePush.Notification +import ApplePush.Helpers + +import Network +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Char8 as BSC +import System.IO +import Data.Binary.Put +import Control.Concurrent.Chan +import Control.Concurrent +import qualified Control.Exception(catch) + +handleMsg hdl (NotificationServiceSend token payload) = do + let y = BS.pack $ BSL.unpack $ runPut $ do + putWord8 0 {- command -} + putWord16be 32 {- token -} + putByteString token + putWord16be (fromIntegral $ length payload) {- payload length -} + putByteString $ BSC.pack payload + BS.hPut hdl y + hFlush hdl +handleMsg hdl NotificationServiceExit = do + return () +handleMsg hdl msg = return () + +notificationServiceHandler :: Handle -> NotificationServiceChan -> NotificationCallbackChan -> IO () +notificationServiceHandler hdl sc cc = do + msg <- readChan sc + handleMsg hdl msg + notificationServiceHandler hdl sc cc + +onConnect :: Handle -> NotificationCallbackChan -> IO () +onConnect hdl callback = do + c <- newChan + writeChan callback (NotificationServerConnected c) + notificationServiceHandler hdl c callback `catch` (\e -> writeChan callback NotificationServerDisconnected) + +getConnection :: String -> Integer -> IO (Either String Handle) +getConnection h p = withSocketsDo $ do + hdl <- connectTo h (PortNumber $ fromIntegral p) + return $ Right hdl + +-- | Connects to the notification service for the host and port specified. +connectToNotificationService :: String -> Integer -> NotificationCallbackChan -> IO () +connectToNotificationService host port callback = do + tid <- forkIO f + return () + where + f = do + hdl <- getConnection host port `catch` (\e -> return $ Left $ show e) + case hdl of + Right handle -> onConnect handle callback + Left msg -> writeChan callback (NotificationServerUnableToConnect msg) + diff --git a/src/ApplePush/Helpers.hs b/src/ApplePush/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/ApplePush/Helpers.hs @@ -0,0 +1,34 @@ +-- | Helpers for the Apple Push Service +module ApplePush.Helpers ( +hexTokenToByteString, +tokenToString, +byteStringToHex +) where + +import qualified Data.ByteString as BS +import Data.Word +import Numeric + +import ApplePush.Types + +byteStringToHex :: BS.ByteString -> String +byteStringToHex bs = do + let s = concat $ map (\x -> (toHex x) ++ " ") (BS.unpack bs) + take ((length s) - 1) s + +toHex :: Word8 -> String +toHex b = case showHex b "" of + a:b:[] -> a:b:[] + a:[] -> '0':a:[] + +-- | Converts a device token to a hex string +tokenToString :: DeviceToken -> String +tokenToString y = (concat $ map (\x -> showHex x "") (BS.unpack y)) + +-- | Converts a hex string to a device token +hexTokenToByteString :: String -> DeviceToken +hexTokenToByteString [] = BS.empty +hexTokenToByteString (a:[]) = BS.empty +hexTokenToByteString (a:b:r) = do + BS.append (BS.pack [(read (concat $ ["0x", [a], [b]]) :: Word8)]) $ hexTokenToByteString r + diff --git a/src/ApplePush/Notification.hs b/src/ApplePush/Notification.hs new file mode 100644 --- /dev/null +++ b/src/ApplePush/Notification.hs @@ -0,0 +1,34 @@ +-- | Creates JSON notification payloads for the Apple Push Notification Service +module ApplePush.Notification ( +makeRawNotification, +makeNotification +) where + +import Text.JSON + +import ApplePush.Types + + +-- | Makes a notification, takes an alert(string/dictionary), integer, string for the sound, and any user data (key/value dictionary.) +makeNotification :: Maybe (Either String [(String, JSValue)]) -> Maybe Integer -> Maybe String -> Maybe [(String, JSValue)] -> String +makeNotification alert badge sound ud = do + encodeStrict $ makeObj $ [("aps", makeObj ((mkAlert alert) ++ (mkBadge badge) ++ (mkSound sound)))] ++ (mkUD ud) + where + mkSound (Just x) = [("sound", showJSON $ x)] + mkSound Nothing = [] + mkBadge (Just x) = [("badge", showJSON $ x)] + mkBadge Nothing = [] + mkUD (Just x) = x + mkUD Nothing = [] + mkAlert (Just (Right x)) = mkRawAlert $ makeObj x + mkAlert (Just (Left x)) = mkRawAlert $ showJSON x + mkAlert Nothing = [] + mkRawAlert x = [("alert", x)] + +makeNotification Nothing Nothing Nothing Nothing = makeRawNotification [("aps", showJSON $ "")] + + +-- | Takes a list of key, JSValue pairs and converts them to a string +makeRawNotification :: [(String, JSValue)] -> String +makeRawNotification x = do + encodeStrict $ makeObj x diff --git a/src/ApplePush/Types.hs b/src/ApplePush/Types.hs new file mode 100644 --- /dev/null +++ b/src/ApplePush/Types.hs @@ -0,0 +1,39 @@ +-- | Types for the Apple Push Service +module ApplePush.Types ( +DeviceToken, +NotificationServiceMsg(..), +NotificationServiceChan, +NotificationCallbackMsg(..), +NotificationCallbackChan, +NotificationPayload, +NotificationAction +) where + +import Data.ByteString +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad.State as SM +import Text.JSON + +-- | Device Token +type DeviceToken = ByteString + +-- | These messages are sent to the Apple Push Notification Service +data NotificationServiceMsg = NotificationServiceSend DeviceToken String | NotificationServiceExit + +type NotificationServiceChan = Chan NotificationServiceMsg + + +-- | Callback messages from the Apple Push Notification Service +data NotificationCallbackMsg = NotificationServerConnected NotificationServiceChan | + NotificationServerUnableToConnect String | NotificationServerDisconnected + +type NotificationCallbackChan = Chan NotificationCallbackMsg + + +-- | Notification payload is a JSON Object +type NotificationPayload = JSObject JSValue + +-- | Notification actions +type NotificationAction = JSObject JSValue diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,48 @@ +module Main where + +import System +import System.IO +import qualified Data.ByteString as BS +import Control.Concurrent.Chan +import Control.Concurrent +import Text.JSON + +import ApplePush + +appVersion = 0.1 + +getMsgs t c = do + putStr "Message> " + hFlush stdout + m <- hGetLine stdin + writeChan c (NotificationServiceSend t (makeNotification (Just $ Left $ m) Nothing (Just "chime") Nothing)) + getMsgs t c + +notificationCallback :: DeviceToken -> NotificationCallbackChan -> IO () +notificationCallback t c = do + msg <- readChan c + case msg of + (NotificationServerConnected srvChan) -> do + tid <- forkIO $ getMsgs t srvChan + return () + _ -> return () + notificationCallback t c + +showUsage a v = do + putStrLn $ "Apple Push Test, Version " ++ (show v) + putStrLn $ "usage: " ++ a ++ " device_token(hex)" + +start (device_token:a) = do + let token = hexTokenToByteString device_token + putStrLn $ "Device Token: " ++ (tokenToString token) + c <- newChan + connectToNotificationService "127.0.0.1" 2195 c + notificationCallback token c + +main :: IO () +main = do + args <- getArgs + prog <- getProgName + if length args < 1 + then showUsage prog appVersion + else start args