-- |
-- Module: APN
-- Copyright: (C) 2017, memrange UG
-- License: BSD3
-- Maintainer: Hans-Christian Esperer <hc@memrange.io>
-- Stability: experimental
-- Portability: portable
--
-- Send push notifications using Apple's HTTP2 APN API
{-# LANGUAGE CPP               #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports    #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE NumericUnderscores     #-}

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
    , isConnectionOpen
    , isSessionOpen
    , isOpen
    , ApnSession
    , JsonAps
    , JsonApsAlert
    , JsonApsMessage
    , ApnMessageResult(..)
    , ApnFatalError(..)
    , ApnTemporaryError(..)
    , ApnToken(..)
    ) where

import           Control.Concurrent
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.IORef
import           Data.Map.Strict                      (Map)
import           Data.Maybe
import           Data.Pool
import           Data.Text                            (Text)
import           Data.Time.Clock
import           Data.Typeable                        (Typeable)
import           Data.X509.CertificateStore
import           GHC.Generics
import           Network.HTTP2.Frame                  (ErrorCode)
import "http2-client" Network.HTTP2.Client
import "http2-client" Network.HTTP2.Client.Helpers
import           Network.TLS                          hiding (sendData)
import           Network.TLS.Extra.Cipher
import           System.IO.Error
import           System.Timeout (timeout)
import           System.X509

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.Frame                  as HTTP2

-- | A session that manages connections to Apple's push notification service
data ApnSession = ApnSession
    { ApnSession -> Pool ApnConnection
apnSessionPool :: !(Pool ApnConnection)
    , ApnSession -> IORef Bool
apnSessionOpen :: !(IORef Bool)
    }

-- | Information about an APN connection
data ApnConnectionInfo = ApnConnectionInfo
    { ApnConnectionInfo -> Maybe String
aciCertPath             :: !(Maybe FilePath)
    , ApnConnectionInfo -> Maybe String
aciCertKey              :: !(Maybe FilePath)
    , ApnConnectionInfo -> Maybe String
aciCaPath               :: !(Maybe FilePath)
    , ApnConnectionInfo -> Text
aciHostname             :: !Text
    , ApnConnectionInfo -> Int
aciMaxConcurrentStreams :: !Int
    , ApnConnectionInfo -> HeaderName
aciTopic                :: !ByteString
    , ApnConnectionInfo -> Bool
aciUseJWT               :: !Bool }

-- | A connection to an APN API server
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)}

-- | An APN token used to uniquely identify a device
newtype ApnToken = ApnToken { ApnToken -> HeaderName
unApnToken :: ByteString }

-- | Create a token from a raw bytestring
rawToken
    :: ByteString
    -- ^ The bytestring that uniquely identifies a device (APN token)
    -> ApnToken
    -- ^ The resulting token
rawToken :: HeaderName -> ApnToken
rawToken = HeaderName -> ApnToken
ApnToken (HeaderName -> ApnToken)
-> (HeaderName -> HeaderName) -> HeaderName -> ApnToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> HeaderName
B16.encode

-- | Create a token from a hex encoded text
hexEncodedToken
    :: Text
    -- ^ The base16 (hex) encoded unique identifier for a device (APN token)
    -> ApnToken
    -- ^ The resulting token
hexEncodedToken :: Text -> ApnToken
hexEncodedToken = HeaderName -> ApnToken
ApnToken (HeaderName -> ApnToken)
-> (Text -> HeaderName) -> Text -> ApnToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> HeaderName
B16.encode (HeaderName -> HeaderName)
-> (Text -> HeaderName) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> HeaderName
B16.decodeLenient (HeaderName -> HeaderName)
-> (Text -> HeaderName) -> Text -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HeaderName
TE.encodeUtf8

-- | Exceptional responses to a send request
data ApnException = ApnExceptionHTTP ErrorCode
                  | ApnExceptionJSON String
                  | ApnExceptionMissingHeader HTTP2.HeaderName
                  | ApnExceptionUnexpectedResponse
                  | ApnExceptionConnectionClosed
                  | ApnExceptionSessionClosed
    deriving (Int -> ApnException -> ShowS
[ApnException] -> ShowS
ApnException -> String
(Int -> ApnException -> ShowS)
-> (ApnException -> String)
-> ([ApnException] -> ShowS)
-> Show ApnException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApnException -> ShowS
showsPrec :: Int -> ApnException -> ShowS
$cshow :: ApnException -> String
show :: ApnException -> String
$cshowList :: [ApnException] -> ShowS
showList :: [ApnException] -> ShowS
Show, Typeable)

instance Exception ApnException

-- | The result of a send request
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
$c== :: ApnMessageResult -> ApnMessageResult -> Bool
== :: ApnMessageResult -> ApnMessageResult -> Bool
$c/= :: ApnMessageResult -> ApnMessageResult -> Bool
/= :: ApnMessageResult -> ApnMessageResult -> Bool
Eq, Int -> ApnMessageResult -> ShowS
[ApnMessageResult] -> ShowS
ApnMessageResult -> String
(Int -> ApnMessageResult -> ShowS)
-> (ApnMessageResult -> String)
-> ([ApnMessageResult] -> ShowS)
-> Show ApnMessageResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApnMessageResult -> ShowS
showsPrec :: Int -> ApnMessageResult -> ShowS
$cshow :: ApnMessageResult -> String
show :: ApnMessageResult -> String
$cshowList :: [ApnMessageResult] -> ShowS
showList :: [ApnMessageResult] -> ShowS
Show)

-- | The specification of a push notification's message body
data JsonApsAlert = JsonApsAlert
    { JsonApsAlert -> Maybe Text
jaaTitle :: !(Maybe Text)
    -- ^ A short string describing the purpose of the notification.
    , JsonApsAlert -> Text
jaaBody  :: !Text
    -- ^ The text of the alert message.
    } 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
$cfrom :: forall x. JsonApsAlert -> Rep JsonApsAlert x
from :: forall x. JsonApsAlert -> Rep JsonApsAlert x
$cto :: forall x. Rep JsonApsAlert x -> JsonApsAlert
to :: forall x. Rep JsonApsAlert x -> JsonApsAlert
Generic, Int -> JsonApsAlert -> ShowS
[JsonApsAlert] -> ShowS
JsonApsAlert -> String
(Int -> JsonApsAlert -> ShowS)
-> (JsonApsAlert -> String)
-> ([JsonApsAlert] -> ShowS)
-> Show JsonApsAlert
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonApsAlert -> ShowS
showsPrec :: Int -> JsonApsAlert -> ShowS
$cshow :: JsonApsAlert -> String
show :: JsonApsAlert -> String
$cshowList :: [JsonApsAlert] -> ShowS
showList :: [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 = drop 3 . map toLower
        , omitNothingFields  = True
        }

