Send.hs

-- GSoC 2013 - Communicating with mobile devices.

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}

-- | This Module define the main functions to send Push Notifications through Apple Push Notification Service,
-- and to communicate to the Feedback Service.
module Network.PushNotify.Apns.Send
    ( sendAPNS
    , startAPNS
    , closeAPNS
    , withAPNS
    , feedBackAPNS
    ) where

import Network.PushNotify.Apns.Types
import Network.PushNotify.Apns.Constants

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM.TChan
import Control.Monad.STM
import Control.Retry
import Data.Certificate.X509            (X509)
import Data.Convertible                 (convert)
import Data.Default
import Data.Int
import Data.IORef
import Data.Serialize
import Data.Text.Encoding               (encodeUtf8,decodeUtf8)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import qualified Data.Aeson.Encode      as AE
import qualified Data.ByteString        as B
import qualified Data.ByteString.Lazy   as LB
import qualified Data.ByteString.Base16 as B16
import qualified Data.HashSet           as HS
import qualified Data.HashMap.Strict    as HM
import qualified Control.Exception      as CE
import qualified Crypto.Random.AESCtr   as RNG
import Network
import Network.Socket.Internal          (PortNumber(PortNum))
import Network.TLS
import Network.TLS.Extra                (ciphersuite_all)
import System.Timeout

connParams :: X509 -> PrivateKey -> Params
connParams cert privateKey = defaultParamsClient{
                     pConnectVersion    = TLS11
                   , pAllowedVersions   = [TLS10,TLS11,TLS12]
                   , pCiphers           = ciphersuite_all
                   , pCertificates      = [(cert , Just privateKey)]
                   , onCertificatesRecv = const $ return CertificateUsageAccept
                   , roleParams         = Client $ ClientParams{
                            clientWantSessionResume    = Nothing
                          , clientUseMaxFragmentLength = Nothing
                          , clientUseServerName        = Nothing
                          , onCertificateRequest       = \x -> return [(cert , Just privateKey)]
                          }
                   }

-- 'connectAPNS' starts a secure connection with APNS servers.
connectAPNS :: APNSConfig -> IO Context
connectAPNS config = do
        handle  <- case environment config of
                    Development -> connectTo cDEVELOPMENT_URL
                                           $ PortNumber $ fromInteger cDEVELOPMENT_PORT
                    Production  -> connectTo cPRODUCTION_URL
                                           $ PortNumber $ fromInteger cPRODUCTION_PORT
                    Local       -> connectTo cLOCAL_URL
                                           $ PortNumber $ fromInteger cLOCAL_PORT
        rng     <- RNG.makeSystem
        ctx     <- contextNewOnHandle handle (connParams (apnsCertificate config) (apnsPrivateKey config)) rng
        handshake ctx
        return ctx

-- | 'startAPNS' starts the APNS service.
startAPNS :: APNSConfig -> IO APNSManager
startAPNS config = do
        c       <- newTChanIO
        ref     <- newIORef $ Just ()
        tID     <- forkIO $ CE.catch (apnsWorker config c) (\(e :: CE.SomeException) ->
                                                              atomicModifyIORef ref (\_ -> (Nothing,())))
        return $ APNSManager ref c tID $ timeoutLimit config

-- | 'closeAPNS' stops the APNS service.
closeAPNS :: APNSManager -> IO ()
closeAPNS m = do
                atomicModifyIORef (mState m) (\_ -> (Nothing,()))
                killThread $ mWorkerID m

-- | 'sendAPNS' sends the message to a APNS Server.
sendAPNS :: APNSManager -> APNSmessage -> IO APNSresult
sendAPNS m msg = do
    s <- readIORef $ mState m
    case s of
      Nothing -> fail "APNS Service closed."
      Just () -> do
        let requestChan = mApnsChannel m
        var1 <- newEmptyMVar

        atomically $ writeTChan requestChan (var1,msg)
        Just (errorChan,startNum) <- takeMVar var1 -- waits until the request is attended by the worker thread.
        -- errorChan -> is the channel where I will receive an error message if the sending fails.
        -- startNum  -> My messages will be identified from startNum to (startNum + num of messages-1)
        
        v    <- race  (readChan errorChan) (takeMVar var1 >> (threadDelay $ mTimeoutLimit m))

        let (success,fail)    = case v of
                Left s  -> if s >= startNum -- an error response, s identifies the last notification that was successfully sent.
                        then (\(a,b) -> (HS.fromList a,HS.fromList b)) $
                                        splitAt (s+1-startNum)   $ HS.toList $ deviceTokens msg -- An error occurred.
                        else (HS.empty,deviceTokens msg) -- An old error occurred, so nothing was sent.
                Right _ -> (deviceTokens msg,HS.empty) -- Successful.
        return $ APNSresult success fail

