{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Network.PushNotify.APN
( newSession
, newMessage
, newMessageWithCustomPayload
, hexEncodedToken
, rawToken
, sendMessage
, sendSilentMessage
, sendRawMessage
, alertMessage
, bodyMessage
, emptyMessage
, setAlertMessage
, setMessageBody
, setBadge
, setCategory
, setSound
, clearAlertMessage
, clearBadge
, clearCategory
, clearSound
, addSupplementalField
, closeSession
, isOpen
, ApnSession
, JsonAps
, JsonApsAlert
, JsonApsMessage
, ApnMessageResult(..)
, ApnFatalError(..)
, ApnTemporaryError(..)
, ApnToken
) where
import Control.Concurrent
import Control.Concurrent.QSem
import Control.Exception.Lifted (Exception, try, bracket_, throw, throwIO)
import Control.Monad
import Control.Monad.Except
import Data.Aeson
import Data.Aeson.Types
import Data.ByteString (ByteString)
import Data.Char (toLower)
import Data.Default (def)
import Data.Either
import Data.Int
import Data.IORef
import Data.Map.Strict (Map)
import Data.Maybe
import Data.Pool
import Data.Semigroup ((<>))
import Data.Text (Text)
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Typeable (Typeable)
import Data.X509
import Data.X509.CertificateStore
import GHC.Generics
import Network.HTTP2 (ErrorCodeId,
toErrorCodeId)
import "http2-client" Network.HTTP2.Client
import "http2-client" Network.HTTP2.Client.FrameConnection
import "http2-client" Network.HTTP2.Client.Helpers
import Network.TLS hiding (sendData)
import Network.TLS.Extra.Cipher
import System.IO.Error
import System.Mem.Weak
import System.Random
import qualified Data.ByteString as S
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as L
import qualified Data.List as DL
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HPACK as HTTP2
import qualified Network.HTTP2 as HTTP2
data ApnSession = ApnSession
{ ApnSession -> Pool ApnConnection
apnSessionPool :: !(Pool ApnConnection)
, ApnSession -> IORef Bool
apnSessionOpen :: !(IORef Bool)
}
data ApnConnectionInfo = ApnConnectionInfo
{ ApnConnectionInfo -> FilePath
aciCertPath :: !FilePath
, ApnConnectionInfo -> FilePath
aciCertKey :: !FilePath
, ApnConnectionInfo -> FilePath
aciCaPath :: !FilePath
, ApnConnectionInfo -> Text
aciHostname :: !Text
, ApnConnectionInfo -> Int
aciMaxConcurrentStreams :: !Int
, ApnConnectionInfo -> ByteString
aciTopic :: !ByteString }
data ApnConnection = ApnConnection
{ ApnConnection -> Http2Client
apnConnectionConnection :: !Http2Client
, ApnConnection -> ApnConnectionInfo
apnConnectionInfo :: !ApnConnectionInfo
, ApnConnection -> QSem
apnConnectionWorkerPool :: !QSem
, ApnConnection -> ThreadId
apnConnectionFlowControlWorker :: !ThreadId
, ApnConnection -> IORef Bool
apnConnectionOpen :: !(IORef Bool)}
newtype ApnToken = ApnToken { ApnToken -> ByteString
unApnToken :: ByteString }
class SpecifyError a where
isAnError :: IOError -> a
rawToken
:: ByteString
-> ApnToken
rawToken :: ByteString -> ApnToken
rawToken = ByteString -> ApnToken
ApnToken (ByteString -> ApnToken)
-> (ByteString -> ByteString) -> ByteString -> ApnToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode
hexEncodedToken
:: Text
-> ApnToken
hexEncodedToken :: Text -> ApnToken
hexEncodedToken = ByteString -> ApnToken
ApnToken (ByteString -> ApnToken)
-> (Text -> ByteString) -> Text -> ApnToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.encode (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B16.decodeLenient (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8
data ApnException = ApnExceptionHTTP ErrorCodeId
| ApnExceptionJSON String
| HTTP2.HeaderName
| ApnExceptionUnexpectedResponse
deriving (Int -> ApnException -> ShowS
[ApnException] -> ShowS
ApnException -> FilePath
(Int -> ApnException -> ShowS)
-> (ApnException -> FilePath)
-> ([ApnException] -> ShowS)
-> Show ApnException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ApnException] -> ShowS
$cshowList :: [ApnException] -> ShowS
show :: ApnException -> FilePath
$cshow :: ApnException -> FilePath
showsPrec :: Int -> ApnException -> ShowS
$cshowsPrec :: Int -> ApnException -> ShowS
Show, Typeable)
instance Exception ApnException
data ApnMessageResult = ApnMessageResultOk
| ApnMessageResultBackoff
| ApnMessageResultFatalError ApnFatalError
| ApnMessageResultTemporaryError ApnTemporaryError
| ApnMessageResultIOError IOError
| ApnMessageResultClientError ClientError
deriving (ApnMessageResult -> ApnMessageResult -> Bool
(ApnMessageResult -> ApnMessageResult -> Bool)
-> (ApnMessageResult -> ApnMessageResult -> Bool)
-> Eq ApnMessageResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApnMessageResult -> ApnMessageResult -> Bool
$c/= :: ApnMessageResult -> ApnMessageResult -> Bool
== :: ApnMessageResult -> ApnMessageResult -> Bool
$c== :: ApnMessageResult -> ApnMessageResult -> Bool
Eq, Int -> ApnMessageResult -> ShowS
[ApnMessageResult] -> ShowS
ApnMessageResult -> FilePath
(Int -> ApnMessageResult -> ShowS)
-> (ApnMessageResult -> FilePath)
-> ([ApnMessageResult] -> ShowS)
-> Show ApnMessageResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ApnMessageResult] -> ShowS
$cshowList :: [ApnMessageResult] -> ShowS
show :: ApnMessageResult -> FilePath
$cshow :: ApnMessageResult -> FilePath
showsPrec :: Int -> ApnMessageResult -> ShowS
$cshowsPrec :: Int -> ApnMessageResult -> ShowS
Show)
data JsonApsAlert = JsonApsAlert
{ JsonApsAlert -> Maybe Text
jaaTitle :: !(Maybe Text)
, JsonApsAlert -> Text
jaaBody :: !Text
} deriving ((forall x. JsonApsAlert -> Rep JsonApsAlert x)
-> (forall x. Rep JsonApsAlert x -> JsonApsAlert)
-> Generic JsonApsAlert
forall x. Rep JsonApsAlert x -> JsonApsAlert
forall x. JsonApsAlert -> Rep JsonApsAlert x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JsonApsAlert x -> JsonApsAlert
$cfrom :: forall x. JsonApsAlert -> Rep JsonApsAlert x
Generic, Int -> JsonApsAlert -> ShowS
[JsonApsAlert] -> ShowS
JsonApsAlert -> FilePath
(Int -> JsonApsAlert -> ShowS)
-> (JsonApsAlert -> FilePath)
-> ([JsonApsAlert] -> ShowS)
-> Show JsonApsAlert
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [JsonApsAlert] -> ShowS
$cshowList :: [JsonApsAlert] -> ShowS
show :: JsonApsAlert -> FilePath
$cshow :: JsonApsAlert -> FilePath
showsPrec :: Int -> JsonApsAlert -> ShowS
$cshowsPrec :: Int -> JsonApsAlert -> ShowS
Show)
instance ToJSON JsonApsAlert where
toJSON :: JsonApsAlert -> Value
toJSON = Options -> JsonApsAlert -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
{ fieldLabelModifier :: ShowS
fieldLabelModifier = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower
, omitNothingFields :: Bool
omitNothingFields = Bool
True
}
data JsonApsMessage
= JsonApsMessage
{ JsonApsMessage -> Maybe JsonApsAlert
jamAlert :: !(Maybe JsonApsAlert)
, JsonApsMessage -> Maybe Int
jamBadge :: !(Maybe Int)
, JsonApsMessage -> Maybe Text
jamSound :: !(Maybe Text)
, JsonApsMessage -> Maybe Text
jamCategory :: !(Maybe Text)
} deriving ((forall x. JsonApsMessage -> Rep JsonApsMessage x)
-> (forall x. Rep JsonApsMessage x -> JsonApsMessage)
-> Generic JsonApsMessage
forall x. Rep JsonApsMessage x -> JsonApsMessage
forall x. JsonApsMessage -> Rep JsonApsMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JsonApsMessage x -> JsonApsMessage
$cfrom :: forall x. JsonApsMessage -> Rep JsonApsMessage x
Generic, Int -> JsonApsMessage -> ShowS
[JsonApsMessage] -> ShowS
JsonApsMessage -> FilePath
(Int -> JsonApsMessage -> ShowS)
-> (JsonApsMessage -> FilePath)
-> ([JsonApsMessage] -> ShowS)
-> Show JsonApsMessage
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [JsonApsMessage] -> ShowS
$cshowList :: [JsonApsMessage] -> ShowS
show :: JsonApsMessage -> FilePath
$cshow :: JsonApsMessage -> FilePath
showsPrec :: Int -> JsonApsMessage -> ShowS
$cshowsPrec :: Int -> JsonApsMessage -> ShowS
Show)
emptyMessage :: JsonApsMessage
emptyMessage :: JsonApsMessage
emptyMessage = Maybe JsonApsAlert
-> Maybe Int -> Maybe Text -> Maybe Text -> JsonApsMessage
JsonApsMessage Maybe JsonApsAlert
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
setSound
:: Text
-> JsonApsMessage
-> JsonApsMessage
setSound :: Text -> JsonApsMessage -> JsonApsMessage
setSound Text
s JsonApsMessage
a = JsonApsMessage
a { jamSound :: Maybe Text
jamSound = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s }
clearSound
:: JsonApsMessage
-> JsonApsMessage
clearSound :: JsonApsMessage -> JsonApsMessage
clearSound JsonApsMessage
a = JsonApsMessage
a { jamSound :: Maybe Text
jamSound = Maybe Text
forall a. Maybe a
Nothing }
setCategory
:: Text
-> JsonApsMessage
-> JsonApsMessage
setCategory :: Text -> JsonApsMessage -> JsonApsMessage
setCategory Text
c JsonApsMessage
a = JsonApsMessage
a { jamCategory :: Maybe Text
jamCategory = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
c }
clearCategory
:: JsonApsMessage
-> JsonApsMessage
clearCategory :: JsonApsMessage -> JsonApsMessage
clearCategory JsonApsMessage
a = JsonApsMessage
a { jamCategory :: Maybe Text
jamCategory = Maybe Text
forall a. Maybe a
Nothing }
setBadge
:: Int
-> JsonApsMessage
-> JsonApsMessage
setBadge :: Int -> JsonApsMessage -> JsonApsMessage
setBadge Int
i JsonApsMessage
a = JsonApsMessage
a { jamBadge :: Maybe Int
jamBadge = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i }
clearBadge
:: JsonApsMessage
-> JsonApsMessage
clearBadge :: JsonApsMessage -> JsonApsMessage
clearBadge JsonApsMessage
a = JsonApsMessage
a { jamBadge :: Maybe Int
jamBadge = Maybe Int
forall a. Maybe a
Nothing }
alertMessage
:: Text
-> Text
-> JsonApsMessage
alertMessage :: Text -> Text -> JsonApsMessage
alertMessage Text
title Text
text = Text -> Text -> JsonApsMessage -> JsonApsMessage
setAlertMessage Text
title Text
text JsonApsMessage
emptyMessage
bodyMessage
:: Text
-> JsonApsMessage
bodyMessage :: Text -> JsonApsMessage
bodyMessage Text
text = Text -> JsonApsMessage -> JsonApsMessage
setMessageBody Text
text JsonApsMessage
emptyMessage
setAlertMessage
:: Text
-> Text
-> JsonApsMessage
-> JsonApsMessage
setAlertMessage :: Text -> Text -> JsonApsMessage -> JsonApsMessage
setAlertMessage Text
title Text
text JsonApsMessage
a = JsonApsMessage
a { jamAlert :: Maybe JsonApsAlert
jamAlert = JsonApsAlert -> Maybe JsonApsAlert
forall a. a -> Maybe a
Just JsonApsAlert
jam }
where
jam :: JsonApsAlert
jam = Maybe Text -> Text -> JsonApsAlert
JsonApsAlert (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
title) Text
text
setMessageBody
:: Text
-> JsonApsMessage
-> JsonApsMessage
setMessageBody :: Text -> JsonApsMessage -> JsonApsMessage
setMessageBody Text
text JsonApsMessage
a = JsonApsMessage
a { jamAlert :: Maybe JsonApsAlert
jamAlert = JsonApsAlert -> Maybe JsonApsAlert
forall a. a -> Maybe a
Just JsonApsAlert
newJaa }
where
newJaa :: JsonApsAlert
newJaa = case JsonApsMessage -> Maybe JsonApsAlert
jamAlert JsonApsMessage
a of
Maybe JsonApsAlert
Nothing -> Maybe Text -> Text -> JsonApsAlert
JsonApsAlert Maybe Text
forall a. Maybe a
Nothing Text
text
Just JsonApsAlert
jaa -> JsonApsAlert
jaa { jaaBody :: Text
jaaBody = Text
text }
clearAlertMessage
:: JsonApsMessage
-> JsonApsMessage
clearAlertMessage :: JsonApsMessage -> JsonApsMessage
clearAlertMessage JsonApsMessage
a = JsonApsMessage
a { jamAlert :: Maybe JsonApsAlert
jamAlert = Maybe JsonApsAlert
forall a. Maybe a
Nothing }
instance ToJSON JsonApsMessage where
toJSON :: JsonApsMessage -> Value
toJSON = Options -> JsonApsMessage -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions
{ fieldLabelModifier :: ShowS
fieldLabelModifier = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
3 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower }
data JsonAps
= JsonAps
{ JsonAps -> JsonApsMessage
jaAps :: !JsonApsMessage
, JsonAps -> Maybe Text
jaAppSpecificContent :: !(Maybe Text)
, JsonAps -> Map Text Value
jaSupplementalFields :: !(Map Text Value)
} deriving ((forall x. JsonAps -> Rep JsonAps x)
-> (forall x. Rep JsonAps x -> JsonAps) -> Generic JsonAps
forall x. Rep JsonAps x -> JsonAps
forall x. JsonAps -> Rep JsonAps x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JsonAps x -> JsonAps
$cfrom :: forall x. JsonAps -> Rep JsonAps x
Generic, Int -> JsonAps -> ShowS
[JsonAps] -> ShowS
JsonAps -> FilePath
(Int -> JsonAps -> ShowS)
-> (JsonAps -> FilePath) -> ([JsonAps] -> ShowS) -> Show JsonAps
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [JsonAps] -> ShowS
$cshowList :: [JsonAps] -> ShowS
show :: JsonAps -> FilePath
$cshow :: JsonAps -> FilePath
showsPrec :: Int -> JsonAps -> ShowS
$cshowsPrec :: Int -> JsonAps -> ShowS
Show)
instance ToJSON JsonAps where
toJSON :: JsonAps -> Value
toJSON JsonAps{Maybe Text
Map Text Value
JsonApsMessage
jaSupplementalFields :: Map Text Value
jaAppSpecificContent :: Maybe Text
jaAps :: JsonApsMessage
jaSupplementalFields :: JsonAps -> Map Text Value
jaAppSpecificContent :: JsonAps -> Maybe Text
jaAps :: JsonAps -> JsonApsMessage
..} = [Pair] -> Value
object ([Pair]
staticFields [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dynamicFields)
where
dynamicFields :: [Pair]
dynamicFields = Map Text Value -> [Pair]
forall k a. Map k a -> [(k, a)]
M.toList Map Text Value
jaSupplementalFields
staticFields :: [Pair]
staticFields = [ Text
"aps" Text -> JsonApsMessage -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= JsonApsMessage
jaAps
, Text
"appspecificcontent" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Maybe Text
jaAppSpecificContent
]
newMessage
:: JsonApsMessage
-> JsonAps
newMessage :: JsonApsMessage -> JsonAps
newMessage JsonApsMessage
aps = JsonApsMessage -> Maybe Text -> Map Text Value -> JsonAps
JsonAps JsonApsMessage
aps Maybe Text
forall a. Maybe a
Nothing Map Text Value
forall k a. Map k a
M.empty
newMessageWithCustomPayload
:: JsonApsMessage
-> Text
-> JsonAps
newMessageWithCustomPayload :: JsonApsMessage -> Text -> JsonAps
newMessageWithCustomPayload JsonApsMessage
message Text
payload =
JsonApsMessage -> Maybe Text -> Map Text Value -> JsonAps
JsonAps JsonApsMessage
message (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
payload) Map Text Value
forall k a. Map k a
M.empty
addSupplementalField :: ToJSON record =>
Text
-> record
-> JsonAps
-> JsonAps
addSupplementalField :: Text -> record -> JsonAps -> JsonAps
addSupplementalField Text
"aps" record
_ JsonAps
_ = FilePath -> JsonAps
forall a. HasCallStack => FilePath -> a
error FilePath
"The 'aps' field may not be overwritten by user code"
addSupplementalField Text
fieldName record
fieldValue JsonAps
oldAPN = JsonAps
oldAPN { jaSupplementalFields :: Map Text Value
jaSupplementalFields = Map Text Value
newSupplemental }
where
oldSupplemental :: Map Text Value
oldSupplemental = JsonAps -> Map Text Value
jaSupplementalFields JsonAps
oldAPN
newSupplemental :: Map Text Value
newSupplemental = Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
fieldName (record -> Value
forall a. ToJSON a => a -> Value
toJSON record
fieldValue) Map Text Value
oldSupplemental
newSession
:: FilePath
-> FilePath
-> FilePath
-> Bool
-> Int
-> Int
-> ByteString
-> IO ApnSession
newSession :: FilePath
-> FilePath
-> FilePath
-> Bool
-> Int
-> Int
-> ByteString
-> IO ApnSession
newSession FilePath
certKey FilePath
certPath FilePath
caPath Bool
dev Int
maxparallel Int
maxConnectionCount ByteString
topic = do
let hostname :: Text
hostname = if Bool
dev
then Text
"api.development.push.apple.com"
else Text
"api.push.apple.com"
connInfo :: ApnConnectionInfo
connInfo = FilePath
-> FilePath
-> FilePath
-> Text
-> Int
-> ByteString
-> ApnConnectionInfo
ApnConnectionInfo FilePath
certPath FilePath
certKey FilePath
caPath Text
hostname Int
maxparallel ByteString
topic
Bool
certsOk <- ApnConnectionInfo -> IO Bool
checkCertificates ApnConnectionInfo
connInfo
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
certsOk (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Unable to load certificates and/or the private key"
IORef Bool
isOpen <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
let connectionUnusedTimeout :: NominalDiffTime
connectionUnusedTimeout :: NominalDiffTime
connectionUnusedTimeout = NominalDiffTime
600
Pool ApnConnection
pool <-
IO ApnConnection
-> (ApnConnection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool ApnConnection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool
(ApnConnectionInfo -> IO ApnConnection
newConnection ApnConnectionInfo
connInfo) ApnConnection -> IO ()
closeApnConnection Int
1 NominalDiffTime
connectionUnusedTimeout Int
maxConnectionCount
let session :: ApnSession
session =
ApnSession :: Pool ApnConnection -> IORef Bool -> ApnSession
ApnSession
{ apnSessionPool :: Pool ApnConnection
apnSessionPool = Pool ApnConnection
pool
, apnSessionOpen :: IORef Bool
apnSessionOpen = IORef Bool
isOpen
}
ApnSession -> IO () -> IO ()
forall key. key -> IO () -> IO ()
addFinalizer ApnSession
session (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
ApnSession -> IO ()
closeSession ApnSession
session
ApnSession -> IO ApnSession
forall (m :: * -> *) a. Monad m => a -> m a
return ApnSession
session
closeSession :: ApnSession -> IO ()
closeSession :: ApnSession -> IO ()
closeSession ApnSession
s = do
Bool
isOpen <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' (ApnSession -> IORef Bool
apnSessionOpen ApnSession
s) (Bool
False,)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isOpen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Session is already closed"
Pool ApnConnection -> IO ()
forall a. Pool a -> IO ()
destroyAllResources (ApnSession -> Pool ApnConnection
apnSessionPool ApnSession
s)
isOpen :: ApnSession -> IO Bool
isOpen :: ApnSession -> IO Bool
isOpen = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool)
-> (ApnSession -> IORef Bool) -> ApnSession -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApnSession -> IORef Bool
apnSessionOpen
withConnection :: ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection :: ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection ApnSession
s ApnConnection -> ClientIO a
action = do
IO () -> ExceptT ClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ ApnSession -> IO ()
ensureOpen ApnSession
s
IO (Either ClientError a) -> ClientIO a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ClientError a) -> ClientIO a)
-> (IO a -> IO (Either ClientError a)) -> IO a -> ClientIO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either ClientError a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (IO a -> ClientIO a) -> IO a -> ClientIO a
forall a b. (a -> b) -> a -> b
$
Pool ApnConnection -> (ApnConnection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource (ApnSession -> Pool ApnConnection
apnSessionPool ApnSession
s) ((ApnConnection -> IO a) -> IO a)
-> (ApnConnection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ApnConnection
conn -> do
Either ClientError a
res <- ClientIO a -> IO (Either ClientError a)
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO (ApnConnection -> ClientIO a
action ApnConnection
conn)
case Either ClientError a
res of
Left ClientError
clientError ->
ClientError -> IO a
forall a e. Exception e => e -> a
throw ClientError
clientError
Right a
res -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
checkCertificates :: ApnConnectionInfo -> IO Bool
checkCertificates :: ApnConnectionInfo -> IO Bool
checkCertificates ApnConnectionInfo
aci = do
Maybe CertificateStore
castore <- FilePath -> IO (Maybe CertificateStore)
readCertificateStore (FilePath -> IO (Maybe CertificateStore))
-> FilePath -> IO (Maybe CertificateStore)
forall a b. (a -> b) -> a -> b
$ ApnConnectionInfo -> FilePath
aciCaPath ApnConnectionInfo
aci
Either FilePath Credential
credential <- FilePath -> FilePath -> IO (Either FilePath Credential)
credentialLoadX509 (ApnConnectionInfo -> FilePath
aciCertPath ApnConnectionInfo
aci) (ApnConnectionInfo -> FilePath
aciCertKey ApnConnectionInfo
aci)
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe CertificateStore -> Bool
forall a. Maybe a -> Bool
isJust Maybe CertificateStore
castore Bool -> Bool -> Bool
&& Either FilePath Credential -> Bool
forall a b. Either a b -> Bool
isRight Either FilePath Credential
credential
newConnection :: ApnConnectionInfo -> IO ApnConnection
newConnection :: ApnConnectionInfo -> IO ApnConnection
newConnection ApnConnectionInfo
aci = do
Just CertificateStore
castore <- FilePath -> IO (Maybe CertificateStore)
readCertificateStore (FilePath -> IO (Maybe CertificateStore))
-> FilePath -> IO (Maybe CertificateStore)
forall a b. (a -> b) -> a -> b
$ ApnConnectionInfo -> FilePath
aciCaPath ApnConnectionInfo
aci
Right Credential
credential <- FilePath -> FilePath -> IO (Either FilePath Credential)
credentialLoadX509 (ApnConnectionInfo -> FilePath
aciCertPath ApnConnectionInfo
aci) (ApnConnectionInfo -> FilePath
aciCertKey ApnConnectionInfo
aci)
let credentials :: Credentials
credentials = [Credential] -> Credentials
Credentials [Credential
credential]
shared :: Shared
shared = Shared
forall a. Default a => a
def { sharedCredentials :: Credentials
sharedCredentials = Credentials
credentials
, sharedCAStore :: CertificateStore
sharedCAStore=CertificateStore
castore }
maxConcurrentStreams :: Int
maxConcurrentStreams = ApnConnectionInfo -> Int
aciMaxConcurrentStreams ApnConnectionInfo
aci
clip :: ClientParams
clip = ClientParams :: Maybe MaxFragmentEnum
-> (FilePath, ByteString)
-> Bool
-> Maybe (ByteString, SessionData)
-> Shared
-> ClientHooks
-> Supported
-> DebugParams
-> Maybe ByteString
-> ClientParams
ClientParams
{ clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientUseMaxFragmentLength=Maybe MaxFragmentEnum
forall a. Maybe a
Nothing
, clientServerIdentification :: (FilePath, ByteString)
clientServerIdentification=(Text -> FilePath
T.unpack Text
hostname, ByteString
forall a. HasCallStack => a
undefined)
, clientUseServerNameIndication :: Bool
clientUseServerNameIndication=Bool
True
, clientWantSessionResume :: Maybe (ByteString, SessionData)
clientWantSessionResume=Maybe (ByteString, SessionData)
forall a. Maybe a
Nothing
, clientShared :: Shared
clientShared=Shared
shared
, clientHooks :: ClientHooks
clientHooks=ClientHooks
forall a. Default a => a
def
{ onCertificateRequest :: OnCertificateRequest
onCertificateRequest=IO (Maybe Credential) -> OnCertificateRequest
forall a b. a -> b -> a
const (IO (Maybe Credential) -> OnCertificateRequest)
-> (Credential -> IO (Maybe Credential))
-> Credential
-> OnCertificateRequest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Credential -> IO (Maybe Credential)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> (Credential -> Maybe Credential)
-> Credential
-> IO (Maybe Credential)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Credential -> Maybe Credential
forall a. a -> Maybe a
Just (Credential -> OnCertificateRequest)
-> Credential -> OnCertificateRequest
forall a b. (a -> b) -> a -> b
$ Credential
credential }
, clientDebug :: DebugParams
clientDebug=DebugParams :: Maybe Seed
-> (Seed -> IO ())
-> Maybe Version
-> (FilePath -> IO ())
-> DebugParams
DebugParams { debugSeed :: Maybe Seed
debugSeed=Maybe Seed
forall a. Maybe a
Nothing, debugPrintSeed :: Seed -> IO ()
debugPrintSeed=IO () -> Seed -> IO ()
forall a b. a -> b -> a
const (IO () -> Seed -> IO ()) -> IO () -> Seed -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
, clientSupported :: Supported
clientSupported=Supported
forall a. Default a => a
def
{ supportedVersions :: [Version]
supportedVersions=[ Version
TLS12 ]
, supportedCiphers :: [Cipher]
supportedCiphers=[Cipher]
ciphersuite_strong }
}
conf :: [(SettingsKeyId, Int)]
conf = [ (SettingsKeyId
HTTP2.SettingsMaxFrameSize, Int
16384)
, (SettingsKeyId
HTTP2.SettingsMaxConcurrentStreams, Int
maxConcurrentStreams)
, (SettingsKeyId
HTTP2.SettingsMaxHeaderBlockSize, Int
4096)
, (SettingsKeyId
HTTP2.SettingsInitialWindowSize, Int
65536)
, (SettingsKeyId
HTTP2.SettingsEnablePush, Int
1)
]
hostname :: Text
hostname = ApnConnectionInfo -> Text
aciHostname ApnConnectionInfo
aci
IORef Bool
isOpen <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
let handleGoAway :: p -> t IO ()
handleGoAway p
rsgaf = do
IO () -> t IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> t IO ()) -> IO () -> t IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isOpen Bool
False
() -> t IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Http2Client
client <-
(Either ClientError Http2Client -> Http2Client)
-> IO (Either ClientError Http2Client) -> IO Http2Client
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ClientError -> Http2Client)
-> (Http2Client -> Http2Client)
-> Either ClientError Http2Client
-> Http2Client
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> Http2Client
forall a e. Exception e => e -> a
throw Http2Client -> Http2Client
forall a. a -> a
id) (IO (Either ClientError Http2Client) -> IO Http2Client)
-> (ClientIO Http2Client -> IO (Either ClientError Http2Client))
-> ClientIO Http2Client
-> IO Http2Client
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIO Http2Client -> IO (Either ClientError Http2Client)
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO (ClientIO Http2Client -> IO Http2Client)
-> ClientIO Http2Client -> IO Http2Client
forall a b. (a -> b) -> a -> b
$ do
Http2FrameConnection
httpFrameConnection <- FilePath
-> PortNumber
-> Maybe ClientParams
-> ClientIO Http2FrameConnection
newHttp2FrameConnection (Text -> FilePath
T.unpack Text
hostname) PortNumber
443 (ClientParams -> Maybe ClientParams
forall a. a -> Maybe a
Just ClientParams
clip)
Http2Client
client <-
Http2FrameConnection
-> Int
-> Int
-> [(SettingsKeyId, Int)]
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO Http2Client
newHttp2Client Http2FrameConnection
httpFrameConnection Int
4096 Int
4096 [(SettingsKeyId, Int)]
conf GoAwayHandler
forall (t :: (* -> *) -> * -> *) p.
(Monad (t IO), MonadTrans t) =>
p -> t IO ()
handleGoAway FallBackFrameHandler
ignoreFallbackHandler
Http2Client -> ExceptT ClientError IO ()
linkAsyncs Http2Client
client
Http2Client -> ClientIO Http2Client
forall (m :: * -> *) a. Monad m => a -> m a
return Http2Client
client
ThreadId
flowWorker <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either ClientError Bool
updated <- ClientIO Bool -> IO (Either ClientError Bool)
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO (ClientIO Bool -> IO (Either ClientError Bool))
-> ClientIO Bool -> IO (Either ClientError Bool)
forall a b. (a -> b) -> a -> b
$ IncomingFlowControl -> ClientIO Bool
_updateWindow (IncomingFlowControl -> ClientIO Bool)
-> IncomingFlowControl -> ClientIO Bool
forall a b. (a -> b) -> a -> b
$ Http2Client -> IncomingFlowControl
_incomingFlowControl Http2Client
client
Int -> IO ()
threadDelay Int
1000000
QSem
workersem <- Int -> IO QSem
newQSem Int
maxConcurrentStreams
ApnConnection -> IO ApnConnection
forall (m :: * -> *) a. Monad m => a -> m a
return (ApnConnection -> IO ApnConnection)
-> ApnConnection -> IO ApnConnection
forall a b. (a -> b) -> a -> b
$ Http2Client
-> ApnConnectionInfo
-> QSem
-> ThreadId
-> IORef Bool
-> ApnConnection
ApnConnection Http2Client
client ApnConnectionInfo
aci QSem
workersem ThreadId
flowWorker IORef Bool
isOpen
closeApnConnection :: ApnConnection -> IO ()
closeApnConnection :: ApnConnection -> IO ()
closeApnConnection ApnConnection
connection =
IO (Either ClientError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either ClientError ()) -> IO ())
-> IO (Either ClientError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT ClientError IO () -> IO (Either ClientError ())
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO (ExceptT ClientError IO () -> IO (Either ClientError ()))
-> ExceptT ClientError IO () -> IO (Either ClientError ())
forall a b. (a -> b) -> a -> b
$ do
IO () -> ExceptT ClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ApnConnection -> IORef Bool
apnConnectionOpen ApnConnection
connection) Bool
False
let flowWorker :: ThreadId
flowWorker = ApnConnection -> ThreadId
apnConnectionFlowControlWorker ApnConnection
connection
IO () -> ExceptT ClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
flowWorker
Http2Client
-> ErrorCodeId -> ByteString -> ExceptT ClientError IO ()
_gtfo (ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection) ErrorCodeId
HTTP2.NoError ByteString
""
Http2Client -> ExceptT ClientError IO ()
_close (ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection)
sendRawMessage
:: ApnSession
-> ApnToken
-> ByteString
-> IO ApnMessageResult
sendRawMessage :: ApnSession -> ApnToken -> ByteString -> IO ApnMessageResult
sendRawMessage ApnSession
s ApnToken
token ByteString
payload = ClientIO ApnMessageResult -> IO ApnMessageResult
catchErrors (ClientIO ApnMessageResult -> IO ApnMessageResult)
-> ClientIO ApnMessageResult -> IO ApnMessageResult
forall a b. (a -> b) -> a -> b
$
ApnSession
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a. ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection ApnSession
s ((ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult)
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ \ApnConnection
c ->
ApnConnection
-> ApnToken -> ByteString -> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
token ByteString
payload
sendMessage
:: ApnSession
-> ApnToken
-> JsonAps
-> IO ApnMessageResult
sendMessage :: ApnSession -> ApnToken -> JsonAps -> IO ApnMessageResult
sendMessage ApnSession
s ApnToken
token JsonAps
payload = ClientIO ApnMessageResult -> IO ApnMessageResult
catchErrors (ClientIO ApnMessageResult -> IO ApnMessageResult)
-> ClientIO ApnMessageResult -> IO ApnMessageResult
forall a b. (a -> b) -> a -> b
$
ApnSession
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a. ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection ApnSession
s ((ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult)
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ \ApnConnection
c ->
ApnConnection
-> ApnToken -> ByteString -> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
token ByteString
message
where message :: ByteString
message = ByteString -> ByteString
L.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ JsonAps -> ByteString
forall a. ToJSON a => a -> ByteString
encode JsonAps
payload
sendSilentMessage
:: ApnSession
-> ApnToken
-> IO ApnMessageResult
sendSilentMessage :: ApnSession -> ApnToken -> IO ApnMessageResult
sendSilentMessage ApnSession
s ApnToken
token = ClientIO ApnMessageResult -> IO ApnMessageResult
catchErrors (ClientIO ApnMessageResult -> IO ApnMessageResult)
-> ClientIO ApnMessageResult -> IO ApnMessageResult
forall a b. (a -> b) -> a -> b
$
ApnSession
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a. ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection ApnSession
s ((ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult)
-> (ApnConnection -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ \ApnConnection
c ->
ApnConnection
-> ApnToken -> ByteString -> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
token ByteString
message
where message :: ByteString
message = ByteString
"{\"aps\":{\"content-available\":1}}"
ensureOpen :: ApnSession -> IO ()
ensureOpen :: ApnSession -> IO ()
ensureOpen ApnSession
s = do
Bool
open <- ApnSession -> IO Bool
isOpen ApnSession
s
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
open (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"Session is closed"
sendApnRaw
:: ApnConnection
-> ApnToken
-> ByteString
-> ClientIO ApnMessageResult
sendApnRaw :: ApnConnection
-> ApnToken -> ByteString -> ClientIO ApnMessageResult
sendApnRaw ApnConnection
connection ApnToken
token ByteString
message = ExceptT ClientError IO ()
-> ExceptT ClientError IO ()
-> ClientIO ApnMessageResult
-> ClientIO ApnMessageResult
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_
(IO () -> ExceptT ClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
waitQSem (ApnConnection -> QSem
apnConnectionWorkerPool ApnConnection
connection))
(IO () -> ExceptT ClientError IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT ClientError IO ())
-> IO () -> ExceptT ClientError IO ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
signalQSem (ApnConnection -> QSem
apnConnectionWorkerPool ApnConnection
connection)) (ClientIO ApnMessageResult -> ClientIO ApnMessageResult)
-> ClientIO ApnMessageResult -> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ do
let requestHeaders :: [(ByteString, ByteString)]
requestHeaders = [ ( ByteString
":method", ByteString
"POST" )
, ( ByteString
":scheme", ByteString
"https" )
, ( ByteString
":authority", Text -> ByteString
TE.encodeUtf8 Text
hostname )
, ( ByteString
":path", ByteString
"/3/device/" ByteString -> ByteString -> ByteString
`S.append` ByteString
token1 )
, ( ByteString
"apns-topic", ByteString
topic ) ]
aci :: ApnConnectionInfo
aci = ApnConnection -> ApnConnectionInfo
apnConnectionInfo ApnConnection
connection
hostname :: Text
hostname = ApnConnectionInfo -> Text
aciHostname ApnConnectionInfo
aci
topic :: ByteString
topic = ApnConnectionInfo -> ByteString
aciTopic ApnConnectionInfo
aci
client :: Http2Client
client = ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection
token1 :: ByteString
token1 = ApnToken -> ByteString
unApnToken ApnToken
token
Either TooMuchConcurrency ApnMessageResult
res <- Http2Client -> forall a. StreamStarter a
_startStream Http2Client
client StreamStarter ApnMessageResult -> StreamStarter ApnMessageResult
forall a b. (a -> b) -> a -> b
$ \Http2Stream
stream ->
let init :: ClientIO StreamThread
init = Http2Stream
-> [(ByteString, ByteString)]
-> FlagSetter
-> ClientIO StreamThread
headers Http2Stream
stream [(ByteString, ByteString)]
requestHeaders FlagSetter
forall a. a -> a
id
handler :: IncomingFlowControl
-> OutgoingFlowControl -> ClientIO ApnMessageResult
handler IncomingFlowControl
isfc OutgoingFlowControl
osfc = do
ByteString
-> FlagSetter
-> Http2Client
-> OutgoingFlowControl
-> Http2Stream
-> OutgoingFlowControl
-> ExceptT ClientError IO ()
upload ByteString
message (FlagSetter
HTTP2.setEndHeader FlagSetter -> FlagSetter -> FlagSetter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSetter
HTTP2.setEndStream) Http2Client
client (Http2Client -> OutgoingFlowControl
_outgoingFlowControl Http2Client
client) Http2Stream
stream OutgoingFlowControl
osfc
let pph :: p -> p -> a -> p -> p -> t IO ()
pph p
hStreamId p
hStream a
hHeaders p
hIfc p
hOfc =
IO () -> t IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> t IO ()) -> IO () -> t IO ()
forall a b. (a -> b) -> a -> b
$ a -> IO ()
forall a. Show a => a -> IO ()
print a
hHeaders
StreamResult
response <- Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream Http2Stream
stream IncomingFlowControl
isfc PushPromiseHandler
forall (t :: (* -> *) -> * -> *) a p p p p.
(MonadTrans t, Show a) =>
p -> p -> a -> p -> p -> t IO ()
pph
let (Either ErrorCode [(ByteString, ByteString)]
errOrHeaders, [Either ErrorCode ByteString]
frameResponses, Maybe [(ByteString, ByteString)]
_) = StreamResult
response
case Either ErrorCode [(ByteString, ByteString)]
errOrHeaders of
Left ErrorCode
err -> ApnException -> ClientIO ApnMessageResult
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (ErrorCodeId -> ApnException
ApnExceptionHTTP (ErrorCodeId -> ApnException) -> ErrorCodeId -> ApnException
forall a b. (a -> b) -> a -> b
$ ErrorCode -> ErrorCodeId
toErrorCodeId ErrorCode
err)
Right [(ByteString, ByteString)]
hdrs1 -> do
let status :: ByteString
status = ByteString -> [(ByteString, ByteString)] -> ByteString
getHeaderEx ByteString
":status" [(ByteString, ByteString)]
hdrs1
[Right ByteString
body] = [Either ErrorCode ByteString]
frameResponses
ApnMessageResult -> ClientIO ApnMessageResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ApnMessageResult -> ClientIO ApnMessageResult)
-> ApnMessageResult -> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ case ByteString
status of
ByteString
"200" -> ApnMessageResult
ApnMessageResultOk
ByteString
"400" -> (ApnFatalError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError ByteString
body
ByteString
"403" -> (ApnFatalError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError ByteString
body
ByteString
"405" -> (ApnFatalError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError ByteString
body
ByteString
"410" -> (ApnFatalError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError ByteString
body
ByteString
"413" -> (ApnFatalError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError ByteString
body
ByteString
"429" -> (ApnTemporaryError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError ByteString
body
ByteString
"500" -> (ApnTemporaryError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError ByteString
body
ByteString
"503" -> (ApnTemporaryError -> ApnMessageResult)
-> ByteString -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError ByteString
body
in ClientIO StreamThread
-> (IncomingFlowControl
-> OutgoingFlowControl -> ClientIO ApnMessageResult)
-> StreamDefinition ApnMessageResult
forall a.
ClientIO StreamThread
-> (IncomingFlowControl -> OutgoingFlowControl -> ClientIO a)
-> StreamDefinition a
StreamDefinition ClientIO StreamThread
init IncomingFlowControl
-> OutgoingFlowControl -> ClientIO ApnMessageResult
handler
case Either TooMuchConcurrency ApnMessageResult
res of
Left TooMuchConcurrency
_ -> ApnMessageResult -> ClientIO ApnMessageResult
forall (m :: * -> *) a. Monad m => a -> m a
return ApnMessageResult
ApnMessageResultBackoff
Right ApnMessageResult
res1 -> ApnMessageResult -> ClientIO ApnMessageResult
forall (m :: * -> *) a. Monad m => a -> m a
return ApnMessageResult
res1
where
decodeReason :: FromJSON response => (response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason :: (response -> ApnMessageResult) -> ByteString -> ApnMessageResult
decodeReason response -> ApnMessageResult
ctor = (FilePath -> ApnMessageResult)
-> (ApnMessageResult -> ApnMessageResult)
-> Either FilePath ApnMessageResult
-> ApnMessageResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ApnException -> ApnMessageResult
forall a e. Exception e => e -> a
throw (ApnException -> ApnMessageResult)
-> (FilePath -> ApnException) -> FilePath -> ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ApnException
ApnExceptionJSON) ApnMessageResult -> ApnMessageResult
forall a. a -> a
id (Either FilePath ApnMessageResult -> ApnMessageResult)
-> (ByteString -> Either FilePath ApnMessageResult)
-> ByteString
-> ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either FilePath ApnMessageResult
decodeBody (ByteString -> Either FilePath ApnMessageResult)
-> (ByteString -> ByteString)
-> ByteString
-> Either FilePath ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict
where
decodeBody :: ByteString -> Either FilePath ApnMessageResult
decodeBody ByteString
body =
ByteString -> Either FilePath Object
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode ByteString
body
Either FilePath Object
-> (Object -> Either FilePath ApnMessageResult)
-> Either FilePath ApnMessageResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Parser ApnMessageResult)
-> Object -> Either FilePath ApnMessageResult
forall a b. (a -> Parser b) -> a -> Either FilePath b
parseEither (\Object
obj -> response -> ApnMessageResult
ctor (response -> ApnMessageResult)
-> Parser response -> Parser ApnMessageResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Text -> Parser response
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"reason")
getHeaderEx :: HTTP2.HeaderName -> [HTTP2.Header] -> HTTP2.HeaderValue
getHeaderEx :: ByteString -> [(ByteString, ByteString)] -> ByteString
getHeaderEx ByteString
name [(ByteString, ByteString)]
headers = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe (ApnException -> ByteString
forall a e. Exception e => e -> a
throw (ApnException -> ByteString) -> ApnException -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ApnException
ApnExceptionMissingHeader ByteString
name) (ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
DL.lookup ByteString
name [(ByteString, ByteString)]
headers)
catchErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult
catchErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult
catchErrors = IO ApnMessageResult -> IO ApnMessageResult
catchIOErrors (IO ApnMessageResult -> IO ApnMessageResult)
-> (ClientIO ApnMessageResult -> IO ApnMessageResult)
-> ClientIO ApnMessageResult
-> IO ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientIO ApnMessageResult -> IO ApnMessageResult
catchClientErrors
where
catchIOErrors :: IO ApnMessageResult -> IO ApnMessageResult
catchIOErrors :: IO ApnMessageResult -> IO ApnMessageResult
catchIOErrors = (IO ApnMessageResult
-> (IOError -> IO ApnMessageResult) -> IO ApnMessageResult)
-> (IOError -> IO ApnMessageResult)
-> IO ApnMessageResult
-> IO ApnMessageResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO ApnMessageResult
-> (IOError -> IO ApnMessageResult) -> IO ApnMessageResult
forall a. IO a -> (IOError -> IO a) -> IO a
catchIOError (ApnMessageResult -> IO ApnMessageResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ApnMessageResult -> IO ApnMessageResult)
-> (IOError -> ApnMessageResult) -> IOError -> IO ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> ApnMessageResult
ApnMessageResultIOError)
catchClientErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult
catchClientErrors :: ClientIO ApnMessageResult -> IO ApnMessageResult
catchClientErrors ClientIO ApnMessageResult
act =
(ClientError -> ApnMessageResult)
-> (ApnMessageResult -> ApnMessageResult)
-> Either ClientError ApnMessageResult
-> ApnMessageResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ClientError -> ApnMessageResult
ApnMessageResultClientError ApnMessageResult -> ApnMessageResult
forall a. a -> a
id (Either ClientError ApnMessageResult -> ApnMessageResult)
-> IO (Either ClientError ApnMessageResult) -> IO ApnMessageResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientIO ApnMessageResult
-> IO (Either ClientError ApnMessageResult)
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO ClientIO ApnMessageResult
act
data ApnFatalError = ApnFatalErrorBadCollapseId
| ApnFatalErrorBadDeviceToken
| ApnFatalErrorBadExpirationDate
| ApnFatalErrorBadMessageId
| ApnFatalErrorBadPriority
| ApnFatalErrorBadTopic
| ApnFatalErrorDeviceTokenNotForTopic
|
| ApnFatalErrorIdleTimeout
| ApnFatalErrorMissingDeviceToken
| ApnFatalErrorMissingTopic
| ApnFatalErrorPayloadEmpty
| ApnFatalErrorTopicDisallowed
| ApnFatalErrorBadCertificate
| ApnFatalErrorBadCertificateEnvironment
| ApnFatalErrorExpiredProviderToken
| ApnFatalErrorForbidden
| ApnFatalErrorInvalidProviderToken
| ApnFatalErrorMissingProviderToken
| ApnFatalErrorBadPath
| ApnFatalErrorMethodNotAllowed
| ApnFatalErrorUnregistered
| ApnFatalErrorPayloadTooLarge
| ApnFatalErrorOther Text
deriving (ApnFatalError -> ApnFatalError -> Bool
(ApnFatalError -> ApnFatalError -> Bool)
-> (ApnFatalError -> ApnFatalError -> Bool) -> Eq ApnFatalError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApnFatalError -> ApnFatalError -> Bool
$c/= :: ApnFatalError -> ApnFatalError -> Bool
== :: ApnFatalError -> ApnFatalError -> Bool
$c== :: ApnFatalError -> ApnFatalError -> Bool
Eq, Int -> ApnFatalError -> ShowS
[ApnFatalError] -> ShowS
ApnFatalError -> FilePath
(Int -> ApnFatalError -> ShowS)
-> (ApnFatalError -> FilePath)
-> ([ApnFatalError] -> ShowS)
-> Show ApnFatalError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ApnFatalError] -> ShowS
$cshowList :: [ApnFatalError] -> ShowS
show :: ApnFatalError -> FilePath
$cshow :: ApnFatalError -> FilePath
showsPrec :: Int -> ApnFatalError -> ShowS
$cshowsPrec :: Int -> ApnFatalError -> ShowS
Show, (forall x. ApnFatalError -> Rep ApnFatalError x)
-> (forall x. Rep ApnFatalError x -> ApnFatalError)
-> Generic ApnFatalError
forall x. Rep ApnFatalError x -> ApnFatalError
forall x. ApnFatalError -> Rep ApnFatalError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApnFatalError x -> ApnFatalError
$cfrom :: forall x. ApnFatalError -> Rep ApnFatalError x
Generic)
instance FromJSON ApnFatalError where
parseJSON :: Value -> Parser ApnFatalError
parseJSON Value
json =
let result :: Result ApnFatalError
result = (Value -> Parser ApnFatalError) -> Value -> Result ApnFatalError
forall a b. (a -> Parser b) -> a -> Result b
parse Value -> Parser ApnFatalError
genericParser Value
json
in
case Result ApnFatalError
result of
Success ApnFatalError
success -> ApnFatalError -> Parser ApnFatalError
forall (m :: * -> *) a. Monad m => a -> m a
return ApnFatalError
success
Error FilePath
err -> case Value
json of
String Text
other -> ApnFatalError -> Parser ApnFatalError
forall (m :: * -> *) a. Monad m => a -> m a
return (ApnFatalError -> Parser ApnFatalError)
-> ApnFatalError -> Parser ApnFatalError
forall a b. (a -> b) -> a -> b
$ Text -> ApnFatalError
ApnFatalErrorOther Text
other
Value
_ -> FilePath -> Parser ApnFatalError
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
err
where
genericParser :: Value -> Parser ApnFatalError
genericParser = Options -> Value -> Parser ApnFatalError
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions {
constructorTagModifier :: ShowS
constructorTagModifier = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
13,
sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue
}
data ApnTemporaryError = ApnTemporaryErrorTooManyProviderTokenUpdates
| ApnTemporaryErrorTooManyRequests
| ApnTemporaryErrorInternalServerError
| ApnTemporaryErrorServiceUnavailable
| ApnTemporaryErrorShutdown
deriving (Int -> ApnTemporaryError
ApnTemporaryError -> Int
ApnTemporaryError -> [ApnTemporaryError]
ApnTemporaryError -> ApnTemporaryError
ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
(ApnTemporaryError -> ApnTemporaryError)
-> (ApnTemporaryError -> ApnTemporaryError)
-> (Int -> ApnTemporaryError)
-> (ApnTemporaryError -> Int)
-> (ApnTemporaryError -> [ApnTemporaryError])
-> (ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError])
-> (ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError])
-> (ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError])
-> Enum ApnTemporaryError
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
$cenumFromThenTo :: ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFromTo :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
$cenumFromTo :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFromThen :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
$cenumFromThen :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFrom :: ApnTemporaryError -> [ApnTemporaryError]
$cenumFrom :: ApnTemporaryError -> [ApnTemporaryError]
fromEnum :: ApnTemporaryError -> Int
$cfromEnum :: ApnTemporaryError -> Int
toEnum :: Int -> ApnTemporaryError
$ctoEnum :: Int -> ApnTemporaryError
pred :: ApnTemporaryError -> ApnTemporaryError
$cpred :: ApnTemporaryError -> ApnTemporaryError
succ :: ApnTemporaryError -> ApnTemporaryError
$csucc :: ApnTemporaryError -> ApnTemporaryError
Enum, ApnTemporaryError -> ApnTemporaryError -> Bool
(ApnTemporaryError -> ApnTemporaryError -> Bool)
-> (ApnTemporaryError -> ApnTemporaryError -> Bool)
-> Eq ApnTemporaryError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApnTemporaryError -> ApnTemporaryError -> Bool
$c/= :: ApnTemporaryError -> ApnTemporaryError -> Bool
== :: ApnTemporaryError -> ApnTemporaryError -> Bool
$c== :: ApnTemporaryError -> ApnTemporaryError -> Bool
Eq, Int -> ApnTemporaryError -> ShowS
[ApnTemporaryError] -> ShowS
ApnTemporaryError -> FilePath
(Int -> ApnTemporaryError -> ShowS)
-> (ApnTemporaryError -> FilePath)
-> ([ApnTemporaryError] -> ShowS)
-> Show ApnTemporaryError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ApnTemporaryError] -> ShowS
$cshowList :: [ApnTemporaryError] -> ShowS
show :: ApnTemporaryError -> FilePath
$cshow :: ApnTemporaryError -> FilePath
showsPrec :: Int -> ApnTemporaryError -> ShowS
$cshowsPrec :: Int -> ApnTemporaryError -> ShowS
Show, (forall x. ApnTemporaryError -> Rep ApnTemporaryError x)
-> (forall x. Rep ApnTemporaryError x -> ApnTemporaryError)
-> Generic ApnTemporaryError
forall x. Rep ApnTemporaryError x -> ApnTemporaryError
forall x. ApnTemporaryError -> Rep ApnTemporaryError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApnTemporaryError x -> ApnTemporaryError
$cfrom :: forall x. ApnTemporaryError -> Rep ApnTemporaryError x
Generic)
instance FromJSON ApnTemporaryError where
parseJSON :: Value -> Parser ApnTemporaryError
parseJSON = Options -> Value -> Parser ApnTemporaryError
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions { constructorTagModifier :: ShowS
constructorTagModifier = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
17 }