push-notify-ccs (empty) → 0.1.0.0
raw patch · 7 files changed
+508/−0 lines, 7 filesdep +aesondep +asyncdep +attoparsecsetup-changed
Dependencies added: aeson, async, attoparsec, base, bytestring, cprng-aes, crypto-random, data-default, hslogger, mtl, network, pontarius-xmpp, push-notify, retry, stm, text, tls, tls-extra, unordered-containers, xml-types
Files
- LICENSE +23/−0
- Network/PushNotify/Ccs.hs +28/−0
- Network/PushNotify/Ccs/Constants.hs +50/−0
- Network/PushNotify/Ccs/Send.hs +296/−0
- Network/PushNotify/Ccs/Types.hs +60/−0
- Setup.hs +2/−0
- push-notify-ccs.cabal +49/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2013 Marcos Pividori++Permission is hereby granted, free of charge, to any+person obtaining a copy of this software and associated+documentation files (the "Software"), to deal in the+Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the+Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice+shall be included in all copies or substantial portions of+the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY+KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR+PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS+OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR+OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Network/PushNotify/Ccs.hs view
@@ -0,0 +1,28 @@+-- GSoC 2013 - Communicating with mobile devices.++-- | This library defines an API for communicating with Android powered devices, sending Push Notifications through Cloud Connection Server (GCM).+--+--The GCM Cloud Connection Server (CCS) is a connection server based on XMPP.+--+--CCS allows 3rd-party app servers to communicate with Android devices by establishing a persistent TCP connection with Google servers using the XMPP protocol. This communication is asynchronous and bidirectional.+--+--To establish a XMPP connection, this library uses Pontarius XMPP library.++module Network.PushNotify.Ccs+ (+ -- * CCS Service+ startCCS+ , closeCCS+ , sendCCS+ -- * CCS Settings+ , GCMCcsConfig(..)+ -- * CCS Utilities+ , withCCS+ , withCCS'+ , CCSManager+ , module Network.PushNotify.Gcm.Types+ ) where++import Network.PushNotify.Gcm.Types+import Network.PushNotify.Ccs.Types+import Network.PushNotify.Ccs.Send
+ Network/PushNotify/Ccs/Constants.hs view
@@ -0,0 +1,50 @@+-- GSoC 2013 - Communicating with mobile devices.++{-# LANGUAGE OverloadedStrings #-}++-- | This Module define the main constants for sending Push Notifications through Cloud Connection Server (GCM).+module Network.PushNotify.Ccs.Constants where++import Data.Text++cCCS_URL :: Text+cCCS_URL = "gcm.googleapis.com"++cCCS_PORT :: Integer+cCCS_PORT = 5235++cREGISTRATION_IDS :: Text+cREGISTRATION_IDS = "registration_ids"++cMessageId :: Text+cMessageId = "message_id"++cTo :: Text+cTo = "to"++cMessageType :: Text+cMessageType = "message_type"++cAck :: Text+cAck = "ack"++cFrom :: Text+cFrom = "from"++cData :: Text+cData = "data"++cError :: Text+cError = "error"++cBadRegistration :: Text+cBadRegistration = "BAD_REGISTRATION"++cDeviceUnregistered :: Text+cDeviceUnregistered = "DEVICE_UNREGISTERED"++cInternalServerError :: Text+cInternalServerError = "INTERNAL_SERVER_ERROR"++cServiceUnAvailable :: Text+cServiceUnAvailable = "SERVICE_UNAVAILABLE"
+ Network/PushNotify/Ccs/Send.hs view
@@ -0,0 +1,296 @@+-- GSoC 2013 - Communicating with mobile devices.++{-# LANGUAGE OverloadedStrings , ScopedTypeVariables #-}++-- | This Module define the main function to send Push Notifications through Cloud Connection Server (GCM).+module Network.PushNotify.Ccs.Send+ ( startCCS+ , closeCCS+ , sendCCS+ , withCCS+ , withCCS'+ ) where++import Network.PushNotify.Ccs.Constants+import Network.PushNotify.Ccs.Types+import Network.PushNotify.Gcm.Types++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.Chan+import Control.Concurrent.STM.TChan+import Control.Monad.Error+import Control.Monad.STM+import Control.Monad+import Control.Retry+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.Parser+import Data.Default+import Data.Functor+import Data.IORef+import Data.Int+import Data.List+import Data.Text+import Data.Text.Encoding+import Data.Monoid ((<>))+import Data.XML.Types+import qualified Data.Attoparsec.ByteString as AB+import qualified Control.Exception as CE+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as E+import Network+import Network.Xmpp+import Network.Xmpp.Internal+import Network.TLS+import Network.TLS.Extra+import Crypto.Random.API+import qualified Crypto.Random.AESCtr+import GHC.IO.Handle+import System.Log.Logger++-- 'connectCCS' starts a secure connection with CCS servers.+connectCCS :: GCMCcsConfig -> IO Session+connectCCS config = do+ let getStreamHandle = lift $ do+ hdl <- connectTo (unpack cCCS_URL) (PortNumber (fromIntegral cCCS_PORT))+ let bck = Backend { backendFlush = hFlush hdl+ , backendClose = hClose hdl+ , backendSend = BS.hPut hdl+ , backendRecv = BS.hGet hdl+ }+ gen <- Crypto.Random.AESCtr.makeSystem+ ctx <- contextNew+ bck+ (defaultParamsClient { pCiphers = ciphersuite_medium })+ gen+ handshake ctx+ return StreamHandle { streamSend = \bs -> CE.catch+ (sendData ctx (BL.fromChunks [bs]) >> return True)+ (\(_e :: CE.SomeException) -> return False)+ , streamReceive = \bs -> recvData ctx+ , streamFlush = contextFlush ctx+ , streamClose = bye ctx }+ result <- session+ (unpack cCCS_URL)+ (Just ( \_ -> [plain (senderID config <> "@" <> cCCS_URL) Nothing (aPiKey config) ] , Nothing))+ def{ sessionStreamConfiguration = def{+ connectionDetails = UseConnection getStreamHandle }+ }+ case result of+ Right s -> return s+ Left e -> fail $ "XmppFailure: " ++ (show e)++-- | 'startCCS' starts the CCS service, which means starting a worker thread which maintains a connection with CCS servers.+startCCS :: GCMCcsConfig -- ^ The main configuration for the GCM service.+ -> (RegId -> Value -> IO ()) -- ^ A callback function to be called each time a message arrives from a device.+ -> IO CCSManager+startCCS config newMessageCallbackFunction = do+ c <- newTChanIO+ ref <- newIORef $ Just ()+ tID <- forkIO $ CE.catch (ccsWorker config c newMessageCallbackFunction)+ (\(e :: CE.SomeException) -> atomicModifyIORef ref (\_ -> (Nothing,())) )+ return $ CCSManager ref c tID++-- Main worker thread.+ccsWorker :: GCMCcsConfig -> TChan (Chan GCMresult , MVar (Chan ()), GCMmessage) -> (RegId -> Value -> IO ()) -> IO ()+ccsWorker config requestChan callBackF = do+ sess <- recoverAll (ccsRetrySettings config) $ connectCCS config+ cont <- newIORef 1000+ hmap <- newIORef HM.empty+ lock <- newEmptyMVar+ locki <- newMVar ()+ errorChan <- newChan -- new Error Channel.+ s <- async (sender 1 cont lock locki hmap requestChan errorChan sess)+ r <- async (receiver cont lock hmap sess)+ res <- waitEither s r+ case res of+ Left _ -> do+ cancel r+ writeChan errorChan ()+ Right v -> do+ takeMVar locki+ cancel s+ writeChan errorChan ()+ ccsWorker config requestChan callBackF -- restarts.++ where+ buildMessage :: Value -> Message+ buildMessage value = Message{+ messageID = Nothing+ , messageFrom = Nothing+ , messageTo = Nothing+ , messageLangTag = Nothing+ , messageType = Normal+ , messagePayload = [ Element (Name "gcm" (Just "google:mobile:data") Nothing) []+ [(NodeContent $ ContentText $ E.decodeUtf8 $+ BS.concat . BL.toChunks $ encode value)]+ ]+ }++ buildAck :: Text -> Text -> Message+ buildAck regId id = buildMessage $ object [cTo .= regId , cMessageId .= id , cMessageType .= cAck]++ sender :: Int32+ -> IORef Int+ -> MVar ()+ -> MVar ()+ -> IORef (HM.HashMap Text (Chan GCMresult,RegId))+ -> TChan (Chan GCMresult , MVar (Chan ()), GCMmessage)+ -> Chan ()+ -> Session+ -> IO Int+ sender n cont lock locki hmap requestChan errorChan sess = do -- this function reads the channel and sends the messages.++ atomically $ peekTChan requestChan+ -- Now there is at least one element in the channel, so the next readTChan won't block.+ takeMVar locki++ (chanRes,varErr,msg) <- atomically $ readTChan requestChan+ echan <- dupChan errorChan+ putMVar varErr echan -- Here, notifies that it is attending this request,+ -- and provides a duplicated error channel.+ putMVar locki ()++ m <- loopSend (HS.toList $ registration_ids msg) msg chanRes sess hmap cont lock n++ sender m cont lock locki hmap requestChan errorChan sess++ loopSend [] _ _ _ _ _ _ n = return n+ loopSend (x:xs) msg chanRes sess hmap cont lock n = do+ checkCounter cont lock++ let id = pack $ show n+ value = fromGCMtoCCS x id msg++ atomicModifyIORef hmap (\hashMap -> (HM.insert id (chanRes,x) hashMap,()))++ sendMessage (buildMessage value) sess++ loopSend xs msg chanRes sess hmap cont lock (n+1)++ checkCounter :: IORef Int -> MVar () -> IO ()+ checkCounter cont lock = do+ newC <- atomicModifyIORef cont (\c -> (c-1,c-1))+ if newC == 0+ then do+ race (threadDelay 5000000 >> fail "Timeout") (takeMVar lock) -- blocks+ return ()+ else return ()++ controlPars :: Value -> Parser (Text,Text,Text,Maybe Text)+ controlPars (Object v) = (,,,) <$>+ v .: cMessageId <*>+ v .: cFrom <*>+ v .: cMessageType <*>+ v .:? cError+ controlPars _ = mzero++ msgPars :: Value -> Parser (Value,Text,Text)+ msgPars (Object v) = (,,) <$>+ v .: cData <*>+ v .: cMessageId <*>+ v .: cFrom+ msgPars _ = mzero++ receiver :: IORef Int+ -> MVar ()+ -> IORef (HM.HashMap Text (Chan GCMresult,RegId))+ -> Session+ -> IO Int+ receiver cont lock hmap sess = do+ msg <- getMessage sess+ let [Element _ _ ([NodeContent (ContentText p)])] = messagePayload msg+ value = case AB.maybeResult $ AB.parse json $ encodeUtf8 p of+ Nothing -> object []+ Just v -> v++ case parseMaybe controlPars value of+ Nothing -> case parseMaybe msgPars value of+ Nothing -> return () -- No expected msg.+ Just (v,id,f) -> do -- This is a message from device so I send the Ack response to CCS server+ -- and start the callback function.+ sendMessage (buildAck f id) sess+ forkIO $ callBackF f v+ return ()+ Just (id,f,t,e) -> do -- This is an ACK/NACK message so I look for the entry of this message+ -- in the hashmap and I put the response in the proper channel.++ oldC <- atomicModifyIORef cont (\c -> (c+1,c))++ if oldC == 0+ then putMVar lock () -- unblock the sender thread+ else return ()++ hashMap <- readIORef hmap++ case HM.lookup id hashMap of+ Just (chanRes,regId) -> do+ let result = getRes t e regId+ writeChan chanRes result+ Nothing -> return ()++ atomicModifyIORef hmap (\hashMap -> (HM.delete id hashMap,()))++ receiver cont lock hmap sess+ where+ getRes t e regId+ | t == cAck = def{success = Just 1}+ | e == Just cBadRegistration = def{failure = Just 1 , errorRest = HM.singleton regId cBadRegistration}+ | e == Just cDeviceUnregistered = def{failure = Just 1 , errorUnRegistered = HS.singleton regId }+ | e == Just cInternalServerError = def{failure = Just 1 , errorRest = HM.singleton regId cInternalServerError }+ | e == Just cServiceUnAvailable = def{failure = Just 1 , errorToReSend = HS.singleton regId }+ | otherwise = def{failure = Just 1 , errorToReSend = HS.singleton regId } -- no expected msg+++-- | 'closeCCS' stops the CCS service.+--+-- This means stopping the worker thread which maintains a connection with CCS servers.+closeCCS :: CCSManager -> IO ()+closeCCS m = do+ atomicModifyIORef (mState m) (\_ -> (Nothing,()))+ killThread $ mWorkerID m++-- | 'sendCCS' sends messages to a CCS Server.+--+-- Every time you call this function, it will put the notification in a channel waiting to be proceesed by the worker thread.+--+-- It will block until the worker thread receives a response from CCS server.+sendCCS :: CCSManager -> GCMmessage -> IO GCMresult+sendCCS man msg = do+ s <- readIORef $ mState man+ case s of+ Nothing -> fail "CCS Service closed."+ Just () -> do+ let requestChan = mCcsChannel man+ chanRes <- newChan+ varErr <- newEmptyMVar+ atomically $ writeTChan requestChan (chanRes,varErr,msg)+ errorChan <- takeMVar varErr+ v <- race (readChan errorChan) (loopResponse chanRes)+ case v of+ Left _ -> return def{ failure = Just (HS.size $ registration_ids msg)+ , errorToReSend = (registration_ids msg)} -- Error while sending.+ Right r -> return r -- Successful.+ where+ loopResponse chan = Data.List.foldr (\_ m -> do+ r <- readChan chan+ res <- m+ return $ r <> res)+ (return def)+ (HS.toList $ registration_ids msg)++-- | 'withCCS' creates a new manager, uses it in the provided function, and then releases it.+--+-- (The second argument is a callback function to be called each time a message arrives from a device).+withCCS :: GCMCcsConfig -> (RegId -> Value -> IO ()) -> (CCSManager -> IO a) -> IO a+withCCS confg callback fun = CE.bracket (startCCS confg callback) closeCCS fun++-- | 'withCCS'' creates a new manager, uses it in the provided function, and then releases it +-- (ignores messages that arrive from a device).+withCCS' :: GCMCcsConfig -> (CCSManager -> IO a) -> IO a+withCCS' confg fun = withCCS confg (\_ _ -> return ()) fun
+ Network/PushNotify/Ccs/Types.hs view
@@ -0,0 +1,60 @@+-- GSoC 2013 - Communicating with mobile devices.++{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}++-- | This Module define the main data types for sending Push Notifications through Cloud Connection Server (GCM).+module Network.PushNotify.Ccs.Types+ ( CCSManager(..)+ , GCMCcsConfig(..)+ , fromGCMtoCCS+ ) where++import Network.PushNotify.Gcm+import Network.PushNotify.Ccs.Constants++import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.STM.TChan+import Control.Retry+import qualified Data.HashMap.Strict as HM+import Data.Aeson.Types+import Data.Default+import Data.IORef+import Data.Text++-- | Manager of a CCS Connection.+data CCSManager = CCSManager+ { mState :: IORef (Maybe ())+ -- ^ @Nothing@ indicates that the manager is closed.+ , mCcsChannel :: TChan (Chan GCMresult , MVar (Chan ()), GCMmessage)+ -- ^ Channel to communicate with the worker thread.+ , mWorkerID :: ThreadId+ -- ^ Worker thread ID.+ }++-- | 'GCMCcsConfig' represents the main necessary information for sending notifications through CCS.+data GCMCcsConfig = GCMCcsConfig+ { aPiKey :: Text -- ^ Api key provided by Google.+ , senderID :: Text -- ^ Sender ID provided by Google.+ , ccsRetrySettings :: RetrySettings -- ^ How to retry to connect to CCS servers.+ }++instance Default GCMCcsConfig where+ def = GCMCcsConfig{+ aPiKey = ""+ , senderID = ""+ , ccsRetrySettings = RetrySettings {+ backoff = True+ , baseDelay = 200+ , numRetries = limitedRetries 2+ }+ }++-- 'fromGCMtoCCS' converts a Gcm message to a proper CCS message.+fromGCMtoCCS :: RegId -> Text -> GCMmessage -> Value+fromGCMtoCCS regId identif msg =+ let Object hmap = toJSON msg+ nmap = HM.delete cREGISTRATION_IDS hmap+ nmap' = HM.insert cTo (String regId) nmap+ nmap'' = HM.insert cMessageId (String identif) nmap'+ in Object nmap''
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ push-notify-ccs.cabal view
@@ -0,0 +1,49 @@+name: push-notify-ccs+version: 0.1.0.0+synopsis: A server-side library for sending/receiving push notifications through CCS (Google Cloud Messaging).+description: This library offers a simple abstraction for sending/receiving notifications through CCS (XMPP - Google Cloud Messaging)+ .+ For more information and test examples: <http://gsoc2013cwithmobiledevices.blogspot.com.ar/>+ .+ GitHub repository: <https://github.com/MarcosPividori/GSoC-Communicating-with-mobile-devices>+homepage: http://gsoc2013cwithmobiledevices.blogspot.com.ar/+license: MIT+license-file: LICENSE+author: Marcos Pividori, mentored by Michael Snoyman.+maintainer: Marcos Pividori <marcos.pividori@gmail.com>++category: Network, Cloud, Mobile+build-type: Simple+cabal-version: >=1.8++library+ exposed-modules: Network.PushNotify.Ccs++ other-modules: Network.PushNotify.Ccs.Constants+ , Network.PushNotify.Ccs.Types+ , Network.PushNotify.Ccs.Send++ build-depends: base >=4.5 && < 5+ , aeson >=0.6+ , async >=2.0+ , attoparsec >=0.10+ , bytestring >=0.9+ , cprng-aes >=0.5.2+ , crypto-random >=0.0.7+ , data-default >=0.5+ , hslogger >=1.2+ , mtl >=2.1+ , network >=2.4+ , pontarius-xmpp >=0.3+ , push-notify >=0.1+ , retry >=0.3+ , stm >=2.3+ , text >=0.11+ , tls >=1.1.5+ , tls-extra >=0.6.5+ , unordered-containers >=0.2+ , xml-types >=0.3++source-repository head+ type: git+ location: https://github.com/MarcosPividori/GSoC-Communicating-with-mobile-devices.git