instance FromJSON JsonApsAlert where
    parseJSON :: Value -> Parser JsonApsAlert
parseJSON = Options -> Value -> Parser JsonApsAlert
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions
        { fieldLabelModifier = drop 3 . map toLower
        , omitNothingFields  = True
        }

-- | Push notification message's content
data JsonApsMessage
    -- | Push notification message's content
    = JsonApsMessage
    { JsonApsMessage -> Maybe JsonApsAlert
jamAlert    :: !(Maybe JsonApsAlert)
    -- ^ A text to display in the notification
    , JsonApsMessage -> Maybe Int
jamBadge    :: !(Maybe Int)
    -- ^ A number to display next to the app's icon. If set to (Just 0), the number is removed.
    , JsonApsMessage -> Maybe Text
jamSound    :: !(Maybe Text)
    -- ^ A sound to play, that's located in the Library/Sounds directory of the app
    -- This should be the name of a sound file in the application's main bundle, or
    -- in the Library/Sounds directory of the app.
    , JsonApsMessage -> Maybe Text
jamCategory :: !(Maybe Text)
    -- ^ The category of the notification. Must be registered by the app beforehand.
    } 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
$cfrom :: forall x. JsonApsMessage -> Rep JsonApsMessage x
from :: forall x. JsonApsMessage -> Rep JsonApsMessage x
$cto :: forall x. Rep JsonApsMessage x -> JsonApsMessage
to :: forall x. Rep JsonApsMessage x -> JsonApsMessage
Generic, Int -> JsonApsMessage -> ShowS
[JsonApsMessage] -> ShowS
JsonApsMessage -> String
(Int -> JsonApsMessage -> ShowS)
-> (JsonApsMessage -> String)
-> ([JsonApsMessage] -> ShowS)
-> Show JsonApsMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonApsMessage -> ShowS
showsPrec :: Int -> JsonApsMessage -> ShowS
$cshow :: JsonApsMessage -> String
show :: JsonApsMessage -> String
$cshowList :: [JsonApsMessage] -> ShowS
showList :: [JsonApsMessage] -> ShowS
Show)

-- | Create an empty apn message
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

-- | Set a sound for an APN message
setSound
    :: Text
    -- ^ The sound to use (either "default" or something in the application's bundle)
    -> JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
setSound :: Text -> JsonApsMessage -> JsonApsMessage
setSound Text
s JsonApsMessage
a = JsonApsMessage
a { jamSound = Just s }

-- | Clear the sound for an APN message
clearSound
    :: JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
clearSound :: JsonApsMessage -> JsonApsMessage
clearSound JsonApsMessage
a = JsonApsMessage
a { jamSound = Nothing }

-- | Set the category part of an APN message
setCategory
    :: Text
    -- ^ The category to set
    -> JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
setCategory :: Text -> JsonApsMessage -> JsonApsMessage
setCategory Text
c JsonApsMessage
a = JsonApsMessage
a { jamCategory = Just c }

-- | Clear the category part of an APN message
clearCategory
    :: JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
clearCategory :: JsonApsMessage -> JsonApsMessage
clearCategory JsonApsMessage
a = JsonApsMessage
a { jamCategory = Nothing }

-- | Set the badge part of an APN message
setBadge
    :: Int
    -- ^ The badge number to set. The badge number is displayed next to your app's icon. Set to 0 to remove the badge number.
    -> JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
setBadge :: Int -> JsonApsMessage -> JsonApsMessage
setBadge Int
i JsonApsMessage
a = JsonApsMessage
a { jamBadge = Just i }

-- | Clear the badge part of an APN message
clearBadge
    :: JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
clearBadge :: JsonApsMessage -> JsonApsMessage
clearBadge JsonApsMessage
a = JsonApsMessage
a { jamBadge = Nothing }

-- | Create a new APN message with an alert part
alertMessage
    :: Text
    -- ^ The title of the message
    -> Text
    -- ^ The body of the message
    -> JsonApsMessage
    -- ^ The modified message
alertMessage :: Text -> Text -> JsonApsMessage
alertMessage Text
title Text
text = Text -> Text -> JsonApsMessage -> JsonApsMessage
setAlertMessage Text
title Text
text JsonApsMessage
emptyMessage

-- | Create a new APN message with a body and no title
bodyMessage
    :: Text
    -- ^ The body of the message
    -> JsonApsMessage
    -- ^ The modified message
bodyMessage :: Text -> JsonApsMessage
bodyMessage Text
text = Text -> JsonApsMessage -> JsonApsMessage
setMessageBody Text
text JsonApsMessage
emptyMessage

-- | Set the alert part of an APN message
setAlertMessage
    :: Text
    -- ^ The title of the message
    -> Text
    -- ^ The body of the message
    -> JsonApsMessage
    -- ^ The message to alter
    -> JsonApsMessage
    -- ^ The modified message
setAlertMessage :: Text -> Text -> JsonApsMessage -> JsonApsMessage
setAlertMessage Text
title Text
text JsonApsMessage
a = JsonApsMessage
a { jamAlert = Just jam }
  where
    jam :: JsonApsAlert
jam = Maybe Text -> Text -> JsonApsAlert
JsonApsAlert (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
title) Text
text

-- | Set the body of an APN message without affecting the title
setMessageBody
    :: Text
    -- ^ The body of the message
    -> JsonApsMessage
    -- ^ The message to alter
    -> JsonApsMessage
    -- ^ The modified message
setMessageBody :: Text -> JsonApsMessage -> JsonApsMessage
setMessageBody Text
text JsonApsMessage
a = JsonApsMessage
a { jamAlert = Just 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 }

-- | Remove the alert part of an APN message
clearAlertMessage
    :: JsonApsMessage
    -- ^ The message to modify
    -> JsonApsMessage
    -- ^ The modified message
clearAlertMessage :: JsonApsMessage -> JsonApsMessage
clearAlertMessage JsonApsMessage
a = JsonApsMessage
a { jamAlert = 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 = drop 3 . map toLower }

instance FromJSON JsonApsMessage where
    parseJSON :: Value -> Parser JsonApsMessage
parseJSON = Options -> Value -> Parser JsonApsMessage
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
defaultOptions
        { fieldLabelModifier = drop 3 . map toLower }

-- | A push notification message
data JsonAps
    -- | A push notification message
    = JsonAps
    { JsonAps -> JsonApsMessage
jaAps                :: !JsonApsMessage
    -- ^ The main content of the message
    , JsonAps -> Maybe Text
jaAppSpecificContent :: !(Maybe Text)
    -- ^ Extra information to be used by the receiving app
    , JsonAps -> Map Text Value
jaSupplementalFields :: !(Map Text Value)
    -- ^ Additional fields to be used by the receiving app
    } 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
$cfrom :: forall x. JsonAps -> Rep JsonAps x
from :: forall x. JsonAps -> Rep JsonAps x
$cto :: forall x. Rep JsonAps x -> JsonAps
to :: forall x. Rep JsonAps x -> JsonAps
Generic, Int -> JsonAps -> ShowS
[JsonAps] -> ShowS
JsonAps -> String
(Int -> JsonAps -> ShowS)
-> (JsonAps -> String) -> ([JsonAps] -> ShowS) -> Show JsonAps
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JsonAps -> ShowS
showsPrec :: Int -> JsonAps -> ShowS
$cshow :: JsonAps -> String
show :: JsonAps -> String
$cshowList :: [JsonAps] -> ShowS
showList :: [JsonAps] -> ShowS
Show)

