{-# 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 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