module Network.PushNotify.Mpns.Send (sendMPNS,newManagerMPNS) where
import Network.PushNotify.Mpns.Constants
import Network.PushNotify.Mpns.Types
import Data.Functor
import Data.String
import Data.Conduit (($$+-))
import Data.List
import Data.Text (Text, pack, unpack, empty)
import Data.Text.Encoding (decodeUtf8)
import Data.Certificate.X509 (X509)
import Text.XML
import qualified Control.Exception as CE
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Control.Concurrent.Async
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource,runResourceT)
import Control.Retry
import Network.Connection (TLSSettings(..))
import Network.HTTP.Types
import Network.HTTP.Client (defaultManagerSettings)
import Network.HTTP.Conduit
import Network.TLS
import Network.TLS.Extra (ciphersuite_all)
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)]
}
}
newManagerMPNS :: MPNSConfig -> IO Manager
newManagerMPNS cnfg = case useSecure cnfg of
False -> newManager defaultManagerSettings
True -> do
let sett = mkManagerSettings (TLSSettings $ connParams (mpnsCertificate cnfg) (mpnsPrivatekey cnfg)) Nothing
newManager sett
retrySettingsMPNS = RetrySettings {
backoff = True
, baseDelay = 100
, numRetries = limitedRetries 1
}
sendMPNS :: Manager -> MPNSConfig -> MPNSmessage -> IO MPNSresult
sendMPNS manager cnfg msg = do
let uriList = HS.toList $ deviceURIs msg
asyncs <- mapM (async . send manager cnfg msg) uriList
results <- mapM waitCatch asyncs
let list = zip uriList results
(r,l) = partition (isRight . snd) list
return $ MPNSresult{
successfullResults = HM.map (\(Right y) -> y) $ HM.fromList r
, errorException = HM.map (\(Left e) -> e) $ HM.fromList l
}
where
isRight (Right _) = True
isRight (Left _) = False
send :: Manager -> MPNSConfig -> MPNSmessage -> DeviceURI -> IO MPNSinfo
send manager cnfg msg deviceUri = runResourceT $ do
req' <- liftIO $ case useSecure cnfg of
False -> parseUrl $ unpack deviceUri
True -> do
r <- (parseUrl $ unpack deviceUri)
return r{ secure = True }
let valueBS = renderLBS def $ restXML msg
interval = case target msg of
Tile -> 1
Toast -> 2
Raw -> 3
+ case batching_interval msg of
Immediate -> 0
Sec450 -> 10
Sec900 -> 20
req = req' {
method = "POST"
, requestBody = RequestBodyLBS valueBS
, requestHeaders = [
("Content-Type", "text/xml")
, (cNotificationClass, fromString $ show interval)
] ++ case target msg of
Tile -> [(cWindowsPhoneTarget, cToken)]
Toast -> [(cWindowsPhoneTarget, cToast)]
Raw -> []
}
info <- liftIO $ CE.catch (runResourceT $ retry req manager (numRet cnfg))
(\(StatusCodeException rStatus rHeaders c) -> case statusCode rStatus of
404 -> return $ handleSuccessfulResponse rHeaders
406 -> return $ handleSuccessfulResponse rHeaders
412 -> return $ handleSuccessfulResponse rHeaders
_ -> CE.throw $ StatusCodeException rStatus rHeaders c )
return info
retry :: (MonadBaseControl IO m,MonadResource m)
=> Request -> Manager -> Int -> m MPNSinfo
retry req manager numret = do
response <- retrying (retrySettingsMPNS{numRetries = limitedRetries numret}) ifRetry $ http req manager
responseBody response $$+- return ()
if ifRetry response
then CE.throw $ StatusCodeException (responseStatus response) (responseHeaders response) (responseCookieJar response)
else return $ handleSuccessfulResponse $ responseHeaders response
where
ifRetry x = (statusCode $ responseStatus x) >= 500
handleSuccessfulResponse :: ResponseHeaders -> MPNSinfo
handleSuccessfulResponse headers = MPNSinfo {
notificationStatus = (decodeUtf8 <$> lookup cNotificationStatus headers ) >>= case1
, subscriptionStatus = (decodeUtf8 <$> lookup cSubscriptionStatus headers ) >>= case2
, connectionStatus = (decodeUtf8 <$> lookup cDeviceConnectionStatus headers) >>= case3
}
case1 :: Text -> Maybe MPNSnotifStatus
case1 m | m== cNotifReceived = Just Received
| m== cNotifDropped = Just Dropped
| m== cNotifQueuefull = Just QueueFull
| m== cNotifSuppressed = Just Suppressed
| otherwise = Nothing
case2 :: Text -> Maybe MPNSsubStatus
case2 m | m== cSubActive = Just Active
| m== cSubExpired = Just Expired
| otherwise = Nothing
case3 :: Text -> Maybe MPNSconStatus
case3 m | m== cConnConnected = Just Connected
| m== cConnInactive = Just InActive
| m== cConnDisconnected = Just Disconnected
| m== cConnTempDisconn = Just TempDisconnected
| otherwise = Nothing