instance FromJSON JsonAps where
    parseJSON :: Value -> Parser JsonAps
parseJSON = String -> (Object -> Parser JsonAps) -> Value -> Parser JsonAps
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JsonAps" ((Object -> Parser JsonAps) -> Value -> Parser JsonAps)
-> (Object -> Parser JsonAps) -> Value -> Parser JsonAps
forall a b. (a -> b) -> a -> b
$ \Object
o ->
      JsonApsMessage -> Maybe Text -> Map Text Value -> JsonAps
JsonAps (JsonApsMessage -> Maybe Text -> Map Text Value -> JsonAps)
-> Parser JsonApsMessage
-> Parser (Maybe Text -> Map Text Value -> JsonAps)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser JsonApsMessage
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"aps"
        Parser (Maybe Text -> Map Text Value -> JsonAps)
-> Parser (Maybe Text) -> Parser (Map Text Value -> JsonAps)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"appspecificcontent"
        Parser (Map Text Value -> JsonAps)
-> Parser (Map Text Value) -> Parser JsonAps
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Map Text Value)
forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"data"

instance ToJSON JsonAps where
    toJSON :: JsonAps -> Value
toJSON JsonAps{Maybe Text
Map Text Value
JsonApsMessage
jaAps :: JsonAps -> JsonApsMessage
jaAppSpecificContent :: JsonAps -> Maybe Text
jaSupplementalFields :: JsonAps -> Map Text Value
jaAps :: JsonApsMessage
jaAppSpecificContent :: Maybe Text
jaSupplementalFields :: Map Text Value
..} = [Pair] -> Value
object ([Pair]
staticFields [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [Pair]
dynamicFields)
        where
            dynamicFields :: [Pair]
dynamicFields = [ Key
"data" Key -> Map Text Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map Text Value
jaSupplementalFields ]
            staticFields :: [Pair]
staticFields = [ Key
"aps" Key -> JsonApsMessage -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= JsonApsMessage
jaAps
                           , Key
"appspecificcontent" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
jaAppSpecificContent
                           ]

-- | Prepare a new apn message consisting of a
-- standard message without a custom payload
newMessage
    :: JsonApsMessage
    -- ^ The standard message to include
    -> JsonAps
    -- ^ The resulting APN message
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

-- | Prepare a new apn message consisting of a
-- standard message and a custom payload
newMessageWithCustomPayload
    :: JsonApsMessage
    -- ^ The message
    -> Text
    -- ^ The custom payload
    -> JsonAps
    -- ^ The resulting APN message
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

-- | Add a supplemental field to be sent over with the notification
--
-- NB: The field 'aps' must not be modified; attempting to do so will
-- cause a crash.
addSupplementalField :: ToJSON record =>
       Text
    -- ^ The field name
    -> record
    -- ^ The value
    -> JsonAps
    -- ^ The APN message to modify
    -> JsonAps
    -- ^ The resulting APN message
addSupplementalField :: forall record.
ToJSON record =>
Text -> record -> JsonAps -> JsonAps
addSupplementalField Text
"aps"     record
_          JsonAps
_      = String -> JsonAps
forall a. HasCallStack => String -> a
error String
"The 'aps' field may not be overwritten by user code"
addSupplementalField Text
fieldName record
fieldValue JsonAps
oldAPN = JsonAps
oldAPN { jaSupplementalFields = 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

-- | Start a new session for sending APN messages. A session consists of a
-- connection pool of connections to the APN servers, while each connection has a
-- pool of workers that create HTTP2 streams to send individual push
-- notifications.
newSession
    :: Maybe FilePath
    -- ^ Path to the client certificate key
    -> Maybe FilePath
    -- ^ Path to the client certificate
    -> Maybe FilePath
    -- ^ Path to the CA
    -> Bool
    -- ^ Whether to use JWT as a bearer token
    -> Bool
    -- ^ True if the apn development servers should be used, False to use the production servers
    -> Int
    -- ^ How many messages will be sent in parallel? This corresponds to the number of http2 streams open in parallel; 100 seems to be a default value.
    -> Int
    -- ^ How many connections to be opened at maximum.
    -> ByteString
    -- ^ Topic (bundle name of the app)
    -> IO ApnSession
    -- ^ The newly created session
newSession :: Maybe String
-> Maybe String
-> Maybe String
-> Bool
-> Bool
-> Int
-> Int
-> HeaderName
-> IO ApnSession
newSession Maybe String
certKey Maybe String
certPath Maybe String
caPath Bool
useJwt Bool
dev Int
maxparallel Int
maxConnectionCount HeaderName
topic = do
    let hostname :: Text
hostname = if Bool
dev
            then Text
"api.sandbox.push.apple.com"
            else Text
"api.push.apple.com"
        connInfo :: ApnConnectionInfo
connInfo = Maybe String
-> Maybe String
-> Maybe String
-> Text
-> Int
-> HeaderName
-> Bool
-> ApnConnectionInfo
ApnConnectionInfo Maybe String
certPath Maybe String
certKey Maybe String
caPath Text
hostname Int
maxparallel HeaderName
topic Bool
useJwt
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
useJwt (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      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
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"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
300
    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
            { apnSessionPool :: Pool ApnConnection
apnSessionPool = Pool ApnConnection
pool
            , apnSessionOpen :: IORef Bool
apnSessionOpen = IORef Bool
isOpen
            }
    ApnSession -> IO ApnSession
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ApnSession
session

-- | Manually close a session. The session must not be used anymore
-- after it has been closed. Calling this function will close
-- the worker thread, and all open connections to the APN service
-- that belong to the given session. Note that sessions will be closed
-- automatically when they are garbage collected, so it is not necessary
-- to call this function.
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
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"Session is already closed"
    Pool ApnConnection -> IO ()
forall a. Pool a -> IO ()
destroyAllResources (ApnSession -> Pool ApnConnection
apnSessionPool ApnSession
s)

-- | Check whether a session is open or has been closed
-- by a call to closeSession
isSessionOpen :: ApnSession -> IO Bool
isSessionOpen :: ApnSession -> IO Bool
isSessionOpen = 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

-- | Check whether a session is open or has been closed
-- by a call to closeSession
{-# DEPRECATED isOpen "Use isSessionOpen instead." #-}
isOpen :: ApnSession -> IO Bool
isOpen :: ApnSession -> IO Bool
isOpen = ApnSession -> IO Bool
isSessionOpen

-- | Check whether the connection is open or has been closed.
isConnectionOpen :: ApnConnection -> IO Bool
isConnectionOpen :: ApnConnection -> IO Bool
isConnectionOpen = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef (IORef Bool -> IO Bool)
-> (ApnConnection -> IORef Bool) -> ApnConnection -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApnConnection -> IORef Bool
apnConnectionOpen

timeoutSeconds :: Int
timeoutSeconds :: Int
timeoutSeconds = Int
300 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000 -- 300 seconds to microseconds

withConnection :: ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection :: forall a. ApnSession -> (ApnConnection -> ClientIO a) -> ClientIO a
withConnection ApnSession
s ApnConnection -> ClientIO a
action = do
    IO () -> ExceptT ClientError IO ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
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 ()
ensureSessionOpen 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 a r. Pool a -> (a -> IO r) -> IO r
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
        ApnConnection -> IO ()
ensureConnectionOpen ApnConnection
conn
        Maybe (Either ClientError a)
mRes <- Int
-> IO (Either ClientError a) -> IO (Maybe (Either ClientError a))
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
timeoutSeconds (ClientIO a -> IO (Either ClientError a)
forall a. ClientIO a -> IO (Either ClientError a)
runClientIO (ApnConnection -> ClientIO a
action ApnConnection
conn))
        case Maybe (Either ClientError a)
mRes of
          Maybe (Either ClientError a)
Nothing -> do
            ClientError -> IO a
forall a e. Exception e => e -> a
throw ClientError
EarlyEndOfStream
          Just Either ClientError a
eRes -> do
            case Either ClientError a
eRes of
              Left ClientError
clientError ->
                  -- When there is a clientError, we think that the connetion is broken.
                  -- Throwing an exception is the way we inform the resource pool.
                  ClientError -> IO a
forall a e. Exception e => e -> a
throw ClientError
clientError
              Right a
res -> a -> IO a
forall a. 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
  case (ApnConnectionInfo -> Bool
aciUseJWT ApnConnectionInfo
aci) of
    Bool
True -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Bool
False -> do
      Maybe CertificateStore
castore <- IO (Maybe CertificateStore)
-> (String -> IO (Maybe CertificateStore))
-> Maybe String
-> IO (Maybe CertificateStore)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe CertificateStore -> IO (Maybe CertificateStore)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CertificateStore
forall a. Maybe a
Nothing) String -> IO (Maybe CertificateStore)
readCertificateStore (Maybe String -> IO (Maybe CertificateStore))
-> Maybe String -> IO (Maybe CertificateStore)
forall a b. (a -> b) -> a -> b
$ ApnConnectionInfo -> Maybe String
aciCaPath ApnConnectionInfo
aci
      Either String Credential
credential <- ApnConnectionInfo -> IO (Either String Credential)
loadCredentials ApnConnectionInfo
aci
      Bool -> IO Bool
forall a. a -> IO a
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 String Credential -> Bool
forall a b. Either a b -> Bool
isRight Either String Credential
credential

loadCredentials :: ApnConnectionInfo -> IO (Either String Credential)
loadCredentials :: ApnConnectionInfo -> IO (Either String Credential)
loadCredentials ApnConnectionInfo
aci =
    case (ApnConnectionInfo -> Maybe String
aciCertPath ApnConnectionInfo
aci, ApnConnectionInfo -> Maybe String
aciCertKey ApnConnectionInfo
aci) of
        (Just String
cert, Just String
key) -> String -> String -> IO (Either String Credential)
credentialLoadX509 String
cert String
key
        (Just String
_, Maybe String
Nothing) -> Either String Credential -> IO (Either String Credential)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Credential -> IO (Either String Credential))
-> Either String Credential -> IO (Either String Credential)
forall a b. (a -> b) -> a -> b
$ String -> Either String Credential
forall a b. a -> Either a b
Left String
"no cert"
        (Maybe String
Nothing, Just String
_) -> Either String Credential -> IO (Either String Credential)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Credential -> IO (Either String Credential))
-> Either String Credential -> IO (Either String Credential)
forall a b. (a -> b) -> a -> b
$ String -> Either String Credential
forall a b. a -> Either a b
Left String
"no key"
        (Maybe String
Nothing, Maybe String
Nothing) -> Either String Credential -> IO (Either String Credential)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Credential -> IO (Either String Credential))
-> Either String Credential -> IO (Either String Credential)
forall a b. (a -> b) -> a -> b
$ String -> Either String Credential
forall a b. a -> Either a b
Left String
"no creds"