-- 'apnsWorker' starts the main worker thread.
apnsWorker :: APNSConfig -> TChan (MVar (Maybe (Chan Int,Int)) , APNSmessage) -> IO ()
apnsWorker config requestChan = do
        ctx        <- recoverAll (apnsRetrySettings config) $ connectAPNS config -- retry to connect to APNS server
        errorChan  <- newChan -- new Error Channel.
        lock       <- newMVar ()
        
        s          <- async (catch $ sender 1 lock requestChan errorChan ctx)
        r          <- async (catch $ receiver ctx)
        res        <- waitEither s r

        case res of
            Left  _ -> do
                            cancel r
                            writeChan errorChan 0
            Right v -> do
                            takeMVar lock
                            cancel s
                            writeChan errorChan v -- v is an int representing: 
                                        -- 0 -> internal worker error.
                                        -- n -> the identifier received in an error msg.
                                        --      This represent the last message that was successfully sent.
        CE.catch (contextClose ctx) (\(e :: CE.SomeException) -> return ())
        apnsWorker config requestChan -- restarts.

        where
            catch :: IO Int -> IO Int
            catch m = CE.catch m (\(e :: CE.SomeException) -> return 0)

            sender  :: Int32
                    -> MVar ()
                    -> TChan (MVar (Maybe (Chan Int,Int)) , APNSmessage)
                    -> Chan Int
                    -> Context
                    -> IO Int
            sender n lock requestChan errorChan c = 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 lock

                    (var,msg)   <- atomically $ readTChan requestChan

                    let list = HS.toList $ deviceTokens msg
                        len  = convert $ HS.size $ deviceTokens msg     -- len is the number of messages it will send.
                        num  = if (n + len :: Int32) < 0 then 1 else n -- to avoid overflow.
                    echan       <- dupChan errorChan
                    putMVar var $ Just (echan,convert num) -- Here, notifies that it is attending this request,
                                                           -- and provides a duplicated error channel.
                    putMVar lock ()

                    ctime       <- getPOSIXTime
                    loop var c num (createPut msg ctime) list -- sends the messages.
                    sender (num+len) lock requestChan errorChan c

            receiver :: Context -> IO Int
            receiver c = do
                    dat <- recvData c
                    case runGet (getWord16be >> getWord32be) dat of -- COMMAND and STATUS | ID |
                        Right ident -> return (convert ident)
                        Left _      -> return 0

            loop :: MVar (Maybe (Chan Int,Int)) 
                -> Context 
                -> Int32 -- This number is the identifier of this message, so if the sending fails,
                         -- I will receive this identifier in an error message.
                -> (DeviceToken -> Int32 -> Put)
                -> [DeviceToken]
                -> IO Bool
            loop var _   _   _    []     = tryPutMVar var Nothing
            loop var ctx num cput (x:xs) = do
                    sendData ctx $ LB.fromChunks [ (runPut $ cput x num) ]
                    loop var ctx (num+1) cput xs


-- 'createPut' builds the binary block to be sent.
createPut :: APNSmessage -> NominalDiffTime -> DeviceToken -> Int32 -> Put
createPut msg ctime dst identifier = do
   let
       -- We convert the text to binary, and then decode the hexadecimal representation.
       btoken     = fst $ B16.decode $ encodeUtf8 dst 
       bpayload   = AE.encode msg
       expiryTime = case expiry msg of
                      Nothing ->  round (ctime + posixDayLength) -- One day for default.
                      Just t  ->  round (utcTimeToPOSIXSeconds t)
   if (LB.length bpayload > 256)
      then fail "Too long payload"
      else do -- COMMAND|ID|EXPIRY|TOKENLEN|TOKEN|PAYLOADLEN|PAYLOAD|
            putWord8 1
            putWord32be $ convert identifier
            putWord32be expiryTime
            putWord16be $ convert $ B.length btoken
            putByteString btoken
            putWord16be $ convert $ LB.length bpayload
            putLazyByteString bpayload

-- | 'withAPNS' creates a new manager, uses it in the provided function, and then releases it.
withAPNS :: APNSConfig -> (APNSManager -> IO a) -> IO a
withAPNS confg fun = CE.bracket (startAPNS confg) closeAPNS fun

-- 'connectFeedBackAPNS' starts a secure connection with Feedback service.
connectFeedBackAPNS :: APNSConfig -> IO Context
connectFeedBackAPNS config = do
        handle  <- case environment config of
                    Development -> connectTo cDEVELOPMENT_FEEDBACK_URL
                                           $ PortNumber $ fromInteger cDEVELOPMENT_FEEDBACK_PORT
                    Production  -> connectTo cPRODUCTION_FEEDBACK_URL
                                           $ PortNumber $ fromInteger cPRODUCTION_FEEDBACK_PORT
                    Local       -> connectTo cLOCAL_FEEDBACK_URL
                                           $ PortNumber $ fromInteger cLOCAL_FEEDBACK_PORT
        rng     <- RNG.makeSystem
        ctx     <- contextNewOnHandle handle (connParams (apnsCertificate config) (apnsPrivateKey config)) rng
        handshake ctx
        return ctx

-- | 'feedBackAPNS' connects to the Feedback service.
feedBackAPNS :: APNSConfig -> IO APNSFeedBackresult
feedBackAPNS config = do
        ctx     <- connectFeedBackAPNS config
        var     <- newEmptyMVar

        tID     <- forkIO $ loopReceive var ctx -- To receive.

        res     <- waitAndCheck var HM.empty
        killThread tID
        bye ctx
        contextClose ctx
        return res

        where
            getData :: Get (DeviceToken,UTCTime)
            getData = do -- TIMESTAMP|TOKENLEN|TOKEN|
                        time    <- getWord32be
                        length  <- getWord16be
                        dtoken  <- getBytes $ convert length
                        return (    decodeUtf8 $ B16.encode dtoken
                               ,    posixSecondsToUTCTime $ fromInteger $ convert time )

            loopReceive :: MVar (DeviceToken,UTCTime) -> Context -> IO ()
            loopReceive var ctx = do
                        dat <- recvData ctx
                        case runGet getData dat of
                            Right tuple -> do
                                                putMVar var tuple
                                                loopReceive var ctx
                            Left _      -> return ()

            waitAndCheck :: MVar (DeviceToken,UTCTime) -> HM.HashMap DeviceToken UTCTime -> IO APNSFeedBackresult
            waitAndCheck var hmap = do
                        v <- timeout (timeoutLimit config) $ takeMVar var
                        case v of
                            Nothing -> return $ APNSFeedBackresult hmap
                            Just (d,t)  -> waitAndCheck var (HM.insert d t hmap)