{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Simplex.Messaging.Notifications.Protocol
  ( NtfEntity (..),
    SNtfEntity (..),
    NtfEntityI (..),
    NtfCommandTag (..),
    NtfCmdTag (..),
    NtfRegCode (..),
    NewNtfEntity (..),
    ANewNtfEntity (..),
    NtfCommand (..),
    NtfCmd (..),
    NtfResponseTag (..),
    NtfResponse (..),
    SMPQueueNtf (..),
    PushProvider (..),
    DeviceToken (..),
    PNMessageData (..),
    NtfEntityId,
    NtfSubscriptionId,
    NtfTokenId,
    NtfSubStatus (..),
    NtfTknStatus (..),
    NTInvalidReason (..),
    encodePNMessages,
    pnMessagesP,
    ntfShouldSubscribe,
    allowTokenVerification,
    allowNtfSubCommands,
    checkEntity,
  ) where

import Control.Applicative (optional, (<|>))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (isNothing)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock.System
import Data.Type.Equality
import Data.Word (Word16)
import Simplex.Messaging.Agent.Protocol (updateSMPServerHosts)
import Simplex.Messaging.Agent.Store.DB (FromField (..), ToField (..), fromTextField_)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Notifications.Transport (NTFVersion, invalidReasonNTFVersion, ntfClientHandshake)
import Simplex.Messaging.Protocol hiding (Command (..), CommandTag (..))
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))

data NtfEntity = Token | Subscription
  deriving (Int -> NtfEntity -> ShowS
[NtfEntity] -> ShowS
NtfEntity -> String
(Int -> NtfEntity -> ShowS)
-> (NtfEntity -> String)
-> ([NtfEntity] -> ShowS)
-> Show NtfEntity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfEntity -> ShowS
showsPrec :: Int -> NtfEntity -> ShowS
$cshow :: NtfEntity -> String
show :: NtfEntity -> String
$cshowList :: [NtfEntity] -> ShowS
showList :: [NtfEntity] -> ShowS
Show)

data SNtfEntity :: NtfEntity -> Type where
  SToken :: SNtfEntity 'Token
  SSubscription :: SNtfEntity 'Subscription

instance TestEquality SNtfEntity where
  testEquality :: forall (a :: NtfEntity) (b :: NtfEntity).
SNtfEntity a -> SNtfEntity b -> Maybe (a :~: b)
testEquality SNtfEntity a
SToken SNtfEntity b
SToken = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SNtfEntity a
SSubscription SNtfEntity b
SSubscription = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SNtfEntity a
_ SNtfEntity b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

deriving instance Show (SNtfEntity e)

class NtfEntityI (e :: NtfEntity) where sNtfEntity :: SNtfEntity e

instance NtfEntityI 'Token where sNtfEntity :: SNtfEntity 'Token
sNtfEntity = SNtfEntity 'Token
SToken

instance NtfEntityI 'Subscription where sNtfEntity :: SNtfEntity 'Subscription
sNtfEntity = SNtfEntity 'Subscription
SSubscription

data NtfCommandTag (e :: NtfEntity) where
  TNEW_ :: NtfCommandTag 'Token
  TVFY_ :: NtfCommandTag 'Token
  TCHK_ :: NtfCommandTag 'Token
  TRPL_ :: NtfCommandTag 'Token
  TDEL_ :: NtfCommandTag 'Token
  TCRN_ :: NtfCommandTag 'Token
  SNEW_ :: NtfCommandTag 'Subscription
  SCHK_ :: NtfCommandTag 'Subscription
  SDEL_ :: NtfCommandTag 'Subscription
  PING_ :: NtfCommandTag 'Subscription

deriving instance Show (NtfCommandTag e)

data NtfCmdTag = forall e. NtfEntityI e => NCT (SNtfEntity e) (NtfCommandTag e)

instance NtfEntityI e => Encoding (NtfCommandTag e) where
  smpEncode :: NtfCommandTag e -> ByteString
smpEncode = \case
    NtfCommandTag e
TNEW_ -> ByteString
"TNEW"
    NtfCommandTag e
TVFY_ -> ByteString
"TVFY"
    NtfCommandTag e
TCHK_ -> ByteString
"TCHK"
    NtfCommandTag e
TRPL_ -> ByteString
"TRPL"
    NtfCommandTag e
TDEL_ -> ByteString
"TDEL"
    NtfCommandTag e
TCRN_ -> ByteString
"TCRN"
    NtfCommandTag e
SNEW_ -> ByteString
"SNEW"
    NtfCommandTag e
SCHK_ -> ByteString
"SCHK"
    NtfCommandTag e
SDEL_ -> ByteString
"SDEL"
    NtfCommandTag e
PING_ -> ByteString
"PING"
  smpP :: Parser (NtfCommandTag e)
smpP = Parser (NtfCommandTag e)
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance Encoding NtfCmdTag where
  smpEncode :: NtfCmdTag -> ByteString
smpEncode (NCT SNtfEntity e
_ NtfCommandTag e
t) = NtfCommandTag e -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode NtfCommandTag e
t
  smpP :: Parser NtfCmdTag
smpP = Parser NtfCmdTag
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance ProtocolMsgTag NtfCmdTag where
  decodeTag :: ByteString -> Maybe NtfCmdTag
decodeTag = \case
    ByteString
"TNEW" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TNEW_
    ByteString
"TVFY" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TVFY_
    ByteString
"TCHK" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TCHK_
    ByteString
"TRPL" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TRPL_
    ByteString
"TDEL" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TDEL_
    ByteString
"TCRN" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Token -> NtfCommandTag 'Token -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Token
SToken NtfCommandTag 'Token
TCRN_
    ByteString
"SNEW" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Subscription
-> NtfCommandTag 'Subscription -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Subscription
SSubscription NtfCommandTag 'Subscription
SNEW_
    ByteString
"SCHK" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Subscription
-> NtfCommandTag 'Subscription -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Subscription
SSubscription NtfCommandTag 'Subscription
SCHK_
    ByteString
"SDEL" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Subscription
-> NtfCommandTag 'Subscription -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Subscription
SSubscription NtfCommandTag 'Subscription
SDEL_
    ByteString
"PING" -> NtfCmdTag -> Maybe NtfCmdTag
forall a. a -> Maybe a
Just (NtfCmdTag -> Maybe NtfCmdTag) -> NtfCmdTag -> Maybe NtfCmdTag
forall a b. (a -> b) -> a -> b
$ SNtfEntity 'Subscription
-> NtfCommandTag 'Subscription -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT SNtfEntity 'Subscription
SSubscription NtfCommandTag 'Subscription
PING_
    ByteString
_ -> Maybe NtfCmdTag
forall a. Maybe a
Nothing

instance NtfEntityI e => ProtocolMsgTag (NtfCommandTag e) where
  decodeTag :: ByteString -> Maybe (NtfCommandTag e)
decodeTag ByteString
s = ByteString -> Maybe NtfCmdTag
forall t. ProtocolMsgTag t => ByteString -> Maybe t
decodeTag ByteString
s Maybe NtfCmdTag
-> (NtfCmdTag -> Maybe (NtfCommandTag e))
-> Maybe (NtfCommandTag e)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(NCT SNtfEntity e
_ NtfCommandTag e
t) -> NtfCommandTag e -> Maybe (NtfCommandTag e)
forall (t :: NtfEntity -> *) (p :: NtfEntity) (p' :: NtfEntity).
(NtfEntityI p, NtfEntityI p') =>
t p' -> Maybe (t p)
checkEntity' NtfCommandTag e
t)

newtype NtfRegCode = NtfRegCode ByteString
  deriving (NtfRegCode -> NtfRegCode -> Bool
(NtfRegCode -> NtfRegCode -> Bool)
-> (NtfRegCode -> NtfRegCode -> Bool) -> Eq NtfRegCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NtfRegCode -> NtfRegCode -> Bool
== :: NtfRegCode -> NtfRegCode -> Bool
$c/= :: NtfRegCode -> NtfRegCode -> Bool
/= :: NtfRegCode -> NtfRegCode -> Bool
Eq, Int -> NtfRegCode -> ShowS
[NtfRegCode] -> ShowS
NtfRegCode -> String
(Int -> NtfRegCode -> ShowS)
-> (NtfRegCode -> String)
-> ([NtfRegCode] -> ShowS)
-> Show NtfRegCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfRegCode -> ShowS
showsPrec :: Int -> NtfRegCode -> ShowS
$cshow :: NtfRegCode -> String
show :: NtfRegCode -> String
$cshowList :: [NtfRegCode] -> ShowS
showList :: [NtfRegCode] -> ShowS
Show)

instance Encoding NtfRegCode where
  smpEncode :: NtfRegCode -> ByteString
smpEncode (NtfRegCode ByteString
code) = ByteString -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode ByteString
code
  smpP :: Parser NtfRegCode
smpP = ByteString -> NtfRegCode
NtfRegCode (ByteString -> NtfRegCode)
-> Parser ByteString ByteString -> Parser NtfRegCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP

instance StrEncoding NtfRegCode where
  strEncode :: NtfRegCode -> ByteString
strEncode (NtfRegCode ByteString
m) = ByteString -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ByteString
m
  strDecode :: ByteString -> Either String NtfRegCode
strDecode ByteString
s = ByteString -> NtfRegCode
NtfRegCode (ByteString -> NtfRegCode)
-> Either String ByteString -> Either String NtfRegCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String ByteString
forall a. StrEncoding a => ByteString -> Either String a
strDecode ByteString
s
  strP :: Parser NtfRegCode
strP = ByteString -> NtfRegCode
NtfRegCode (ByteString -> NtfRegCode)
-> Parser ByteString ByteString -> Parser NtfRegCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
forall a. StrEncoding a => Parser a
strP

instance FromJSON NtfRegCode where
  parseJSON :: Value -> Parser NtfRegCode
parseJSON = String -> Value -> Parser NtfRegCode
forall a. StrEncoding a => String -> Value -> Parser a
strParseJSON String
"NtfRegCode"

instance ToJSON NtfRegCode where
  toJSON :: NtfRegCode -> Value
toJSON = NtfRegCode -> Value
forall a. StrEncoding a => a -> Value
strToJSON
  toEncoding :: NtfRegCode -> Encoding
toEncoding = NtfRegCode -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding

data NewNtfEntity (e :: NtfEntity) where
  NewNtfTkn :: DeviceToken -> NtfPublicAuthKey -> C.PublicKeyX25519 -> NewNtfEntity 'Token
  NewNtfSub :: NtfTokenId -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription

deriving instance Show (NewNtfEntity e)

data ANewNtfEntity = forall e. NtfEntityI e => ANE (SNtfEntity e) (NewNtfEntity e)

deriving instance Show ANewNtfEntity

instance NtfEntityI e => Encoding (NewNtfEntity e) where
  smpEncode :: NewNtfEntity e -> ByteString
smpEncode = \case
    NewNtfTkn DeviceToken
tkn NtfPublicAuthKey
verifyKey PublicKeyX25519
dhPubKey -> (Char, DeviceToken, NtfPublicAuthKey, PublicKeyX25519)
-> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'T', DeviceToken
tkn, NtfPublicAuthKey
verifyKey, PublicKeyX25519
dhPubKey)
    NewNtfSub NtfTokenId