newConnection :: ApnConnectionInfo -> IO ApnConnection
newConnection :: ApnConnectionInfo -> IO ApnConnection
newConnection ApnConnectionInfo
aci = do
    let maxConcurrentStreams :: Int
maxConcurrentStreams = ApnConnectionInfo -> Int
aciMaxConcurrentStreams ApnConnectionInfo
aci
        conf :: [(SettingsKey, Int)]
conf = [ (SettingsKey
HTTP2.SettingsMaxFrameSize, Int
16384)
               , (SettingsKey
HTTP2.SettingsMaxConcurrentStreams, Int
maxConcurrentStreams)
#if MIN_VERSION_http2(5,0,0)
               , (SettingsKey
HTTP2.SettingsMaxHeaderListSize, Int
4096)
#else
               , (HTTP2.SettingsMaxHeaderBlockSize, 4096)
#endif
               , (SettingsKey
HTTP2.SettingsInitialWindowSize, Int
65536)
               , (SettingsKey
HTTP2.SettingsEnablePush, Int
1)
               ]
        hostname :: Text
hostname = ApnConnectionInfo -> Text
aciHostname ApnConnectionInfo
aci

    ClientParams
clip <- case (ApnConnectionInfo -> Bool
aciUseJWT ApnConnectionInfo
aci) of
        Bool
