diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Network/PushNotify/Ccs.hs b/Network/PushNotify/Ccs.hs
new file mode 100644
--- /dev/null
+++ b/Network/PushNotify/Ccs.hs
@@ -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
diff --git a/Network/PushNotify/Ccs/Constants.hs b/Network/PushNotify/Ccs/Constants.hs
new file mode 100644
--- /dev/null
+++ b/Network/PushNotify/Ccs/Constants.hs
@@ -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"
diff --git a/Network/PushNotify/Ccs/Send.hs b/Network/PushNotify/Ccs/Send.hs
new file mode 100644
--- /dev/null
+++ b/Network/PushNotify/Ccs/Send.hs
@@ -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
diff --git a/Network/PushNotify/Ccs/Types.hs b/Network/PushNotify/Ccs/Types.hs
new file mode 100644
--- /dev/null
+++ b/Network/PushNotify/Ccs/Types.hs
@@ -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''
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/push-notify-ccs.cabal b/push-notify-ccs.cabal
new file mode 100644
--- /dev/null
+++ b/push-notify-ccs.cabal
@@ -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:
+ .
+ GitHub repository:
+homepage: http://gsoc2013cwithmobiledevices.blogspot.com.ar/
+license: MIT
+license-file: LICENSE
+author: Marcos Pividori, mentored by Michael Snoyman.
+maintainer: Marcos Pividori
+
+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