tknId SMPQueueNtf
smpQueue NtfPrivateAuthKey
notifierKey -> (Char, NtfTokenId, SMPQueueNtf, NtfPrivateAuthKey) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (Char
'S', NtfTokenId
tknId, SMPQueueNtf
smpQueue, NtfPrivateAuthKey
notifierKey)
  smpP :: Parser (NewNtfEntity e)
smpP = (\(ANE SNtfEntity e
_ NewNtfEntity e
c) -> NewNtfEntity e -> Either String (NewNtfEntity e)
forall (t :: NtfEntity -> *) (e :: NtfEntity) (e' :: NtfEntity).
(NtfEntityI e, NtfEntityI e') =>
t e' -> Either String (t e)
checkEntity NewNtfEntity e
c) (ANewNtfEntity -> Either String (NewNtfEntity e))
-> Parser ByteString ANewNtfEntity -> Parser (NewNtfEntity e)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString ANewNtfEntity
forall a. Encoding a => Parser a
smpP

instance Encoding ANewNtfEntity where
  smpEncode :: ANewNtfEntity -> ByteString
smpEncode (ANE SNtfEntity e
_ NewNtfEntity e
e) = NewNtfEntity e -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode NewNtfEntity e
e
  smpP :: Parser ByteString ANewNtfEntity
smpP =
    Parser Char
A.anyChar Parser Char
-> (Char -> Parser ByteString ANewNtfEntity)
-> Parser ByteString ANewNtfEntity
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'T' -> SNtfEntity 'Token -> NewNtfEntity 'Token -> ANewNtfEntity
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NewNtfEntity e -> ANewNtfEntity
ANE SNtfEntity 'Token
SToken (NewNtfEntity 'Token -> ANewNtfEntity)
-> Parser ByteString (NewNtfEntity 'Token)
-> Parser ByteString ANewNtfEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DeviceToken
-> NtfPublicAuthKey -> PublicKeyX25519 -> NewNtfEntity 'Token
NewNtfTkn (DeviceToken
 -> NtfPublicAuthKey -> PublicKeyX25519 -> NewNtfEntity 'Token)
-> Parser ByteString DeviceToken
-> Parser
     ByteString
     (NtfPublicAuthKey -> PublicKeyX25519 -> NewNtfEntity 'Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString DeviceToken
forall a. Encoding a => Parser a
smpP Parser
  ByteString
  (NtfPublicAuthKey -> PublicKeyX25519 -> NewNtfEntity 'Token)
-> Parser ByteString NtfPublicAuthKey
-> Parser ByteString (PublicKeyX25519 -> NewNtfEntity 'Token)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString NtfPublicAuthKey
forall a. Encoding a => Parser a
smpP Parser ByteString (PublicKeyX25519 -> NewNtfEntity 'Token)
-> Parser ByteString PublicKeyX25519
-> Parser ByteString (NewNtfEntity 'Token)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString PublicKeyX25519
forall a. Encoding a => Parser a
smpP)
      Char
'S' -> SNtfEntity 'Subscription
-> NewNtfEntity 'Subscription -> ANewNtfEntity
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NewNtfEntity e -> ANewNtfEntity
ANE SNtfEntity 'Subscription
SSubscription (NewNtfEntity 'Subscription -> ANewNtfEntity)
-> Parser ByteString (NewNtfEntity 'Subscription)
-> Parser ByteString ANewNtfEntity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NtfTokenId
-> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription
NewNtfSub (NtfTokenId
 -> SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription)
-> Parser ByteString NtfTokenId
-> Parser
     ByteString
     (SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NtfTokenId
forall a. Encoding a => Parser a
smpP Parser
  ByteString
  (SMPQueueNtf -> NtfPrivateAuthKey -> NewNtfEntity 'Subscription)
-> Parser ByteString SMPQueueNtf
-> Parser
     ByteString (NtfPrivateAuthKey -> NewNtfEntity 'Subscription)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString SMPQueueNtf
forall a. Encoding a => Parser a
smpP Parser ByteString (NtfPrivateAuthKey -> NewNtfEntity 'Subscription)
-> Parser ByteString NtfPrivateAuthKey
-> Parser ByteString (NewNtfEntity 'Subscription)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString NtfPrivateAuthKey
forall a. Encoding a => Parser a
smpP)
      Char
_ -> String -> Parser ByteString ANewNtfEntity
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ANewNtfEntity"

instance Protocol NTFVersion ErrorType NtfResponse where
  type ProtoCommand NtfResponse = NtfCmd
  type ProtoType NtfResponse = 'PNTF
  protocolClientHandshake :: forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRange NTFVersion
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandle NTFVersion c 'TClient)
protocolClientHandshake c 'TClient
c Maybe KeyPairX25519
_ks = c 'TClient
-> KeyHash
-> VersionRange NTFVersion
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandleNTF c 'TClient)
forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient
-> KeyHash
-> VersionRange NTFVersion
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandleNTF c 'TClient)
ntfClientHandshake c 'TClient
c
  {-# INLINE protocolClientHandshake #-}
  useServiceAuth :: ProtoCommand NtfResponse -> Bool
useServiceAuth ProtoCommand NtfResponse
_ = Bool
False
  {-# INLINE useServiceAuth #-}
  protocolPing :: ProtoCommand NtfResponse
protocolPing = SNtfEntity 'Subscription -> NtfCommand 'Subscription -> NtfCmd
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommand e -> NtfCmd
NtfCmd SNtfEntity 'Subscription
SSubscription NtfCommand 'Subscription
PING
  {-# INLINE protocolPing #-}
  protocolError :: NtfResponse -> Maybe ErrorType
protocolError = \case
    NRErr ErrorType
e -> ErrorType -> Maybe ErrorType
forall a. a -> Maybe a
Just ErrorType
e
    NtfResponse
_ -> Maybe ErrorType
forall a. Maybe a
Nothing
  {-# INLINE protocolError #-}

data NtfCommand (e :: NtfEntity) where
  -- | register new device token for notifications
  TNEW :: NewNtfEntity 'Token -> NtfCommand 'Token
  -- | verify token - uses e2e encrypted random string sent to the device via PN to confirm that the device has the token
  TVFY :: NtfRegCode -> NtfCommand 'Token
  -- | check token status
  TCHK :: NtfCommand 'Token
  -- | replace device token (while keeping all existing subscriptions)
  TRPL :: DeviceToken -> NtfCommand 'Token
  -- | delete token - all subscriptions will be removed and no more notifications will be sent
  TDEL :: NtfCommand 'Token
  -- | enable periodic background notification to fetch the new messages - interval is in minutes, minimum is 20, 0 to disable
  TCRN :: Word16 -> NtfCommand 'Token
  -- | create SMP subscription
  SNEW :: NewNtfEntity 'Subscription -> NtfCommand 'Subscription
  -- | check SMP subscription status (response is SUB)
  SCHK :: NtfCommand 'Subscription
  -- | delete SMP subscription
  SDEL :: NtfCommand 'Subscription
  -- | keep-alive command
  PING :: NtfCommand 'Subscription

deriving instance Show (NtfCommand e)

data NtfCmd = forall e. NtfEntityI e => NtfCmd (SNtfEntity e) (NtfCommand e)

deriving instance Show NtfCmd

instance NtfEntityI e => ProtocolEncoding NTFVersion ErrorType (NtfCommand e) where
  type Tag (NtfCommand e) = NtfCommandTag e
  encodeProtocol :: Version NTFVersion -> NtfCommand e -> ByteString
encodeProtocol Version NTFVersion
_v = \case
    TNEW NewNtfEntity 'Token
newTkn -> (NtfCommandTag 'Token, Char, NewNtfEntity 'Token) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfCommandTag 'Token
TNEW_, Char
' ', NewNtfEntity 'Token
newTkn)
    TVFY NtfRegCode
code -> (NtfCommandTag 'Token, Char, NtfRegCode) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfCommandTag 'Token
TVFY_, Char
' ', NtfRegCode
code)
    NtfCommand e
TCHK -> NtfCommandTag 'Token -> ByteString
forall a. Encoding a => a -> ByteString
e NtfCommandTag 'Token
TCHK_
    TRPL DeviceToken
tkn -> (NtfCommandTag 'Token, Char, DeviceToken) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfCommandTag 'Token
TRPL_, Char
' ', DeviceToken
tkn)
    NtfCommand e
TDEL -> NtfCommandTag 'Token -> ByteString
forall a. Encoding a => a -> ByteString
e NtfCommandTag 'Token
TDEL_
    TCRN Word16
int -> (NtfCommandTag 'Token, Char, Word16) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfCommandTag 'Token
TCRN_, Char
' ', Word16
int)
    SNEW NewNtfEntity 'Subscription
newSub -> (NtfCommandTag 'Subscription, Char, NewNtfEntity 'Subscription)
-> ByteString
forall a. Encoding a => a -> ByteString
e (NtfCommandTag 'Subscription
SNEW_, Char
' ', NewNtfEntity 'Subscription
newSub)
    NtfCommand e
SCHK -> NtfCommandTag 'Subscription -> ByteString
forall a. Encoding a => a -> ByteString
e NtfCommandTag 'Subscription
SCHK_
    NtfCommand e
SDEL -> NtfCommandTag 'Subscription -> ByteString
forall a. Encoding a => a -> ByteString
e NtfCommandTag 'Subscription
SDEL_
    NtfCommand e
PING -> NtfCommandTag 'Subscription -> ByteString
forall a. Encoding a => a -> ByteString
e NtfCommandTag 'Subscription
PING_
    where
      e :: Encoding a => a -> ByteString
      e :: forall a. Encoding a => a -> ByteString
e = a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

  protocolP :: Version NTFVersion -> Tag (NtfCommand e) -> Parser (NtfCommand e)
protocolP Version NTFVersion
_v Tag (NtfCommand e)
tag = (\(NtfCmd SNtfEntity e
_ NtfCommand e
c) -> NtfCommand e -> Either String (NtfCommand e)
forall (t :: NtfEntity -> *) (e :: NtfEntity) (e' :: NtfEntity).
(NtfEntityI e, NtfEntityI e') =>
t e' -> Either String (t e)
checkEntity NtfCommand e
c) (NtfCmd -> Either String (NtfCommand e))
-> Parser ByteString NtfCmd -> Parser (NtfCommand e)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Version NTFVersion -> Tag NtfCmd -> Parser ByteString NtfCmd
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> Tag msg -> Parser msg
protocolP Version NTFVersion
_v (SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommandTag e -> NtfCmdTag
NCT (forall (e :: NtfEntity). NtfEntityI e => SNtfEntity e
sNtfEntity @e) Tag (NtfCommand e)
NtfCommandTag e
tag)

  fromProtocolError :: ProtocolErrorType -> ErrorType
fromProtocolError = forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @NTFVersion @ErrorType @NtfResponse
  {-# INLINE fromProtocolError #-}

  checkCredentials :: Maybe TAuthorizations
-> NtfTokenId -> NtfCommand e -> Either ErrorType (NtfCommand e)
checkCredentials Maybe TAuthorizations
auth (EntityId ByteString
entityId) NtfCommand e
cmd = case NtfCommand e
cmd of
    -- TNEW and SNEW must have signature but NOT token/subscription IDs
    TNEW {} -> Either ErrorType (NtfCommand e)
sigNoEntity
    SNEW {} -> Either ErrorType (NtfCommand e)
sigNoEntity
    NtfCommand e
PING
      | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth Bool -> Bool -> Bool
&& ByteString -> Bool
B.null ByteString
entityId -> NtfCommand e -> Either ErrorType (NtfCommand e)
forall a b. b -> Either a b
Right NtfCommand e
cmd
      | Bool
otherwise -> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (NtfCommand e))
-> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
    -- other client commands must have both signature and entity ID
    NtfCommand e
_
      | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth Bool -> Bool -> Bool
|| ByteString -> Bool
B.null ByteString
entityId -> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (NtfCommand e))
-> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
      | Bool
otherwise -> NtfCommand e -> Either ErrorType (NtfCommand e)
forall a b. b -> Either a b
Right NtfCommand e
cmd
    where
      sigNoEntity :: Either ErrorType (NtfCommand e)
sigNoEntity
        | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth = ErrorType -> Either ErrorType (NtfCommand e)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (NtfCommand e))
-> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
        | Bool -> Bool
not (ByteString -> Bool
B.null ByteString
entityId) = ErrorType -> Either ErrorType (NtfCommand e)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (NtfCommand e))
-> ErrorType -> Either ErrorType (NtfCommand e)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
        | Bool
otherwise = NtfCommand e -> Either ErrorType (NtfCommand e)
forall a b. b -> Either a b
Right NtfCommand e
cmd

instance ProtocolEncoding NTFVersion ErrorType NtfCmd where
  type Tag NtfCmd = NtfCmdTag
  encodeProtocol :: Version NTFVersion -> NtfCmd -> ByteString
encodeProtocol Version NTFVersion
_v (NtfCmd SNtfEntity e
_ NtfCommand e
c) = Version NTFVersion -> NtfCommand e -> ByteString
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> msg -> ByteString
encodeProtocol Version NTFVersion
_v NtfCommand e
c

  protocolP :: Version NTFVersion -> Tag NtfCmd -> Parser ByteString NtfCmd
protocolP Version NTFVersion
_v = \case
    NCT SNtfEntity e
SToken NtfCommandTag e
tag ->
      SNtfEntity 'Token -> NtfCommand 'Token -> NtfCmd
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommand e -> NtfCmd
NtfCmd SNtfEntity 'Token
SToken (NtfCommand 'Token -> NtfCmd)
-> Parser ByteString (NtfCommand 'Token)
-> Parser ByteString NtfCmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case NtfCommandTag e
tag of
        NtfCommandTag e
TNEW_ -> NewNtfEntity 'Token -> NtfCommand 'Token
TNEW (NewNtfEntity 'Token -> NtfCommand 'Token)
-> Parser ByteString (NewNtfEntity 'Token)
-> Parser ByteString (NtfCommand 'Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (NewNtfEntity 'Token)
forall a. Encoding a => Parser a
_smpP
        NtfCommandTag e
TVFY_ -> NtfRegCode -> NtfCommand 'Token
TVFY (NtfRegCode -> NtfCommand 'Token)
-> Parser NtfRegCode -> Parser ByteString (NtfCommand 'Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser NtfRegCode
forall a. Encoding a => Parser a
_smpP
        NtfCommandTag e
TCHK_ -> NtfCommand 'Token -> Parser ByteString (NtfCommand 'Token)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCommand 'Token
TCHK
        NtfCommandTag e
TRPL_ -> DeviceToken -> NtfCommand 'Token
TRPL (DeviceToken -> NtfCommand 'Token)
-> Parser ByteString DeviceToken
-> Parser ByteString (NtfCommand 'Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString DeviceToken
forall a. Encoding a => Parser a
_smpP
        NtfCommandTag e
TDEL_ -> NtfCommand 'Token -> Parser ByteString (NtfCommand 'Token)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCommand 'Token
TDEL
        NtfCommandTag e
TCRN_ -> Word16 -> NtfCommand 'Token
TCRN (Word16 -> NtfCommand 'Token)
-> Parser ByteString Word16
-> Parser ByteString (NtfCommand 'Token)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word16
forall a. Encoding a => Parser a
_smpP
    NCT SNtfEntity e
SSubscription NtfCommandTag e
tag ->
      SNtfEntity 'Subscription -> NtfCommand 'Subscription -> NtfCmd
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommand e -> NtfCmd
NtfCmd SNtfEntity 'Subscription
SSubscription (NtfCommand 'Subscription -> NtfCmd)
-> Parser ByteString (NtfCommand 'Subscription)
-> Parser ByteString NtfCmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case NtfCommandTag e
tag of
        NtfCommandTag e
SNEW_ -> NewNtfEntity 'Subscription -> NtfCommand 'Subscription
SNEW (NewNtfEntity 'Subscription -> NtfCommand 'Subscription)
-> Parser ByteString (NewNtfEntity 'Subscription)
-> Parser ByteString (NtfCommand 'Subscription)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (NewNtfEntity 'Subscription)
forall a. Encoding a => Parser a
_smpP
        NtfCommandTag e
SCHK_ -> NtfCommand 'Subscription
-> Parser ByteString (NtfCommand 'Subscription)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCommand 'Subscription
SCHK
        NtfCommandTag e
SDEL_ -> NtfCommand 'Subscription
-> Parser ByteString (NtfCommand 'Subscription)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCommand 'Subscription
SDEL
        NtfCommandTag e
PING_ -> NtfCommand 'Subscription
-> Parser ByteString (NtfCommand 'Subscription)
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCommand 'Subscription
PING

  fromProtocolError :: ProtocolErrorType -> ErrorType
fromProtocolError = forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @NTFVersion @ErrorType @NtfResponse
  {-# INLINE fromProtocolError #-}

  checkCredentials :: Maybe TAuthorizations
-> NtfTokenId -> NtfCmd -> Either ErrorType NtfCmd
checkCredentials Maybe TAuthorizations
tAuth NtfTokenId
entId (NtfCmd SNtfEntity e
e NtfCommand e
c) = SNtfEntity e -> NtfCommand e -> NtfCmd
forall (e :: NtfEntity).
NtfEntityI e =>
SNtfEntity e -> NtfCommand e -> NtfCmd
NtfCmd SNtfEntity e
e (NtfCommand e -> NtfCmd)
-> Either ErrorType (NtfCommand e) -> Either ErrorType NtfCmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TAuthorizations
-> NtfTokenId -> NtfCommand e -> Either ErrorType (NtfCommand e)
forall v err msg.
ProtocolEncoding v err msg =>
Maybe TAuthorizations -> NtfTokenId -> msg -> Either err msg
checkCredentials Maybe TAuthorizations
tAuth NtfTokenId
entId NtfCommand e
c

data NtfResponseTag
  = NRTknId_
  | NRSubId_
  | NROk_
  | NRErr_
  | NRTkn_
  | NRSub_
  | NRPong_
  deriving (Int -> NtfResponseTag -> ShowS
[NtfResponseTag] -> ShowS
NtfResponseTag -> String
(Int -> NtfResponseTag -> ShowS)
-> (NtfResponseTag -> String)
-> ([NtfResponseTag] -> ShowS)
-> Show NtfResponseTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfResponseTag -> ShowS
showsPrec :: Int -> NtfResponseTag -> ShowS
$cshow :: NtfResponseTag -> String
show :: NtfResponseTag -> String
$cshowList :: [NtfResponseTag] -> ShowS
showList :: [NtfResponseTag] -> ShowS
Show)

instance Encoding NtfResponseTag where
  smpEncode :: NtfResponseTag -> ByteString
smpEncode = \case
    NtfResponseTag
NRTknId_ -> ByteString
"IDTKN" -- it should be "TID", "SID"
    NtfResponseTag
NRSubId_ -> ByteString
"IDSUB"
    NtfResponseTag
NROk_ -> ByteString
"OK"
    NtfResponseTag
NRErr_ -> ByteString
"ERR"
    NtfResponseTag
NRTkn_ -> ByteString
"TKN"
    NtfResponseTag
NRSub_ -> ByteString
"SUB"
    NtfResponseTag
NRPong_ -> ByteString
"PONG"
  smpP :: Parser NtfResponseTag
smpP = Parser NtfResponseTag
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance ProtocolMsgTag NtfResponseTag where
  decodeTag :: ByteString -> Maybe NtfResponseTag
decodeTag = \case
    ByteString
"IDTKN" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRTknId_
    ByteString
"IDSUB" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRSubId_
    ByteString
"OK" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NROk_
    ByteString
"ERR" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRErr_
    ByteString
"TKN" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRTkn_
    ByteString
"SUB" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRSub_
    ByteString
"PONG" -> NtfResponseTag -> Maybe NtfResponseTag
forall a. a -> Maybe a
Just NtfResponseTag
NRPong_
    ByteString
_ -> Maybe NtfResponseTag
forall a. Maybe a
Nothing

data NtfResponse
  = NRTknId NtfEntityId C.PublicKeyX25519
  | NRSubId NtfEntityId
  | NROk
  | NRErr ErrorType
  | NRTkn NtfTknStatus
  | NRSub NtfSubStatus
  | NRPong
  deriving (Int -> NtfResponse -> ShowS
[NtfResponse] -> ShowS
NtfResponse -> String
(Int -> NtfResponse -> ShowS)
-> (NtfResponse -> String)
-> ([NtfResponse] -> ShowS)
-> Show NtfResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfResponse -> ShowS
showsPrec :: Int -> NtfResponse -> ShowS
$cshow :: NtfResponse -> String
show :: NtfResponse -> String
$cshowList :: [NtfResponse] -> ShowS
showList :: [NtfResponse] -> ShowS
Show)

instance ProtocolEncoding NTFVersion ErrorType NtfResponse where
  type Tag NtfResponse = NtfResponseTag
  encodeProtocol :: Version NTFVersion -> NtfResponse -> ByteString
encodeProtocol Version NTFVersion
v = \case
    NRTknId NtfTokenId
entId PublicKeyX25519
dhKey -> (NtfResponseTag, Char, NtfTokenId, PublicKeyX25519) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfResponseTag
NRTknId_, Char
' ', NtfTokenId
entId, PublicKeyX25519
dhKey)
    NRSubId NtfTokenId
entId -> (NtfResponseTag, Char, NtfTokenId) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfResponseTag
NRSubId_, Char
' ', NtfTokenId
entId)
    NtfResponse
NROk -> NtfResponseTag -> ByteString
forall a. Encoding a => a -> ByteString
e NtfResponseTag
NROk_
    NRErr ErrorType
err -> (NtfResponseTag, Char, ErrorType) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfResponseTag
NRErr_, Char
' ', ErrorType
err)
    NRTkn NtfTknStatus
stat -> (NtfResponseTag, Char, NtfTknStatus) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfResponseTag
NRTkn_, Char
' ', NtfTknStatus
stat')
      where
        stat' :: NtfTknStatus
stat'
          | Version NTFVersion
v Version NTFVersion -> Version NTFVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= Version NTFVersion
invalidReasonNTFVersion = NtfTknStatus
stat
          | Bool
otherwise = case NtfTknStatus
stat of
              NTInvalid Maybe NTInvalidReason
_ -> Maybe NTInvalidReason -> NtfTknStatus
NTInvalid Maybe NTInvalidReason
forall a. Maybe a
Nothing
              NtfTknStatus
_ -> NtfTknStatus
stat
    NRSub NtfSubStatus
stat -> (NtfResponseTag, Char, NtfSubStatus) -> ByteString
forall a. Encoding a => a -> ByteString
e (NtfResponseTag
NRSub_, Char
' ', NtfSubStatus
stat)
    NtfResponse
NRPong -> NtfResponseTag -> ByteString
forall a. Encoding a => a -> ByteString
e NtfResponseTag
NRPong_
    where
      e :: Encoding a => a -> ByteString
      e :: forall a. Encoding a => a -> ByteString
e = a -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

  protocolP :: Version NTFVersion -> Tag NtfResponse -> Parser NtfResponse
protocolP Version NTFVersion
_v = \case
    Tag NtfResponse
NtfResponseTag
NRTknId_ -> NtfTokenId -> PublicKeyX25519 -> NtfResponse
NRTknId (NtfTokenId -> PublicKeyX25519 -> NtfResponse)
-> Parser ByteString NtfTokenId
-> Parser ByteString (PublicKeyX25519 -> NtfResponse)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NtfTokenId
forall a. Encoding a => Parser a
_smpP Parser ByteString (PublicKeyX25519 -> NtfResponse)
-> Parser ByteString PublicKeyX25519 -> Parser NtfResponse
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString PublicKeyX25519
forall a. Encoding a => Parser a
smpP
    Tag NtfResponse
NtfResponseTag
NRSubId_ -> NtfTokenId -> NtfResponse
NRSubId (NtfTokenId -> NtfResponse)
-> Parser ByteString NtfTokenId -> Parser NtfResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NtfTokenId
forall a. Encoding a => Parser a
_smpP
    Tag NtfResponse
NtfResponseTag
NROk_ -> NtfResponse -> Parser NtfResponse
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfResponse
NROk
    Tag NtfResponse
NtfResponseTag
NRErr_ -> ErrorType -> NtfResponse
NRErr (ErrorType -> NtfResponse)
-> Parser ByteString ErrorType -> Parser NtfResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ErrorType
forall a. Encoding a => Parser a
_smpP
    Tag NtfResponse
NtfResponseTag
NRTkn_ -> NtfTknStatus -> NtfResponse
NRTkn (NtfTknStatus -> NtfResponse)
-> Parser ByteString NtfTknStatus -> Parser NtfResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NtfTknStatus
forall a. Encoding a => Parser a
_smpP
    Tag NtfResponse
NtfResponseTag
NRSub_ -> NtfSubStatus -> NtfResponse
NRSub (NtfSubStatus -> NtfResponse)
-> Parser ByteString NtfSubStatus -> Parser NtfResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NtfSubStatus
forall a. Encoding a => Parser a
_smpP
    Tag NtfResponse
NtfResponseTag
NRPong_ -> NtfResponse -> Parser NtfResponse
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfResponse
NRPong

  fromProtocolError :: ProtocolErrorType -> ErrorType
fromProtocolError = \case
    ProtocolErrorType
PECmdSyntax -> CommandError -> ErrorType
CMD CommandError
SYNTAX
    ProtocolErrorType
PECmdUnknown -> CommandError -> ErrorType
CMD CommandError
UNKNOWN
    ProtocolErrorType
PESession -> ErrorType
SESSION
    ProtocolErrorType
PEBlock -> ErrorType
BLOCK
  {-# INLINE fromProtocolError #-}

  checkCredentials :: Maybe TAuthorizations
-> NtfTokenId -> NtfResponse -> Either ErrorType NtfResponse
checkCredentials Maybe TAuthorizations
_ (EntityId ByteString
entId) NtfResponse
cmd = case NtfResponse
cmd of
    -- IDTKN response must not have queue ID
    NRTknId {} -> Either ErrorType NtfResponse
noEntity
    -- IDSUB response must not have queue ID
    NRSubId {} -> Either ErrorType NtfResponse
noEntity
    -- ERR response does not always have entity ID
    NRErr ErrorType
_ -> NtfResponse -> Either ErrorType NtfResponse
forall a b. b -> Either a b
Right NtfResponse
cmd
    -- PONG response must not have queue ID
    NtfResponse
NRPong -> Either ErrorType NtfResponse
noEntity
    -- other server responses must have entity ID
    NtfResponse
_
      | ByteString -> Bool
B.null ByteString
entId -> ErrorType -> Either ErrorType NtfResponse
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType NtfResponse)
-> ErrorType -> Either ErrorType NtfResponse
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_ENTITY
      | Bool
otherwise -> NtfResponse -> Either ErrorType NtfResponse
forall a b. b -> Either a b
Right NtfResponse
cmd
    where
      noEntity :: Either ErrorType NtfResponse
noEntity
        | ByteString -> Bool
B.null ByteString
entId = NtfResponse -> Either ErrorType NtfResponse
forall a b. b -> Either a b
Right NtfResponse
cmd
        | Bool
otherwise = ErrorType -> Either ErrorType NtfResponse
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType NtfResponse)
-> ErrorType -> Either ErrorType NtfResponse
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH

data SMPQueueNtf = SMPQueueNtf
  { SMPQueueNtf -> SMPServer
smpServer :: SMPServer,
    SMPQueueNtf -> NtfTokenId
notifierId :: NotifierId
  }
  deriving (SMPQueueNtf -> SMPQueueNtf -> Bool
(SMPQueueNtf -> SMPQueueNtf -> Bool)
-> (SMPQueueNtf -> SMPQueueNtf -> Bool) -> Eq SMPQueueNtf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPQueueNtf -> SMPQueueNtf -> Bool
== :: SMPQueueNtf -> SMPQueueNtf -> Bool
$c/= :: SMPQueueNtf -> SMPQueueNtf -> Bool
/= :: SMPQueueNtf -> SMPQueueNtf -> Bool
Eq, Eq SMPQueueNtf
Eq SMPQueueNtf =>
(SMPQueueNtf -> SMPQueueNtf -> Ordering)
-> (SMPQueueNtf -> SMPQueueNtf -> Bool)
-> (SMPQueueNtf -> SMPQueueNtf -> Bool)
-> (SMPQueueNtf -> SMPQueueNtf -> Bool)
-> (SMPQueueNtf -> SMPQueueNtf -> Bool)
-> (SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf)
-> (SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf)
-> Ord SMPQueueNtf
SMPQueueNtf -> SMPQueueNtf -> Bool
SMPQueueNtf -> SMPQueueNtf -> Ordering
SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SMPQueueNtf -> SMPQueueNtf -> Ordering
compare :: SMPQueueNtf -> SMPQueueNtf -> Ordering
$c< :: SMPQueueNtf -> SMPQueueNtf -> Bool
< :: SMPQueueNtf -> SMPQueueNtf -> Bool
$c<= :: SMPQueueNtf -> SMPQueueNtf -> Bool
<= :: SMPQueueNtf -> SMPQueueNtf -> Bool
$c> :: SMPQueueNtf -> SMPQueueNtf -> Bool
> :: SMPQueueNtf -> SMPQueueNtf -> Bool
$c>= :: SMPQueueNtf -> SMPQueueNtf -> Bool
>= :: SMPQueueNtf -> SMPQueueNtf -> Bool
$cmax :: SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf
max :: SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf
$cmin :: SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf
min :: SMPQueueNtf -> SMPQueueNtf -> SMPQueueNtf
Ord, Int -> SMPQueueNtf -> ShowS
[SMPQueueNtf] -> ShowS
SMPQueueNtf -> String
(Int -> SMPQueueNtf -> ShowS)
-> (SMPQueueNtf -> String)
-> ([SMPQueueNtf] -> ShowS)
-> Show SMPQueueNtf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPQueueNtf -> ShowS
showsPrec :: Int -> SMPQueueNtf -> ShowS
$cshow :: SMPQueueNtf -> String
show :: SMPQueueNtf -> String
$cshowList :: [SMPQueueNtf] -> ShowS
showList :: [SMPQueueNtf] -> ShowS
Show)

instance Encoding SMPQueueNtf where
  smpEncode :: SMPQueueNtf -> ByteString
smpEncode SMPQueueNtf {SMPServer
smpServer :: SMPQueueNtf -> SMPServer
smpServer :: SMPServer
smpServer, NtfTokenId
notifierId :: SMPQueueNtf -> NtfTokenId
notifierId :: NtfTokenId
notifierId} = (SMPServer, NtfTokenId) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (SMPServer
smpServer, NtfTokenId
notifierId)
  smpP :: Parser ByteString SMPQueueNtf
smpP = do
    SMPServer
smpServer <- SMPServer -> SMPServer
updateSMPServerHosts (SMPServer -> SMPServer)
-> Parser ByteString SMPServer -> Parser ByteString SMPServer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SMPServer
forall a. Encoding a => Parser a
smpP
    NtfTokenId
notifierId <- Parser ByteString NtfTokenId
forall a. Encoding a => Parser a
smpP
    SMPQueueNtf -> Parser ByteString SMPQueueNtf
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPQueueNtf {SMPServer
smpServer :: SMPServer
smpServer :: SMPServer
smpServer, NtfTokenId
notifierId :: NtfTokenId
notifierId :: NtfTokenId
notifierId}

instance StrEncoding SMPQueueNtf where
  strEncode :: SMPQueueNtf -> ByteString
strEncode SMPQueueNtf {SMPServer
smpServer :: SMPQueueNtf -> SMPServer
smpServer :: SMPServer
smpServer, NtfTokenId
notifierId :: SMPQueueNtf -> NtfTokenId
notifierId :: NtfTokenId
notifierId} = SMPServer -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SMPServer
smpServer ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> NtfTokenId -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode NtfTokenId
notifierId
  strP :: Parser ByteString SMPQueueNtf
strP = do
    SMPServer
smpServer <- SMPServer -> SMPServer
updateSMPServerHosts (SMPServer -> SMPServer)
-> Parser ByteString SMPServer -> Parser ByteString SMPServer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SMPServer
forall a. StrEncoding a => Parser a
strP
    NtfTokenId
notifierId <- Char -> Parser Char
A.char Char
'/' Parser Char
-> Parser ByteString NtfTokenId -> Parser ByteString NtfTokenId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString NtfTokenId
forall a. StrEncoding a => Parser a
strP
    SMPQueueNtf -> Parser ByteString SMPQueueNtf
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPQueueNtf {SMPServer
smpServer :: SMPServer
smpServer :: SMPServer
smpServer, NtfTokenId
notifierId :: NtfTokenId
notifierId :: NtfTokenId
notifierId}

data PushProvider
  = PPApnsDev -- provider for Apple development environment
  | PPApnsProd -- production environment, including TestFlight
  | PPApnsTest -- used for tests, to use APNS mock server
  | PPApnsNull -- used to test servers from the client - does not communicate with APNS
  deriving (PushProvider -> PushProvider -> Bool
(PushProvider -> PushProvider -> Bool)
-> (PushProvider -> PushProvider -> Bool) -> Eq PushProvider
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PushProvider -> PushProvider -> Bool
== :: PushProvider -> PushProvider -> Bool
$c/= :: PushProvider -> PushProvider -> Bool
/= :: PushProvider -> PushProvider -> Bool
Eq, Eq PushProvider
Eq PushProvider =>
(PushProvider -> PushProvider -> Ordering)
-> (PushProvider -> PushProvider -> Bool)
-> (PushProvider -> PushProvider -> Bool)
-> (PushProvider -> PushProvider -> Bool)
-> (PushProvider -> PushProvider -> Bool)
-> (PushProvider -> PushProvider -> PushProvider)
-> (PushProvider -> PushProvider -> PushProvider)
-> Ord PushProvider
PushProvider -> PushProvider -> Bool
PushProvider -> PushProvider -> Ordering
PushProvider -> PushProvider -> PushProvider
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PushProvider -> PushProvider -> Ordering
compare :: PushProvider -> PushProvider -> Ordering
$c< :: PushProvider -> PushProvider -> Bool
< :: PushProvider -> PushProvider -> Bool
$c<= :: PushProvider -> PushProvider -> Bool
<= :: PushProvider -> PushProvider -> Bool
$c> :: PushProvider -> PushProvider -> Bool
> :: PushProvider -> PushProvider -> Bool
$c>= :: PushProvider -> PushProvider -> Bool
>= :: PushProvider -> PushProvider -> Bool
$cmax :: PushProvider -> PushProvider -> PushProvider
max :: PushProvider -> PushProvider -> PushProvider
$cmin :: PushProvider -> PushProvider -> PushProvider
min :: PushProvider -> PushProvider -> PushProvider
Ord, Int -> PushProvider -> ShowS
[PushProvider] -> ShowS
PushProvider -> String
(Int -> PushProvider -> ShowS)
-> (PushProvider -> String)
-> ([PushProvider] -> ShowS)
-> Show PushProvider
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PushProvider -> ShowS
showsPrec :: Int -> PushProvider -> ShowS
$cshow :: PushProvider -> String
show :: PushProvider -> String
$cshowList :: [PushProvider] -> ShowS
showList :: [PushProvider] -> ShowS
Show)

instance Encoding PushProvider where
  smpEncode :: PushProvider -> ByteString
smpEncode = \case
    PushProvider
PPApnsDev -> ByteString
"AD"
    PushProvider
PPApnsProd -> ByteString
"AP"
    PushProvider
PPApnsTest -> ByteString
"AT"
    PushProvider
PPApnsNull -> ByteString
"AN"
  smpP :: Parser PushProvider
smpP =
    Int -> Parser ByteString ByteString
A.take Int
2 Parser ByteString ByteString
-> (ByteString -> Parser PushProvider) -> Parser PushProvider
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"AD" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsDev
      ByteString
"AP" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsProd
      ByteString
"AT" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsTest
      ByteString
"AN" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsNull
      ByteString
_ -> String -> Parser PushProvider
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad PushProvider"

instance StrEncoding PushProvider where
  strEncode :: PushProvider -> ByteString
strEncode = \case
    PushProvider
PPApnsDev -> ByteString
"apns_dev"
    PushProvider
PPApnsProd -> ByteString
"apns_prod"
    PushProvider
PPApnsTest -> ByteString
"apns_test"
    PushProvider
PPApnsNull -> ByteString
"apns_null"
  strP :: Parser PushProvider
strP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser PushProvider) -> Parser PushProvider
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"apns_dev" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsDev
      ByteString
"apns_prod" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsProd
      ByteString
"apns_test" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsTest
      ByteString
"apns_null" -> PushProvider -> Parser PushProvider
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PushProvider
PPApnsNull
      ByteString
_ -> String -> Parser PushProvider
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad PushProvider"

instance FromField PushProvider where fromField :: FieldParser PushProvider
fromField = (Text -> Maybe PushProvider) -> FieldParser PushProvider
forall a. Typeable a => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ ((Text -> Maybe PushProvider) -> FieldParser PushProvider)
-> (Text -> Maybe PushProvider) -> FieldParser PushProvider
forall a b. (a -> b) -> a -> b
$ Either String PushProvider -> Maybe PushProvider
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String PushProvider -> Maybe PushProvider)
-> (Text -> Either String PushProvider)
-> Text
-> Maybe PushProvider
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String PushProvider
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String PushProvider)
-> (Text -> ByteString) -> Text -> Either String PushProvider
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

instance ToField PushProvider where toField :: PushProvider -> SQLData
toField = Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Text -> SQLData)
-> (PushProvider -> Text) -> PushProvider -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (PushProvider -> ByteString) -> PushProvider -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PushProvider -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode

data DeviceToken = DeviceToken PushProvider ByteString
  deriving (DeviceToken -> DeviceToken -> Bool
(DeviceToken -> DeviceToken -> Bool)
-> (DeviceToken -> DeviceToken -> Bool) -> Eq DeviceToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeviceToken -> DeviceToken -> Bool
== :: DeviceToken -> DeviceToken -> Bool
$c/= :: DeviceToken -> DeviceToken -> Bool
/= :: DeviceToken -> DeviceToken -> Bool
Eq, Eq DeviceToken
Eq DeviceToken =>
(DeviceToken -> DeviceToken -> Ordering)
-> (DeviceToken -> DeviceToken -> Bool)
-> (DeviceToken -> DeviceToken -> Bool)
-> (DeviceToken -> DeviceToken -> Bool)
-> (DeviceToken -> DeviceToken -> Bool)
-> (DeviceToken -> DeviceToken -> DeviceToken)
-> (DeviceToken -> DeviceToken -> DeviceToken)
-> Ord DeviceToken
DeviceToken -> DeviceToken -> Bool
DeviceToken -> DeviceToken -> Ordering
DeviceToken -> DeviceToken -> DeviceToken
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeviceToken -> DeviceToken -> Ordering
compare :: DeviceToken -> DeviceToken -> Ordering
$c< :: DeviceToken -> DeviceToken -> Bool
< :: DeviceToken -> DeviceToken -> Bool
$c<= :: DeviceToken -> DeviceToken -> Bool
<= :: DeviceToken -> DeviceToken -> Bool
$c> :: DeviceToken -> DeviceToken -> Bool
> :: DeviceToken -> DeviceToken -> Bool
$c>= :: DeviceToken -> DeviceToken -> Bool
>= :: DeviceToken -> DeviceToken -> Bool
$cmax :: DeviceToken -> DeviceToken -> DeviceToken
max :: DeviceToken -> DeviceToken -> DeviceToken
$cmin :: DeviceToken -> DeviceToken -> DeviceToken
min :: DeviceToken -> DeviceToken -> DeviceToken
Ord, Int -> DeviceToken -> ShowS
[DeviceToken] -> ShowS
DeviceToken -> String
(Int -> DeviceToken -> ShowS)
-> (DeviceToken -> String)
-> ([DeviceToken] -> ShowS)
-> Show DeviceToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeviceToken -> ShowS
showsPrec :: Int -> DeviceToken -> ShowS
$cshow :: DeviceToken -> String
show :: DeviceToken -> String
$cshowList :: [DeviceToken] -> ShowS
showList :: [DeviceToken] -> ShowS
Show)

instance Encoding DeviceToken where
  smpEncode :: DeviceToken -> ByteString
smpEncode (DeviceToken PushProvider
p ByteString
t) = (PushProvider, ByteString) -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode (PushProvider
p, ByteString
t)
  smpP :: Parser ByteString DeviceToken
smpP = PushProvider -> ByteString -> DeviceToken
DeviceToken (PushProvider -> ByteString -> DeviceToken)
-> Parser PushProvider
-> Parser ByteString (ByteString -> DeviceToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PushProvider
forall a. Encoding a => Parser a
smpP Parser ByteString (ByteString -> DeviceToken)
-> Parser ByteString ByteString -> Parser ByteString DeviceToken
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
forall a. Encoding a => Parser a
smpP

instance StrEncoding DeviceToken where
  strEncode :: DeviceToken -> ByteString
strEncode (DeviceToken PushProvider
p ByteString
t) = PushProvider -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode PushProvider
p ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t
  strP :: Parser ByteString DeviceToken
strP = Parser ByteString DeviceToken
nullToken Parser ByteString DeviceToken
-> Parser ByteString DeviceToken -> Parser ByteString DeviceToken
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString DeviceToken
hexToken
    where
      nullToken :: Parser ByteString DeviceToken
nullToken = Parser ByteString ByteString
"apns_null test_ntf_token" Parser ByteString ByteString
-> DeviceToken -> Parser ByteString DeviceToken
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PushProvider -> ByteString -> DeviceToken
DeviceToken PushProvider
PPApnsNull ByteString
"test_ntf_token"
      hexToken :: Parser ByteString DeviceToken
hexToken = PushProvider -> ByteString -> DeviceToken
DeviceToken (PushProvider -> ByteString -> DeviceToken)
-> Parser PushProvider
-> Parser ByteString (ByteString -> DeviceToken)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PushProvider
forall a. StrEncoding a => Parser a
strP Parser ByteString (ByteString -> DeviceToken)
-> Parser Char -> Parser ByteString (ByteString -> DeviceToken)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char
A.space Parser ByteString (ByteString -> DeviceToken)
-> Parser ByteString ByteString -> Parser ByteString DeviceToken
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
hexStringP
      hexStringP :: Parser ByteString ByteString
hexStringP =
        (Char -> Bool) -> Parser ByteString ByteString
A.takeWhile (Char -> ByteString -> Bool
`B.elem` ByteString
"0123456789abcdef") Parser ByteString ByteString
-> (ByteString -> Parser ByteString ByteString)
-> Parser ByteString ByteString
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
s ->
          if Int -> Bool
forall a. Integral a => a -> Bool
even (ByteString -> Int
B.length ByteString
s) then ByteString -> Parser ByteString ByteString
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s else String -> Parser ByteString ByteString
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"odd number of hex characters"

instance ToJSON DeviceToken where
  toEncoding :: DeviceToken -> Encoding
toEncoding (DeviceToken PushProvider
pp ByteString
t) = Series -> Encoding
J.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Key
"pushProvider" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeLatin1 (PushProvider -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode PushProvider
pp) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"token" Key -> Text -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeLatin1 ByteString
t
  toJSON :: DeviceToken -> Value
toJSON (DeviceToken PushProvider
pp ByteString
t) = [Pair] -> Value
J.object [Key
"pushProvider" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeLatin1 (PushProvider -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode PushProvider
pp), Key
"token" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeLatin1 ByteString
t]

instance FromJSON DeviceToken where
  parseJSON :: Value -> Parser DeviceToken
parseJSON = String
-> (Object -> Parser DeviceToken) -> Value -> Parser DeviceToken
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"DeviceToken" ((Object -> Parser DeviceToken) -> Value -> Parser DeviceToken)
-> (Object -> Parser DeviceToken) -> Value -> Parser DeviceToken
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    PushProvider
pp <- ByteString -> Either String PushProvider
forall a. StrEncoding a => ByteString -> Either String a
strDecode (ByteString -> Either String PushProvider)
-> (Text -> ByteString) -> Text -> Either String PushProvider
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> Either String PushProvider)
-> Parser Text -> Parser PushProvider
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pushProvider"
    ByteString
t <- Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Parser Text -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"token"
    DeviceToken -> Parser DeviceToken
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeviceToken -> Parser DeviceToken)
-> DeviceToken -> Parser DeviceToken
forall a b. (a -> b) -> a -> b
$ PushProvider -> ByteString -> DeviceToken
DeviceToken PushProvider
pp ByteString
t

-- List of PNMessageData uses semicolon-separated encoding instead of strEncode,
-- because strEncode of NonEmpty list uses comma for separator,
-- and encoding of PNMessageData's smpQueue has comma in list of hosts
encodePNMessages :: NonEmpty PNMessageData -> ByteString
encodePNMessages :: NonEmpty PNMessageData -> ByteString
encodePNMessages = ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" ([ByteString] -> ByteString)
-> (NonEmpty PNMessageData -> [ByteString])
-> NonEmpty PNMessageData
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PNMessageData -> ByteString) -> [PNMessageData] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map PNMessageData -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode ([PNMessageData] -> [ByteString])
-> (NonEmpty PNMessageData -> [PNMessageData])
-> NonEmpty PNMessageData
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PNMessageData -> [PNMessageData]
forall a. NonEmpty a -> [a]
L.toList

pnMessagesP :: A.Parser (NonEmpty PNMessageData)
pnMessagesP :: Parser (NonEmpty PNMessageData)
pnMessagesP = [PNMessageData] -> NonEmpty PNMessageData
forall a. HasCallStack => [a] -> NonEmpty a
L.fromList ([PNMessageData] -> NonEmpty PNMessageData)
-> Parser ByteString [PNMessageData]
-> Parser (NonEmpty PNMessageData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PNMessageData
forall a. StrEncoding a => Parser a
strP Parser PNMessageData
-> Parser Char -> Parser ByteString [PNMessageData]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`A.sepBy1` Char -> Parser Char
A.char Char
';'

data PNMessageData = PNMessageData
  { PNMessageData -> SMPQueueNtf
smpQueue :: SMPQueueNtf,
    PNMessageData -> SystemTime
ntfTs :: SystemTime,
    PNMessageData -> CbNonce
nmsgNonce :: C.CbNonce,
    PNMessageData -> ByteString
encNMsgMeta :: EncNMsgMeta
  }
  deriving (Int -> PNMessageData -> ShowS
[PNMessageData] -> ShowS
PNMessageData -> String
(Int -> PNMessageData -> ShowS)
-> (PNMessageData -> String)
-> ([PNMessageData] -> ShowS)
-> Show PNMessageData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PNMessageData -> ShowS
showsPrec :: Int -> PNMessageData -> ShowS
$cshow :: PNMessageData -> String
show :: PNMessageData -> String
$cshowList :: [PNMessageData] -> ShowS
showList :: [PNMessageData] -> ShowS
Show)

instance StrEncoding PNMessageData where
  strEncode :: PNMessageData -> ByteString
strEncode PNMessageData {SMPQueueNtf
smpQueue :: PNMessageData -> SMPQueueNtf
smpQueue :: SMPQueueNtf
smpQueue, SystemTime
ntfTs :: PNMessageData -> SystemTime
ntfTs :: SystemTime
ntfTs, CbNonce
nmsgNonce :: PNMessageData -> CbNonce
nmsgNonce :: CbNonce
nmsgNonce, ByteString
encNMsgMeta :: PNMessageData -> ByteString
encNMsgMeta :: ByteString
encNMsgMeta} =
    (SMPQueueNtf, SystemTime, CbNonce, ByteString) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (SMPQueueNtf
smpQueue, SystemTime
ntfTs, CbNonce
nmsgNonce, ByteString
encNMsgMeta)
  strP :: Parser PNMessageData
strP = do
    (SMPQueueNtf
smpQueue, SystemTime
ntfTs, CbNonce
nmsgNonce, ByteString
encNMsgMeta) <- Parser (SMPQueueNtf, SystemTime, CbNonce, ByteString)
forall a. StrEncoding a => Parser a
strP
    PNMessageData -> Parser PNMessageData
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PNMessageData {SMPQueueNtf
smpQueue :: SMPQueueNtf
smpQueue :: SMPQueueNtf
smpQueue, SystemTime
ntfTs :: SystemTime
ntfTs :: SystemTime
ntfTs, CbNonce
nmsgNonce :: CbNonce
nmsgNonce :: CbNonce
nmsgNonce, ByteString
encNMsgMeta :: ByteString
encNMsgMeta :: ByteString
encNMsgMeta}

type NtfEntityId = EntityId

type NtfSubscriptionId = NtfEntityId

type NtfTokenId = NtfEntityId

data NtfSubStatus
  = -- | state after SNEW
    NSNew
  | -- | pending connection/subscription to SMP server
    NSPending
  | -- | connected and subscribed to SMP server
    NSActive
  | -- | disconnected/unsubscribed from SMP server
    NSInactive
  | -- | END received
    NSEnd
  | -- | DELD received (connection was deleted)
    NSDeleted
  | -- | SMP AUTH error
    NSAuth
  | -- | SMP SERVICE error - rejected service signature on individual subscriptions
    NSService
  | -- | SMP error other than AUTH
    NSErr ByteString
  deriving (NtfSubStatus -> NtfSubStatus -> Bool
(NtfSubStatus -> NtfSubStatus -> Bool)
-> (NtfSubStatus -> NtfSubStatus -> Bool) -> Eq NtfSubStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NtfSubStatus -> NtfSubStatus -> Bool
== :: NtfSubStatus -> NtfSubStatus -> Bool
$c/= :: NtfSubStatus -> NtfSubStatus -> Bool
/= :: NtfSubStatus -> NtfSubStatus -> Bool
Eq, Eq NtfSubStatus
Eq NtfSubStatus =>
(NtfSubStatus -> NtfSubStatus -> Ordering)
-> (NtfSubStatus -> NtfSubStatus -> Bool)
-> (NtfSubStatus -> NtfSubStatus -> Bool)
-> (NtfSubStatus -> NtfSubStatus -> Bool)
-> (NtfSubStatus -> NtfSubStatus -> Bool)
-> (NtfSubStatus -> NtfSubStatus -> NtfSubStatus)
-> (NtfSubStatus -> NtfSubStatus -> NtfSubStatus)
-> Ord NtfSubStatus
NtfSubStatus -> NtfSubStatus -> Bool
NtfSubStatus -> NtfSubStatus -> Ordering
NtfSubStatus -> NtfSubStatus -> NtfSubStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NtfSubStatus -> NtfSubStatus -> Ordering
compare :: NtfSubStatus -> NtfSubStatus -> Ordering
$c< :: NtfSubStatus -> NtfSubStatus -> Bool
< :: NtfSubStatus -> NtfSubStatus -> Bool
$c<= :: NtfSubStatus -> NtfSubStatus -> Bool
<= :: NtfSubStatus -> NtfSubStatus -> Bool
$c> :: NtfSubStatus -> NtfSubStatus -> Bool
> :: NtfSubStatus -> NtfSubStatus -> Bool
$c>= :: NtfSubStatus -> NtfSubStatus -> Bool
>= :: NtfSubStatus -> NtfSubStatus -> Bool
$cmax :: NtfSubStatus -> NtfSubStatus -> NtfSubStatus
max :: NtfSubStatus -> NtfSubStatus -> NtfSubStatus
$cmin :: NtfSubStatus -> NtfSubStatus -> NtfSubStatus
min :: NtfSubStatus -> NtfSubStatus -> NtfSubStatus
Ord, Int -> NtfSubStatus -> ShowS
[NtfSubStatus] -> ShowS
NtfSubStatus -> String
(Int -> NtfSubStatus -> ShowS)
-> (NtfSubStatus -> String)
-> ([NtfSubStatus] -> ShowS)
-> Show NtfSubStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfSubStatus -> ShowS
showsPrec :: Int -> NtfSubStatus -> ShowS
$cshow :: NtfSubStatus -> String
show :: NtfSubStatus -> String
$cshowList :: [NtfSubStatus] -> ShowS
showList :: [NtfSubStatus] -> ShowS
Show)

ntfShouldSubscribe :: NtfSubStatus -> Bool
ntfShouldSubscribe :: NtfSubStatus -> Bool
ntfShouldSubscribe = \case
  NtfSubStatus
NSNew -> Bool
True
  NtfSubStatus
NSPending -> Bool
True
  NtfSubStatus
NSActive -> Bool
True
  NtfSubStatus
NSInactive -> Bool
True
  NtfSubStatus
NSEnd -> Bool
False
  NtfSubStatus
NSDeleted -> Bool
False
  NtfSubStatus
NSAuth -> Bool
False
  NtfSubStatus
NSService -> Bool
True
  NSErr ByteString
_ -> Bool
False

instance Encoding NtfSubStatus where
  smpEncode :: NtfSubStatus -> ByteString
smpEncode = \case
    NtfSubStatus
NSNew -> ByteString
"NEW"
    NtfSubStatus
NSPending -> ByteString
"PENDING" -- e.g. after SMP server disconnect/timeout while ntf server is retrying to connect
    NtfSubStatus
NSActive -> ByteString
"ACTIVE"
    NtfSubStatus
NSInactive -> ByteString
"INACTIVE"
    NtfSubStatus
NSEnd -> ByteString
"END"
    NtfSubStatus
NSDeleted -> ByteString
"DELETED"
    NtfSubStatus
NSAuth -> ByteString
"AUTH"
    NtfSubStatus
NSService -> ByteString
"SERVICE"
    NSErr ByteString
err -> ByteString
"ERR " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
err
  smpP :: Parser ByteString NtfSubStatus
smpP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser ByteString NtfSubStatus)
-> Parser ByteString NtfSubStatus
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"NEW" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSNew
      ByteString
"PENDING" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSPending
      ByteString
"ACTIVE" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSActive
      ByteString
"INACTIVE" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSInactive
      ByteString
"END" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSEnd
      ByteString
"DELETED" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSDeleted
      ByteString
"AUTH" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSAuth
      ByteString
"SERVICE" -> NtfSubStatus -> Parser ByteString NtfSubStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfSubStatus
NSService
      ByteString
"ERR" -> ByteString -> NtfSubStatus
NSErr (ByteString -> NtfSubStatus)
-> Parser ByteString ByteString -> Parser ByteString NtfSubStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Char
A.space Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
A.takeByteString)
      ByteString
_ -> String -> Parser ByteString NtfSubStatus
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad NtfSubStatus"

instance StrEncoding NtfSubStatus where
  strEncode :: NtfSubStatus -> ByteString
strEncode = NtfSubStatus -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode
  {-# INLINE strEncode #-}
  strP :: Parser ByteString NtfSubStatus
strP = Parser ByteString NtfSubStatus
forall a. Encoding a => Parser a
smpP
  {-# INLINE strP #-}

data NtfTknStatus
  = -- | Token created in DB
    NTNew
  | -- | state after registration (TNEW)
    NTRegistered
  | -- | if initial notification failed (push provider error) or verification failed
    NTInvalid (Maybe NTInvalidReason)
  | -- | Token confirmed via notification (accepted by push provider or verification code received by client)
    NTConfirmed
  | -- | after successful verification (TVFY)
    NTActive
  | -- | after it is no longer valid (push provider error)
    NTExpired
  deriving (NtfTknStatus -> NtfTknStatus -> Bool
(NtfTknStatus -> NtfTknStatus -> Bool)
-> (NtfTknStatus -> NtfTknStatus -> Bool) -> Eq NtfTknStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NtfTknStatus -> NtfTknStatus -> Bool
== :: NtfTknStatus -> NtfTknStatus -> Bool
$c/= :: NtfTknStatus -> NtfTknStatus -> Bool
/= :: NtfTknStatus -> NtfTknStatus -> Bool
Eq, Int -> NtfTknStatus -> ShowS
[NtfTknStatus] -> ShowS
NtfTknStatus -> String
(Int -> NtfTknStatus -> ShowS)
-> (NtfTknStatus -> String)
-> ([NtfTknStatus] -> ShowS)
-> Show NtfTknStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfTknStatus -> ShowS
showsPrec :: Int -> NtfTknStatus -> ShowS
$cshow :: NtfTknStatus -> String
show :: NtfTknStatus -> String
$cshowList :: [NtfTknStatus] -> ShowS
showList :: [NtfTknStatus] -> ShowS
Show)

allowTokenVerification :: NtfTknStatus -> Bool
allowTokenVerification :: NtfTknStatus -> Bool
allowTokenVerification = \case
  NtfTknStatus
NTNew -> Bool
False
  NtfTknStatus
NTRegistered -> Bool
True
  NTInvalid Maybe NTInvalidReason
_ -> Bool
False
  NtfTknStatus
NTConfirmed -> Bool
True
  NtfTknStatus
NTActive -> Bool
True
  NtfTknStatus
NTExpired -> Bool
False

allowNtfSubCommands :: NtfTknStatus -> Bool
allowNtfSubCommands :: NtfTknStatus -> Bool
allowNtfSubCommands = \case
  NtfTknStatus
NTNew -> Bool
False
  NtfTknStatus
NTRegistered -> Bool
False
  -- TODO we could have separate statuses to show whether it became invalid
  -- after verification (allow commands) or before (do not allow)
  NTInvalid Maybe NTInvalidReason
_ -> Bool
True
  NtfTknStatus
NTConfirmed -> Bool
False
  NtfTknStatus
NTActive -> Bool
True
  NtfTknStatus
NTExpired -> Bool
True

instance Encoding NtfTknStatus where
  smpEncode :: NtfTknStatus -> ByteString
smpEncode = \case
    NtfTknStatus
NTNew -> ByteString
"NEW"
    NtfTknStatus
NTRegistered -> ByteString
"REGISTERED"
    NTInvalid Maybe NTInvalidReason
r_ -> ByteString
"INVALID" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (NTInvalidReason -> ByteString)
-> Maybe NTInvalidReason
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" (\NTInvalidReason
r -> Char
',' Char -> ByteString -> ByteString
`B.cons` NTInvalidReason -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode NTInvalidReason
r) Maybe NTInvalidReason
r_
    NtfTknStatus
NTConfirmed -> ByteString
"CONFIRMED"
    NtfTknStatus
NTActive -> ByteString
"ACTIVE"
    NtfTknStatus
NTExpired -> ByteString
"EXPIRED"
  smpP :: Parser ByteString NtfTknStatus
smpP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') Parser ByteString ByteString
-> (ByteString -> Parser ByteString NtfTknStatus)
-> Parser ByteString NtfTknStatus
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"NEW" -> NtfTknStatus -> Parser ByteString NtfTknStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTNew
      ByteString
"REGISTERED" -> NtfTknStatus -> Parser ByteString NtfTknStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTRegistered
      ByteString
"INVALID" -> Maybe NTInvalidReason -> NtfTknStatus
NTInvalid (Maybe NTInvalidReason -> NtfTknStatus)
-> Parser ByteString (Maybe NTInvalidReason)
-> Parser ByteString NtfTknStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString NTInvalidReason
-> Parser ByteString (Maybe NTInvalidReason)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Char
A.char Char
',' Parser Char
-> Parser ByteString NTInvalidReason
-> Parser ByteString NTInvalidReason
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString NTInvalidReason
forall a. StrEncoding a => Parser a
strP)
      ByteString
"CONFIRMED" -> NtfTknStatus -> Parser ByteString NtfTknStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTConfirmed
      ByteString
"ACTIVE" -> NtfTknStatus -> Parser ByteString NtfTknStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTActive
      ByteString
"EXPIRED" -> NtfTknStatus -> Parser ByteString NtfTknStatus
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfTknStatus
NTExpired
      ByteString
_ -> String -> Parser ByteString NtfTknStatus
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad NtfTknStatus"

instance StrEncoding NTInvalidReason where
  strEncode :: NTInvalidReason -> ByteString
strEncode = NTInvalidReason -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode
  strP :: Parser ByteString NTInvalidReason
strP = Parser ByteString NTInvalidReason
forall a. Encoding a => Parser a
smpP

data NTInvalidReason = NTIRBadToken | NTIRTokenNotForTopic | NTIRExpiredToken | NTIRUnregistered
  deriving (NTInvalidReason -> NTInvalidReason -> Bool
(NTInvalidReason -> NTInvalidReason -> Bool)
-> (NTInvalidReason -> NTInvalidReason -> Bool)
-> Eq NTInvalidReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NTInvalidReason -> NTInvalidReason -> Bool
== :: NTInvalidReason -> NTInvalidReason -> Bool
$c/= :: NTInvalidReason -> NTInvalidReason -> Bool
/= :: NTInvalidReason -> NTInvalidReason -> Bool
Eq, Int -> NTInvalidReason -> ShowS
[NTInvalidReason] -> ShowS
NTInvalidReason -> String
(Int -> NTInvalidReason -> ShowS)
-> (NTInvalidReason -> String)
-> ([NTInvalidReason] -> ShowS)
-> Show NTInvalidReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NTInvalidReason -> ShowS
showsPrec :: Int -> NTInvalidReason -> ShowS
$cshow :: NTInvalidReason -> String
show :: NTInvalidReason -> String
$cshowList :: [NTInvalidReason] -> ShowS
showList :: [NTInvalidReason] -> ShowS
Show)

instance Encoding NTInvalidReason where
  smpEncode :: NTInvalidReason -> ByteString
smpEncode = \case
    NTInvalidReason
NTIRBadToken -> ByteString
"BAD"
    NTInvalidReason
NTIRTokenNotForTopic -> ByteString
"TOPIC"
    NTInvalidReason
NTIRExpiredToken -> ByteString
"EXPIRED"
    NTInvalidReason
NTIRUnregistered -> ByteString
"UNREGISTERED"
  smpP :: Parser ByteString NTInvalidReason
smpP =
    (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> (ByteString -> Parser ByteString NTInvalidReason)
-> Parser ByteString NTInvalidReason
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ByteString
"BAD" -> NTInvalidReason -> Parser ByteString NTInvalidReason
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NTInvalidReason
NTIRBadToken
      ByteString
"TOPIC" -> NTInvalidReason -> Parser ByteString NTInvalidReason
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NTInvalidReason
NTIRTokenNotForTopic
      ByteString
"EXPIRED" -> NTInvalidReason -> Parser ByteString NTInvalidReason
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NTInvalidReason
NTIRExpiredToken
      ByteString
"UNREGISTERED" -> NTInvalidReason -> Parser ByteString NTInvalidReason
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NTInvalidReason
NTIRUnregistered
      ByteString
_ -> String -> Parser ByteString NTInvalidReason
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad NTInvalidReason"

instance StrEncoding NtfTknStatus where
  strEncode :: NtfTknStatus -> ByteString
strEncode = NtfTknStatus -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode
  strP :: Parser ByteString NtfTknStatus
strP = Parser ByteString NtfTknStatus
forall a. Encoding a => Parser a
smpP

instance FromField NtfTknStatus where fromField :: FieldParser NtfTknStatus
fromField = (Text -> Maybe NtfTknStatus) -> FieldParser NtfTknStatus
forall a. Typeable a => (Text -> Maybe a) -> Field -> Ok a
fromTextField_ ((Text -> Maybe NtfTknStatus) -> FieldParser NtfTknStatus)
-> (Text -> Maybe NtfTknStatus) -> FieldParser NtfTknStatus
forall a b. (a -> b) -> a -> b
$ (String -> Maybe NtfTknStatus)
-> (NtfTknStatus -> Maybe NtfTknStatus)
-> Either String NtfTknStatus
-> Maybe NtfTknStatus
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe NtfTknStatus -> String -> Maybe NtfTknStatus
forall a b. a -> b -> a
const Maybe NtfTknStatus
forall a. Maybe a
Nothing) NtfTknStatus -> Maybe NtfTknStatus
forall a. a -> Maybe a
Just (Either String NtfTknStatus -> Maybe NtfTknStatus)
-> (Text -> Either String NtfTknStatus)
-> Text
-> Maybe NtfTknStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String NtfTknStatus
forall a. Encoding a => ByteString -> Either String a
smpDecode (ByteString -> Either String NtfTknStatus)
-> (Text -> ByteString) -> Text -> Either String NtfTknStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

instance ToField NtfTknStatus where toField :: NtfTknStatus -> SQLData
toField = Text -> SQLData
forall a. ToField a => a -> SQLData
toField (Text -> SQLData)
-> (NtfTknStatus -> Text) -> NtfTknStatus -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (NtfTknStatus -> ByteString) -> NtfTknStatus -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtfTknStatus -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance ToJSON NtfTknStatus where
  toEncoding :: NtfTknStatus -> Encoding
toEncoding = Text -> Encoding
forall a. Text -> Encoding' a
JE.text (Text -> Encoding)
-> (NtfTknStatus -> Text) -> NtfTknStatus -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (NtfTknStatus -> ByteString) -> NtfTknStatus -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtfTknStatus -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode
  toJSON :: NtfTknStatus -> Value
toJSON = Text -> Value
J.String (Text -> Value) -> (NtfTknStatus -> Text) -> NtfTknStatus -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeLatin1 (ByteString -> Text)
-> (NtfTknStatus -> ByteString) -> NtfTknStatus -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtfTknStatus -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode

instance FromJSON NtfTknStatus where
  parseJSON :: Value -> Parser NtfTknStatus
parseJSON = String
-> (Text -> Parser NtfTknStatus) -> Value -> Parser NtfTknStatus
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"NtfTknStatus" ((Text -> Parser NtfTknStatus) -> Value -> Parser NtfTknStatus)
-> (Text -> Parser NtfTknStatus) -> Value -> Parser NtfTknStatus
forall a b. (a -> b) -> a -> b
$ (String -> Parser NtfTknStatus)
-> (NtfTknStatus -> Parser NtfTknStatus)
-> Either String NtfTknStatus
-> Parser NtfTknStatus
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser NtfTknStatus
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail NtfTknStatus -> Parser NtfTknStatus
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String NtfTknStatus -> Parser NtfTknStatus)
-> (Text -> Either String NtfTknStatus)
-> Text
-> Parser NtfTknStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String NtfTknStatus
forall a. Encoding a => ByteString -> Either String a
smpDecode (ByteString -> Either String NtfTknStatus)
-> (Text -> ByteString) -> Text -> Either String NtfTknStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

checkEntity :: forall t e e'. (NtfEntityI e, NtfEntityI e') => t e' -> Either String (t e)
checkEntity :: forall (t :: NtfEntity -> *) (e :: NtfEntity) (e' :: NtfEntity).
(NtfEntityI e, NtfEntityI e') =>
t e' -> Either String (t e)
checkEntity t e'
c = case SNtfEntity e -> SNtfEntity e' -> Maybe (e :~: e')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: NtfEntity) (b :: NtfEntity).
SNtfEntity a -> SNtfEntity b -> Maybe (a :~: b)
testEquality (forall (e :: NtfEntity). NtfEntityI e => SNtfEntity e
sNtfEntity @e) (forall (e :: NtfEntity). NtfEntityI e => SNtfEntity e
sNtfEntity @e') of
  Just e :~: e'
Refl -> t e -> Either String (t e)
forall a b. b -> Either a b
Right t e
t e'
c
  Maybe (e :~: e')
Nothing -> String -> Either String (t e)
forall a b. a -> Either a b
Left String
"bad command party"

checkEntity' :: forall t p p'. (NtfEntityI p, NtfEntityI p') => t p' -> Maybe (t p)
checkEntity' :: forall (t :: NtfEntity -> *) (p :: NtfEntity) (p' :: NtfEntity).
(NtfEntityI p, NtfEntityI p') =>
t p' -> Maybe (t p)
checkEntity' t p'
c = case SNtfEntity p -> SNtfEntity p' -> Maybe (p :~: p')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: NtfEntity) (b :: NtfEntity).
SNtfEntity a -> SNtfEntity b -> Maybe (a :~: b)
testEquality (forall (e :: NtfEntity). NtfEntityI e => SNtfEntity e
sNtfEntity @p) (forall (e :: NtfEntity). NtfEntityI e => SNtfEntity e
sNtfEntity @p') of
  Just p :~: p'
Refl -> t p -> Maybe (t p)
forall a. a -> Maybe a
Just t p
t p'
c
  Maybe (p :~: p')
_ -> Maybe (t p)
forall a. Maybe a
Nothing