True -> do
          CertificateStore
castore <- IO CertificateStore
getSystemCertificateStore
          let clip :: ClientParams
clip = ClientParams
                  { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientUseMaxFragmentLength=Maybe MaxFragmentEnum
forall a. Maybe a
Nothing
                  , clientServerIdentification :: (String, HeaderName)
clientServerIdentification=(Text -> String
T.unpack Text
hostname, HeaderName
forall a. HasCallStack => a
undefined)
                  , clientUseServerNameIndication :: Bool
clientUseServerNameIndication=Bool
True
                  , clientWantSessionResume :: Maybe (HeaderName, SessionData)
clientWantSessionResume=Maybe (HeaderName, SessionData)
forall a. Maybe a
Nothing
                  , clientShared :: Shared
clientShared=Shared
forall a. Default a => a
def
                      { sharedCAStore=castore }
                  , clientHooks :: ClientHooks
clientHooks=ClientHooks
forall a. Default a => a
def
                      { onCertificateRequest = const . return $ Nothing }
                  , clientDebug :: DebugParams
clientDebug=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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (), debugVersionForced :: Maybe Version
debugVersionForced=Maybe Version
forall a. Maybe a
Nothing, debugKeyLogger :: String -> IO ()
debugKeyLogger=IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
                  , clientSupported :: Supported
clientSupported=Supported
forall a. Default a => a
def
                      { supportedVersions=[ TLS12 ]
                      , supportedCiphers=ciphersuite_strong }
#if MIN_VERSION_tls(2, 0, 0)
                  , clientUseEarlyData :: Bool
clientUseEarlyData=Bool
False
#else
                  , clientEarlyData=Nothing
#endif
                  }
          ClientParams -> IO ClientParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientParams
clip
        Bool
False -> do
          Just CertificateStore
castore <- IO (Maybe CertificateStore)
-> (String -> IO (Maybe CertificateStore))
-> Maybe String
-> IO (Maybe CertificateStore)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe CertificateStore -> IO (Maybe CertificateStore)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe CertificateStore
forall a. Maybe a
Nothing) String -> IO (Maybe CertificateStore)
readCertificateStore (Maybe String -> IO (Maybe CertificateStore))
-> Maybe String -> IO (Maybe CertificateStore)
forall a b. (a -> b) -> a -> b
$ ApnConnectionInfo -> Maybe String
aciCaPath ApnConnectionInfo
aci
          Right Credential
credential <- ApnConnectionInfo -> IO (Either String Credential)
loadCredentials ApnConnectionInfo
aci
          let credentials :: Credentials
credentials = [Credential] -> Credentials
Credentials [Credential
credential]
              shared :: Shared
shared      = Shared
forall a. Default a => a
def { sharedCredentials = credentials
                                , sharedCAStore=castore }

              clip :: ClientParams
clip = ClientParams
                  { clientUseMaxFragmentLength :: Maybe MaxFragmentEnum
clientUseMaxFragmentLength=Maybe MaxFragmentEnum
forall a. Maybe a
Nothing
                  , clientServerIdentification :: (String, HeaderName)
clientServerIdentification=(Text -> String
T.unpack Text
hostname, HeaderName
forall a. HasCallStack => a
undefined)
                  , clientUseServerNameIndication :: Bool
clientUseServerNameIndication=Bool
True
                  , clientWantSessionResume :: Maybe (HeaderName, SessionData)
clientWantSessionResume=Maybe (HeaderName, SessionData)
forall a. Maybe a
Nothing
                  , clientShared :: Shared
clientShared=Shared
shared
                  , clientHooks :: ClientHooks
clientHooks=ClientHooks
forall a. Default a => a
def
                      { onCertificateRequest=const . return . Just $ credential }
                  , clientDebug :: DebugParams
clientDebug=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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (), debugVersionForced :: Maybe Version
debugVersionForced=Maybe Version
forall a. Maybe a
Nothing, debugKeyLogger :: String -> IO ()
debugKeyLogger=IO () -> String -> IO ()
forall a b. a -> b -> a
const (IO () -> String -> IO ()) -> IO () -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () }
                  , clientSupported :: Supported
clientSupported=Supported
forall a. Default a => a
def
                      { supportedVersions=[ TLS12 ]
                      , supportedCiphers=ciphersuite_strong }
#if MIN_VERSION_tls(2, 0, 0)
                  , clientUseEarlyData :: Bool
clientUseEarlyData=Bool
False
#else
                  , clientEarlyData=Nothing
#endif
                  }
          ClientParams -> IO ClientParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientParams
clip

    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 (m :: * -> *) a. Monad m => m a -> t m a
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 a. a -> t IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Http2Client
client <-
        (Either ClientError Http2Client -> Http2Client)
-> IO (Either ClientError Http2Client) -> IO Http2Client
forall a b. (a -> b) -> IO a -> IO b
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 <- String
-> PortNumber
-> Maybe ClientParams
-> ClientIO Http2FrameConnection
newHttp2FrameConnection (Text -> String
T.unpack Text
hostname) PortNumber
443 (ClientParams -> Maybe ClientParams
forall a. a -> Maybe a
Just ClientParams
clip)
        Http2Client
client <-
            Http2FrameConnection
-> Int
-> Int
-> [(SettingsKey, Int)]
-> GoAwayHandler
-> FallBackFrameHandler
-> ClientIO Http2Client
newHttp2Client Http2FrameConnection
httpFrameConnection Int
4096 Int
4096 [(SettingsKey, 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 a. a -> ExceptT ClientError IO a
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 a. a -> IO a
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 =
    -- Ignoring ClientErrors in this place. We want to close our session, so we do not need to
    -- fail on this kind of errors.
    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 (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
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 (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
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 -> ErrorCode -> HeaderName -> ExceptT ClientError IO ()
_gtfo (ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection) ErrorCode
HTTP2.NoError HeaderName
""
    Http2Client -> ExceptT ClientError IO ()
_close (ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection)


-- | Send a raw payload as a push notification message (advanced)
sendRawMessage
    :: ApnSession
    -- ^ Session to use
    -> ApnToken
    -- ^ Device to send the message to
    -> Maybe ByteString
    -- ^ JWT Bearer Token
    -> ByteString
    -- ^ The message to send
    -> IO ApnMessageResult
    -- ^ The response from the APN server
sendRawMessage :: ApnSession
-> ApnToken
-> Maybe HeaderName
-> HeaderName
-> IO ApnMessageResult
sendRawMessage ApnSession
s ApnToken
deviceToken Maybe HeaderName
mJwtToken HeaderName
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
-> Maybe HeaderName
-> HeaderName
-> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
deviceToken Maybe HeaderName
mJwtToken HeaderName
payload

-- | Send a push notification message.
sendMessage
    :: ApnSession
    -- ^ Session to use
    -> ApnToken
    -- ^ Device to send the message to
    -> Maybe ByteString
    -- ^ JWT Bearer Token
    -> JsonAps
    -- ^ The message to send
    -> IO ApnMessageResult
    -- ^ The response from the APN server
sendMessage :: ApnSession
-> ApnToken -> Maybe HeaderName -> JsonAps -> IO ApnMessageResult
sendMessage ApnSession
s ApnToken
token Maybe HeaderName
mJwt 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
-> Maybe HeaderName
-> HeaderName
-> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
token Maybe HeaderName
mJwt HeaderName
message
  where message :: HeaderName
message = ByteString -> HeaderName
L.toStrict (ByteString -> HeaderName) -> ByteString -> HeaderName
forall a b. (a -> b) -> a -> b
$ JsonAps -> ByteString
forall a. ToJSON a => a -> ByteString
encode JsonAps
payload

-- | Send a silent push notification
sendSilentMessage
    :: ApnSession
    -- ^ Session to use
    -> ApnToken
    -- ^ Device to send the message to
    -> Maybe ByteString
    -- ^ JWT Bearer Token
    -> IO ApnMessageResult
    -- ^ The response from the APN server
sendSilentMessage :: ApnSession -> ApnToken -> Maybe HeaderName -> IO ApnMessageResult
sendSilentMessage ApnSession
s ApnToken
token Maybe HeaderName
mJwt = 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
-> Maybe HeaderName
-> HeaderName
-> ClientIO ApnMessageResult
sendApnRaw ApnConnection
c ApnToken
token Maybe HeaderName
mJwt HeaderName
message
  where message :: HeaderName
message = HeaderName
"{\"aps\":{\"content-available\":1}}"

ensureSessionOpen :: ApnSession -> IO ()
ensureSessionOpen :: ApnSession -> IO ()
ensureSessionOpen ApnSession
s = do
    Bool
open <- ApnSession -> IO Bool
isSessionOpen 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
$ ApnException -> IO ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO ApnException
ApnExceptionConnectionClosed

ensureConnectionOpen :: ApnConnection -> IO ()
ensureConnectionOpen :: ApnConnection -> IO ()
ensureConnectionOpen ApnConnection
c = do
    Bool
open <- ApnConnection -> IO Bool
isConnectionOpen ApnConnection
c
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
open (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ApnException -> IO ()
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO ApnException
ApnExceptionConnectionClosed

-- | Send a push notification message.
sendApnRaw
    :: ApnConnection
    -- ^ Connection to use
    -> ApnToken
    -- ^ Device to send the message to
    -> Maybe ByteString
    -- ^ JWT Bearer Token
    -> ByteString
    -- ^ The message to send
    -> ClientIO ApnMessageResult
sendApnRaw :: ApnConnection
-> ApnToken
-> Maybe HeaderName
-> HeaderName
-> ClientIO ApnMessageResult
sendApnRaw ApnConnection
connection ApnToken
deviceToken Maybe HeaderName
mJwtBearerToken HeaderName
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 (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
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 (m :: * -> *) a. Monad m => m a -> ExceptT ClientError m a
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 aci :: ApnConnectionInfo
aci = ApnConnection -> ApnConnectionInfo
apnConnectionInfo ApnConnection
connection
        requestHeaders :: [(HeaderName, HeaderName)]
requestHeaders = [(HeaderName, HeaderName)]
-> (HeaderName -> [(HeaderName, HeaderName)])
-> Maybe HeaderName
-> [(HeaderName, HeaderName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> HeaderName -> HeaderName -> [(HeaderName, HeaderName)]
defaultHeaders Text
hostname HeaderName
token1 HeaderName
topic)
                         (\HeaderName
bearerToken -> (Text -> HeaderName -> HeaderName -> [(HeaderName, HeaderName)]
defaultHeaders Text
hostname HeaderName
token1 HeaderName
topic) [(HeaderName, HeaderName)]
-> [(HeaderName, HeaderName)] -> [(HeaderName, HeaderName)]
forall a. Semigroup a => a -> a -> a
<> [ ( HeaderName
"authorization", HeaderName
"bearer " HeaderName -> HeaderName -> HeaderName
forall a. Semigroup a => a -> a -> a
<> HeaderName
bearerToken ) ])
                         Maybe HeaderName
mJwtBearerToken
        hostname :: Text
hostname = ApnConnectionInfo -> Text
aciHostname ApnConnectionInfo
aci
        topic :: HeaderName
topic = ApnConnectionInfo -> HeaderName
aciTopic ApnConnectionInfo
aci
        client :: Http2Client
client = ApnConnection -> Http2Client
apnConnectionConnection ApnConnection
connection
        token1 :: HeaderName
token1 = ApnToken -> HeaderName
unApnToken ApnToken
deviceToken

    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
-> [(HeaderName, HeaderName)]
-> FlagSetter
-> ClientIO StreamThread
headers Http2Stream
stream [(HeaderName, HeaderName)]
requestHeaders FlagSetter
forall a. a -> a
id
            handler :: IncomingFlowControl
-> OutgoingFlowControl -> ClientIO ApnMessageResult
handler IncomingFlowControl
isfc OutgoingFlowControl
osfc = do
                -- sendData client stream (HTTP2.setEndStream) message
                HeaderName
-> FlagSetter
-> Http2Client
-> OutgoingFlowControl
-> Http2Stream
-> OutgoingFlowControl
-> ExceptT ClientError IO ()
upload HeaderName
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 (m :: * -> *) a. Monad m => m a -> t m a
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
#if MIN_VERSION_http2_client(0, 10, 0)
                StreamResult
response <- Http2Client
-> Http2Stream
-> IncomingFlowControl
-> PushPromiseHandler
-> ClientIO StreamResult
waitStream Http2Client
client Http2Stream
stream IncomingFlowControl
isfc PushPromiseHandler
forall {t :: (* -> *) -> * -> *} {a} {p} {p} {p} {p}.
(MonadTrans t, Show a) =>
p -> p -> a -> p -> p -> t IO ()
pph
#else
                response <- waitStream stream isfc pph
#endif
                let (Either ErrorCode [(HeaderName, HeaderName)]
errOrHeaders, [Either ErrorCode HeaderName]
frameResponses, Maybe [(HeaderName, HeaderName)]
_) = StreamResult
response
                case Either ErrorCode [(HeaderName, HeaderName)]
errOrHeaders of
                    Left ErrorCode
err -> ApnException -> ClientIO ApnMessageResult
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (ErrorCode -> ApnException
ApnExceptionHTTP ErrorCode
err)
                    Right [(HeaderName, HeaderName)]
hdrs1 -> do
                        let status :: HeaderName
status       = HeaderName -> [(HeaderName, HeaderName)] -> HeaderName
getHeaderEx HeaderName
":status" [(HeaderName, HeaderName)]
hdrs1
                            -- apns-id      = getHeaderEx "apns-id" hdrs1
                            [Right HeaderName
body] = [Either ErrorCode HeaderName]
frameResponses

                        ApnMessageResult -> ClientIO ApnMessageResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApnMessageResult -> ClientIO ApnMessageResult)
-> ApnMessageResult -> ClientIO ApnMessageResult
forall a b. (a -> b) -> a -> b
$ case HeaderName
status of
                            HeaderName
"200" -> ApnMessageResult
ApnMessageResultOk
                            HeaderName
"400" -> (ApnFatalError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError HeaderName
body
                            HeaderName
"403" -> (ApnFatalError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError HeaderName
body
                            HeaderName
"405" -> (ApnFatalError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError HeaderName
body
                            HeaderName
"410" -> (ApnFatalError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError HeaderName
body
                            HeaderName
"413" -> (ApnFatalError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError HeaderName
body
                            HeaderName
"429" -> (ApnTemporaryError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError HeaderName
body
                            HeaderName
"500" -> (ApnTemporaryError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError HeaderName
body
                            HeaderName
"503" -> (ApnTemporaryError -> ApnMessageResult)
-> HeaderName -> ApnMessageResult
forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason ApnTemporaryError -> ApnMessageResult
ApnMessageResultTemporaryError HeaderName
body
                            HeaderName
unknown ->
                                ApnFatalError -> ApnMessageResult
ApnMessageResultFatalError (ApnFatalError -> ApnMessageResult)
-> ApnFatalError -> ApnMessageResult
forall a b. (a -> b) -> a -> b
$
                                Text -> ApnFatalError
ApnFatalErrorOther (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"unhandled status: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HeaderName -> String
forall a. Show a => a -> String
show HeaderName
unknown)
        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 a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ApnMessageResult
ApnMessageResultBackoff -- Too much concurrency
        Right ApnMessageResult
res1 -> ApnMessageResult -> ClientIO ApnMessageResult
forall a. a -> ExceptT ClientError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ApnMessageResult
res1

    where
        decodeReason :: FromJSON response => (response -> ApnMessageResult) -> ByteString -> ApnMessageResult
        decodeReason :: forall response.
FromJSON response =>
(response -> ApnMessageResult) -> HeaderName -> ApnMessageResult
decodeReason response -> ApnMessageResult
ctor = (String -> ApnMessageResult)
-> (ApnMessageResult -> ApnMessageResult)
-> Either String 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)
-> (String -> ApnException) -> String -> ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ApnException
ApnExceptionJSON) ApnMessageResult -> ApnMessageResult
forall a. a -> a
id (Either String ApnMessageResult -> ApnMessageResult)
-> (HeaderName -> Either String ApnMessageResult)
-> HeaderName
-> ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ApnMessageResult
decodeBody (ByteString -> Either String ApnMessageResult)
-> (HeaderName -> ByteString)
-> HeaderName
-> Either String ApnMessageResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
L.fromStrict
            where
                decodeBody :: ByteString -> Either String ApnMessageResult
decodeBody ByteString
body =
                    ByteString -> Either String Object
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
body
                        Either String Object
-> (Object -> Either String ApnMessageResult)
-> Either String ApnMessageResult
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Parser ApnMessageResult)
-> Object -> Either String ApnMessageResult
forall a b. (a -> Parser b) -> a -> Either String 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 -> Key -> Parser response
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reason")

        getHeaderEx :: HTTP2.HeaderName -> [HTTP2.Header] -> HTTP2.HeaderValue
        getHeaderEx :: HeaderName -> [(HeaderName, HeaderName)] -> HeaderName
getHeaderEx HeaderName
name [(HeaderName, HeaderName)]
headers = HeaderName -> Maybe HeaderName -> HeaderName
forall a. a -> Maybe a -> a
fromMaybe (ApnException -> HeaderName
forall a e. Exception e => e -> a
throw (ApnException -> HeaderName) -> ApnException -> HeaderName
forall a b. (a -> b) -> a -> b
$ HeaderName -> ApnException
ApnExceptionMissingHeader HeaderName
name) (HeaderName -> [(HeaderName, HeaderName)] -> Maybe HeaderName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
DL.lookup HeaderName
name [(HeaderName, HeaderName)]
headers)

        defaultHeaders :: Text -> ByteString -> ByteString -> [(HTTP2.HeaderName, ByteString)]
        defaultHeaders :: Text -> HeaderName -> HeaderName -> [(HeaderName, HeaderName)]
defaultHeaders Text
hostname HeaderName
token HeaderName
topic = [ ( HeaderName
":method", HeaderName
"POST" )
                                              , ( HeaderName
":scheme", HeaderName
"https" )
                                              , ( HeaderName
":authority", Text -> HeaderName
TE.encodeUtf8 Text
hostname )
                                              , ( HeaderName
":path", HeaderName
"/3/device/" HeaderName -> HeaderName -> HeaderName
`S.append` HeaderName
token )
                                              , ( HeaderName
"apns-topic", HeaderName
topic ) ]


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 a. a -> IO a
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


-- The type of permanent error indicated by APNS
-- See https://apple.co/2RDCdWC table 8-6 for the meaning of each value.
data ApnFatalError = ApnFatalErrorBadCollapseId
                   | ApnFatalErrorBadDeviceToken
                   | ApnFatalErrorBadExpirationDate
                   | ApnFatalErrorBadMessageId
                   | ApnFatalErrorBadPriority
                   | ApnFatalErrorBadTopic
                   | ApnFatalErrorDeviceTokenNotForTopic
                   | ApnFatalErrorDuplicateHeaders
                   | 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
$c== :: ApnFatalError -> ApnFatalError -> Bool
== :: ApnFatalError -> ApnFatalError -> Bool
$c/= :: ApnFatalError -> ApnFatalError -> Bool
/= :: ApnFatalError -> ApnFatalError -> Bool
Eq, Int -> ApnFatalError -> ShowS
[ApnFatalError] -> ShowS
ApnFatalError -> String
(Int -> ApnFatalError -> ShowS)
-> (ApnFatalError -> String)
-> ([ApnFatalError] -> ShowS)
-> Show ApnFatalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApnFatalError -> ShowS
showsPrec :: Int -> ApnFatalError -> ShowS
$cshow :: ApnFatalError -> String
show :: ApnFatalError -> String
$cshowList :: [ApnFatalError] -> ShowS
showList :: [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
$cfrom :: forall x. ApnFatalError -> Rep ApnFatalError x
from :: forall x. ApnFatalError -> Rep ApnFatalError x
$cto :: forall x. Rep ApnFatalError x -> ApnFatalError
to :: forall x. Rep ApnFatalError x -> ApnFatalError
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 a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ApnFatalError
success
                Error String
err -> case Value
json of
                                String Text
other -> ApnFatalError -> Parser ApnFatalError
forall a. a -> Parser a
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
_            -> String -> Parser ApnFatalError
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
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 = drop 13,
                                sumEncoding = UntaggedValue
                            }

-- The type of transient error indicated by APNS
-- See https://apple.co/2RDCdWC table 8-6 for the meaning of each value.
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
$csucc :: ApnTemporaryError -> ApnTemporaryError
succ :: ApnTemporaryError -> ApnTemporaryError
$cpred :: ApnTemporaryError -> ApnTemporaryError
pred :: ApnTemporaryError -> ApnTemporaryError
$ctoEnum :: Int -> ApnTemporaryError
toEnum :: Int -> ApnTemporaryError
$cfromEnum :: ApnTemporaryError -> Int
fromEnum :: ApnTemporaryError -> Int
$cenumFrom :: ApnTemporaryError -> [ApnTemporaryError]
enumFrom :: ApnTemporaryError -> [ApnTemporaryError]
$cenumFromThen :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFromThen :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
$cenumFromTo :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFromTo :: ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
$cenumFromThenTo :: ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
enumFromThenTo :: ApnTemporaryError
-> ApnTemporaryError -> ApnTemporaryError -> [ApnTemporaryError]
Enum, ApnTemporaryError -> ApnTemporaryError -> Bool
(ApnTemporaryError -> ApnTemporaryError -> Bool)
-> (ApnTemporaryError -> ApnTemporaryError -> Bool)
-> Eq ApnTemporaryError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApnTemporaryError -> ApnTemporaryError -> Bool
== :: ApnTemporaryError -> ApnTemporaryError -> Bool
$c/= :: ApnTemporaryError -> ApnTemporaryError -> Bool
/= :: ApnTemporaryError -> ApnTemporaryError -> Bool
Eq, Int -> ApnTemporaryError -> ShowS
[ApnTemporaryError] -> ShowS
ApnTemporaryError -> String
(Int -> ApnTemporaryError -> ShowS)
-> (ApnTemporaryError -> String)
-> ([ApnTemporaryError] -> ShowS)
-> Show ApnTemporaryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApnTemporaryError -> ShowS
showsPrec :: Int -> ApnTemporaryError -> ShowS
$cshow :: ApnTemporaryError -> String
show :: ApnTemporaryError -> String
$cshowList :: [ApnTemporaryError] -> ShowS
showList :: [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
$cfrom :: forall x. ApnTemporaryError -> Rep ApnTemporaryError x
from :: forall x. ApnTemporaryError -> Rep ApnTemporaryError x
$cto :: forall x. Rep ApnTemporaryError x -> ApnTemporaryError
to :: forall x. Rep ApnTemporaryError x -> ApnTemporaryError
Generic, [ApnTemporaryError] -> Value
[ApnTemporaryError] -> Encoding
ApnTemporaryError -> Bool
ApnTemporaryError -> Value
ApnTemporaryError -> Encoding
(ApnTemporaryError -> Value)
-> (ApnTemporaryError -> Encoding)
-> ([ApnTemporaryError] -> Value)
-> ([ApnTemporaryError] -> Encoding)
-> (ApnTemporaryError -> Bool)
-> ToJSON ApnTemporaryError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ApnTemporaryError -> Value
toJSON :: ApnTemporaryError -> Value
$ctoEncoding :: ApnTemporaryError -> Encoding
toEncoding :: ApnTemporaryError -> Encoding
$ctoJSONList :: [ApnTemporaryError] -> Value
toJSONList :: [ApnTemporaryError] -> Value
$ctoEncodingList :: [ApnTemporaryError] -> Encoding
toEncodingList :: [ApnTemporaryError] -> Encoding
$comitField :: ApnTemporaryError -> Bool
omitField :: ApnTemporaryError -> Bool
ToJSON)

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 = drop 17 }