{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# HLINT ignore "Use newtype instead of data" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

-- |
-- Module      : Simplex.Messaging.ProtocolEncoding
-- Copyright   : (c) simplex.chat
-- License     : AGPL-3
--
-- Maintainer  : chat@simplex.chat
-- Stability   : experimental
-- Portability : non-portable
--
-- Types, parsers, serializers and functions to send and receive SMP protocol commands and responses.
--
-- See https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md
module Simplex.Messaging.Protocol
  ( -- * SMP protocol parameters
    supportedSMPClientVRange,
    maxMessageLength,
    paddedProxiedTLength,
    e2eEncConfirmationLength,
    e2eEncMessageLength,

    -- * SMP protocol types
    SMPClientVersion,
    VersionSMPC,
    VersionRangeSMPC,
    pattern VersionSMPC,
    ProtocolEncoding (..),
    Command (..),
    SubscriptionMode (..),
    NewQueueReq (..),
    QueueReqData (..),
    QueueMode (..),
    QueueLinkData,
    EncFixedDataBytes,
    EncUserDataBytes,
    EncDataBytes (..),
    NewNtfCreds (..),
    ServerNtfCreds (..),
    Party (..),
    Cmd (..),
    QueueParty,
    BatchParty,
    ServiceParty,
    ASubscriberParty (..),
    BrokerMsg (..),
    SParty (..),
    PartyI (..),
    QueueIdsKeys (..),
    ProtocolErrorType (..),
    ErrorType (..),
    CommandError (..),
    ProxyError (..),
    BrokerErrorType (..),
    NetworkError (..),
    BlockingInfo (..),
    BlockingReason (..),
    RawTransmission,
    Transmission,
    TAuthorizations,
    TransmissionAuth (..),
    SignedTransmission,
    SignedTransmissionOrError,
    SentRawTransmission,
    ClientMsgEnvelope (..),
    PubHeader (..),
    ClientMessage (..),
    PrivHeader (..),
    Protocol (..),
    ProtocolType (..),
    SProtocolType (..),
    AProtocolType (..),
    ProtocolTypeI (..),
    UserProtocol,
    ProtocolServer (..),
    ProtoServer,
    SMPServer,
    pattern SMPServer,
    SMPServerWithAuth,
    NtfServer,
    pattern NtfServer,
    NtfServerWithAuth,
    XFTPServer,
    pattern XFTPServer,
    XFTPServerWithAuth,
    ProtoServerWithAuth (..),
    AProtoServerWithAuth (..),
    BasicAuth (..),
    SrvLoc (..),
    CorrId (..),
    pattern NoCorrId,
    EntityId (..),
    pattern NoEntity,
    QueueId,
    RecipientId,
    SenderId,
    LinkId,
    NotifierId,
    ServiceId,
    RcvPrivateAuthKey,
    RcvPublicAuthKey,
    RcvPublicDhKey,
    RcvDhSecret,
    SndPrivateAuthKey,
    SndPublicAuthKey,
    NtfPrivateAuthKey,
    NtfPublicAuthKey,
    RcvNtfPublicDhKey,
    RcvNtfDhSecret,
    Message (..),
    RcvMessage (..),
    MsgId,
    MsgBody,
    MaxMessageLen,
    MaxRcvMessageLen,
    EncRcvMsgBody (..),
    RcvMsgBody (..),
    ClientRcvMsgBody (..),
    EncNMsgMeta,
    SMPMsgMeta (..),
    NMsgMeta (..),
    EncFwdResponse (..),
    EncFwdTransmission (..),
    EncResponse (..),
    EncTransmission (..),
    FwdResponse (..),
    FwdTransmission (..),
    MsgFlags (..),
    initialSMPClientVersion,
    currentSMPClientVersion,
    senderCanSecure,
    queueReqMode,
    queueParty,
    batchParty,
    serviceParty,
    partyClientRole,
    partyServiceRole,
    userProtocol,
    rcvMessageMeta,
    noMsgFlags,
    messageId,
    messageTs,
    toNetworkError,

    -- * Parse and serialize
    ProtocolMsgTag (..),
    messageTagP,
    TransmissionForAuth (..),
    encodeTransmissionForAuth,
    encodeTransmission,
    transmissionP,
    _smpP,
    encodeRcvMsgBody,
    clientRcvMsgBodyP,
    legacyEncodeServer,
    legacyServerP,
    legacyStrEncodeServer,
    srvHostnamesSMPClientVersion,
    sndAuthKeySMPClientVersion,
    shortLinksSMPClientVersion,
    sameSrvAddr,
    sameSrvAddr',
    noAuthSrv,
    toMsgInfo,

    -- * TCP transport functions
    TransportBatch (..),
    tPut,
    tPutLog,
    tGetServer,
    tGetClient,
    tParse,
    tDecodeServer,
    tDecodeClient,
    tEncode,
    tEncodeBatch1,
    batchTransmissions,
    batchTransmissions',
    batchTransmissions_,

    -- * exports for tests
    CommandTag (..),
    BrokerMsgTag (..),
    checkParty,
  )
where

import Control.Applicative (optional, (<|>))
import Control.Exception (Exception, SomeException, displayException, fromException)
import Control.Monad.Except
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as J
import Data.Attoparsec.ByteString.Char8 (Parser, (<?>))
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import Data.Char (isPrint, isSpace)
import Data.Constraint (Dict (..))
import Data.Functor (($>))
import Data.Int (Int64)
import Data.Kind
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Maybe (isJust, isNothing)
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock.System (SystemTime (..), systemToUTCTime)
import Data.Type.Equality
import Data.Word (Word16)
import GHC.TypeLits (ErrorMessage (..), TypeError, type (+))
import qualified GHC.TypeLits as TE
import qualified GHC.TypeLits as Type
import Network.Socket (ServiceName)
import qualified Network.TLS as TLS
import Simplex.Messaging.Agent.Store.DB (Binary (..), FromField (..), ToField (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol.Types
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.Transport
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
import Simplex.Messaging.Util (bshow, eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version
import Simplex.Messaging.Version.Internal

-- SMP client protocol version history:
-- 1 - binary protocol encoding (1/1/2022)
-- 2 - multiple server hostnames and versioned queue addresses (8/12/2022)
-- 3 - faster handshake: SKEY command for sender to secure queue (6/30/2024, SMP protocol version 9)
-- 4 - short connection links with stored data (3/30/2025, SMP protocol version 15)

data SMPClientVersion

instance VersionScope SMPClientVersion

type VersionSMPC = Version SMPClientVersion

type VersionRangeSMPC = VersionRange SMPClientVersion

pattern VersionSMPC :: Word16 -> VersionSMPC
pattern $mVersionSMPC :: forall {r}. VersionSMPC -> (Word16 -> r) -> ((# #) -> r) -> r
$bVersionSMPC :: Word16 -> VersionSMPC
VersionSMPC v = Version v

initialSMPClientVersion :: VersionSMPC
initialSMPClientVersion :: VersionSMPC
initialSMPClientVersion = Word16 -> VersionSMPC
VersionSMPC Word16
1

srvHostnamesSMPClientVersion :: VersionSMPC
srvHostnamesSMPClientVersion :: VersionSMPC
srvHostnamesSMPClientVersion = Word16 -> VersionSMPC
VersionSMPC Word16
2

sndAuthKeySMPClientVersion :: VersionSMPC
sndAuthKeySMPClientVersion :: VersionSMPC
sndAuthKeySMPClientVersion = Word16 -> VersionSMPC
VersionSMPC Word16
3

shortLinksSMPClientVersion :: VersionSMPC
shortLinksSMPClientVersion :: VersionSMPC
shortLinksSMPClientVersion = Word16 -> VersionSMPC
VersionSMPC Word16
4

currentSMPClientVersion :: VersionSMPC
currentSMPClientVersion :: VersionSMPC
currentSMPClientVersion = Word16 -> VersionSMPC
VersionSMPC Word16
4

supportedSMPClientVRange :: VersionRangeSMPC
supportedSMPClientVRange :: VersionRangeSMPC
supportedSMPClientVRange = VersionSMPC -> VersionSMPC -> VersionRangeSMPC
forall v. Version v -> Version v -> VersionRange v
mkVersionRange VersionSMPC
initialSMPClientVersion VersionSMPC
currentSMPClientVersion

-- TODO v6.0 remove dependency on version
maxMessageLength :: VersionSMP -> Int
maxMessageLength :: VersionSMP -> Int
maxMessageLength VersionSMP
v
  | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
encryptedBlockSMPVersion = Int
16048 -- max 16048
  | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
sendingProxySMPVersion = Int
16064 -- max 16067
  | Bool
otherwise = Int
16088 -- 16048 - always use this size to determine allowed ranges

paddedProxiedTLength :: Int
paddedProxiedTLength :: Int
paddedProxiedTLength = Int
16226 -- 16225 .. 16227

-- TODO v7.0 change to 16048
type MaxMessageLen = 16088

-- 16 extra bytes: 8 for timestamp and 8 for flags (7 flags and the space, only 1 flag is currently used)
type MaxRcvMessageLen = MaxMessageLen + 16 -- 16104, the padded size is 16106

-- it is shorter to allow per-queue e2e encryption DH key in the "public" header
e2eEncConfirmationLength :: Int
e2eEncConfirmationLength :: Int
e2eEncConfirmationLength = Int
15904 -- 15865 .. 15960

e2eEncMessageLength :: Int
e2eEncMessageLength :: Int
e2eEncMessageLength = Int
16000 -- 15988 .. 16005

-- | SMP protocol clients
data Party
  = Creator
  | Recipient
  | RecipientService
  | Sender
  | IdleClient
  | Notifier
  | NotifierService
  | LinkClient
  | ProxiedClient
  | ProxyService
  deriving (Int -> Party -> ShowS
[Party] -> ShowS
Party -> String
(Int -> Party -> ShowS)
-> (Party -> String) -> ([Party] -> ShowS) -> Show Party
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Party -> ShowS
showsPrec :: Int -> Party -> ShowS
$cshow :: Party -> String
show :: Party -> String
$cshowList :: [Party] -> ShowS
showList :: [Party] -> ShowS
Show)

-- | Singleton types for SMP protocol clients
data SParty :: Party -> Type where
  SCreator :: SParty Creator
  SRecipient :: SParty Recipient
  SRecipientService :: SParty RecipientService
  SSender :: SParty Sender
  SIdleClient :: SParty IdleClient
  SNotifier :: SParty Notifier
  SNotifierService :: SParty NotifierService
  SSenderLink :: SParty LinkClient
  SProxiedClient :: SParty ProxiedClient
  SProxyService :: SParty ProxyService

instance TestEquality SParty where
  testEquality :: forall (a :: Party) (b :: Party).
SParty a -> SParty b -> Maybe (a :~: b)
testEquality SParty a
SCreator SParty b
SCreator = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SRecipient SParty b
SRecipient = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SRecipientService SParty b
SRecipientService = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SSender SParty b
SSender = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SIdleClient SParty b
SIdleClient = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SNotifier SParty b
SNotifier = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SNotifierService SParty b
SNotifierService = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SSenderLink SParty b
SSenderLink = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SProxiedClient SParty b
SProxiedClient = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
SProxyService SParty b
SProxyService = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SParty a
_ SParty b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

deriving instance Show (SParty p)

class PartyI (p :: Party) where sParty :: SParty p

instance PartyI Creator where sParty :: SParty 'Creator
sParty = SParty 'Creator
SCreator

instance PartyI Recipient where sParty :: SParty 'Recipient
sParty = SParty 'Recipient
SRecipient

instance PartyI RecipientService where sParty :: SParty 'RecipientService
sParty = SParty 'RecipientService
SRecipientService

instance PartyI Sender where sParty :: SParty 'Sender
sParty = SParty 'Sender
SSender

instance PartyI IdleClient where sParty :: SParty 'IdleClient
sParty = SParty 'IdleClient
SIdleClient

instance PartyI Notifier where sParty :: SParty 'Notifier
sParty = SParty 'Notifier
SNotifier

instance PartyI NotifierService where sParty :: SParty 'NotifierService
sParty = SParty 'NotifierService
SNotifierService

instance PartyI LinkClient where sParty :: SParty 'LinkClient
sParty = SParty 'LinkClient
SSenderLink

instance PartyI ProxiedClient where sParty :: SParty 'ProxiedClient
sParty = SParty 'ProxiedClient
SProxiedClient

instance PartyI ProxyService where sParty :: SParty 'ProxyService
sParty = SParty 'ProxyService
SProxyService

-- command parties that can read queues
type family QueueParty (p :: Party) :: Constraint where
  QueueParty Recipient = ()
  QueueParty Sender = ()
  QueueParty Notifier = ()
  QueueParty LinkClient = ()
  QueueParty p =
    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not QueueParty"))

queueParty :: SParty p -> Maybe (Dict (PartyI p, QueueParty p))
queueParty :: forall (p :: Party).
SParty p -> Maybe (Dict (PartyI p, QueueParty p))
queueParty = \case
  SParty p
SRecipient -> Dict (PartyI 'Recipient, () :: Constraint)
-> Maybe (Dict (PartyI 'Recipient, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'Recipient, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
SSender -> Dict (PartyI 'Sender, () :: Constraint)
-> Maybe (Dict (PartyI 'Sender, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'Sender, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
SSenderLink -> Dict (PartyI 'LinkClient, () :: Constraint)
-> Maybe (Dict (PartyI 'LinkClient, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'LinkClient, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
SNotifier -> Dict (PartyI 'Notifier, () :: Constraint)
-> Maybe (Dict (PartyI 'Notifier, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'Notifier, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
_ -> Maybe (Dict (PartyI p, QueueParty p))
forall a. Maybe a
Nothing
{-# INLINE queueParty #-}

type family BatchParty (p :: Party) :: Constraint where
  BatchParty Recipient = ()
  BatchParty Notifier = ()
  BatchParty p =
    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not BatchParty"))

batchParty :: SParty p -> Maybe (Dict (PartyI p, BatchParty p))
batchParty :: forall (p :: Party).
SParty p -> Maybe (Dict (PartyI p, BatchParty p))
batchParty = \case
  SParty p
SRecipient -> Dict (PartyI 'Recipient, () :: Constraint)
-> Maybe (Dict (PartyI 'Recipient, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'Recipient, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
SNotifier -> Dict (PartyI 'Notifier, () :: Constraint)
-> Maybe (Dict (PartyI 'Notifier, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'Notifier, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
_ -> Maybe (Dict (PartyI p, BatchParty p))
forall a. Maybe a
Nothing
{-# INLINE batchParty #-}

-- command parties that can subscribe to individual queues
type family ServiceParty (p :: Party) :: Constraint where
  ServiceParty RecipientService = ()
  ServiceParty NotifierService = ()
  ServiceParty p =
    (Int ~ Bool, TypeError (Type.Text "Party " :<>: ShowType p :<>: Type.Text " is not ServiceParty"))

serviceParty :: SParty p -> Maybe (Dict (PartyI p, ServiceParty p))
serviceParty :: forall (p :: Party).
SParty p -> Maybe (Dict (PartyI p, ServiceParty p))
serviceParty = \case
  SParty p
SRecipientService -> Dict (PartyI 'RecipientService, () :: Constraint)
-> Maybe (Dict (PartyI 'RecipientService, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'RecipientService, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
SNotifierService -> Dict (PartyI 'NotifierService, () :: Constraint)
-> Maybe (Dict (PartyI 'NotifierService, () :: Constraint))
forall a. a -> Maybe a
Just Dict (PartyI 'NotifierService, () :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SParty p
_ -> Maybe (Dict (PartyI p, ServiceParty p))
forall a. Maybe a
Nothing
{-# INLINE serviceParty #-}

data ASubscriberParty = forall p. (PartyI p, ServiceParty p) => ASP (SParty p)

deriving instance Show ASubscriberParty

instance Eq ASubscriberParty where
  ASP SParty p
p == :: ASubscriberParty -> ASubscriberParty -> Bool
== ASP SParty p
p' = Maybe (p :~: p) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (p :~: p) -> Bool) -> Maybe (p :~: p) -> Bool
forall a b. (a -> b) -> a -> b
$ SParty p -> SParty p -> Maybe (p :~: p)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Party) (b :: Party).
SParty a -> SParty b -> Maybe (a :~: b)
testEquality SParty p
p SParty p
p'

instance Encoding ASubscriberParty where
  smpEncode :: ASubscriberParty -> MsgId
smpEncode = \case
    ASP SParty p
SRecipientService -> MsgId
"R"
    ASP SParty p
SNotifierService -> MsgId
"N"
  smpP :: Parser ASubscriberParty
smpP =
    Parser Char
A.anyChar Parser Char
-> (Char -> Parser ASubscriberParty) -> Parser ASubscriberParty
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'R' -> ASubscriberParty -> Parser ASubscriberParty
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ASubscriberParty -> Parser ASubscriberParty)
-> ASubscriberParty -> Parser ASubscriberParty
forall a b. (a -> b) -> a -> b
$ SParty 'RecipientService -> ASubscriberParty
forall (p :: Party).
(PartyI p, ServiceParty p) =>
SParty p -> ASubscriberParty
ASP SParty 'RecipientService
SRecipientService
      Char
'N' -> ASubscriberParty -> Parser ASubscriberParty
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ASubscriberParty -> Parser ASubscriberParty)
-> ASubscriberParty -> Parser ASubscriberParty
forall a b. (a -> b) -> a -> b
$ SParty 'NotifierService -> ASubscriberParty
forall (p :: Party).
(PartyI p, ServiceParty p) =>
SParty p -> ASubscriberParty
ASP SParty 'NotifierService
SNotifierService
      Char
_ -> String -> Parser ASubscriberParty
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ASubscriberParty"

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

partyClientRole :: SParty p -> Maybe SMPServiceRole
partyClientRole :: forall (p :: Party). SParty p -> Maybe SMPServiceRole
partyClientRole = \case
  SParty p
SCreator -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SRecipient -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SRecipientService -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SSender -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SIdleClient -> Maybe SMPServiceRole
forall a. Maybe a
Nothing
  SParty p
SNotifier -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRNotifier
  SParty p
SNotifierService -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRNotifier
  SParty p
SSenderLink -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SProxiedClient -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRMessaging
  SParty p
SProxyService -> SMPServiceRole -> Maybe SMPServiceRole
forall a. a -> Maybe a
Just SMPServiceRole
SRProxy
{-# INLINE partyClientRole #-}

partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole
partyServiceRole :: forall (p :: Party). ServiceParty p => SParty p -> SMPServiceRole
partyServiceRole = \case
  SParty p
SRecipientService -> SMPServiceRole
SRMessaging
  SParty p
SNotifierService -> SMPServiceRole
SRNotifier
{-# INLINE partyServiceRole #-}

-- | Type for client command of any participant.
data Cmd = forall p. PartyI p => Cmd (SParty p) (Command p)

deriving instance Show Cmd

-- | Parsed SMP transmission without signature, size and session ID.
type Transmission c = (CorrId, EntityId, c)

-- | signed parsed transmission, with original raw bytes and parsing error.
type SignedTransmission c = (Maybe TAuthorizations, Signed, Transmission c)

type SignedTransmissionOrError e c = Either (Transmission e) (SignedTransmission c)

type Signed = ByteString

-- | unparsed SMP transmission with signature.
data RawTransmission = RawTransmission
  { RawTransmission -> MsgId
authenticator :: ByteString, -- signature or encrypted transmission hash
    RawTransmission -> Maybe (Signature 'Ed25519)
serviceSig :: Maybe (C.Signature 'C.Ed25519), -- optional second signature with the key of the client service
    RawTransmission -> MsgId
authorized :: ByteString, -- authorized transmission
    RawTransmission -> MsgId
sessId :: SessionId,
    RawTransmission -> CorrId
corrId :: CorrId,
    RawTransmission -> LinkId
entityId :: EntityId,
    RawTransmission -> MsgId
command :: ByteString
  }
  deriving (Int -> RawTransmission -> ShowS
[RawTransmission] -> ShowS
RawTransmission -> String
(Int -> RawTransmission -> ShowS)
-> (RawTransmission -> String)
-> ([RawTransmission] -> ShowS)
-> Show RawTransmission
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawTransmission -> ShowS
showsPrec :: Int -> RawTransmission -> ShowS
$cshow :: RawTransmission -> String
show :: RawTransmission -> String
$cshowList :: [RawTransmission] -> ShowS
showList :: [RawTransmission] -> ShowS
Show)

type TAuthorizations = (TransmissionAuth, Maybe (C.Signature 'C.Ed25519))

data TransmissionAuth
  = TASignature C.ASignature
  | TAAuthenticator C.CbAuthenticator
  deriving (Int -> TransmissionAuth -> ShowS
[TransmissionAuth] -> ShowS
TransmissionAuth -> String
(Int -> TransmissionAuth -> ShowS)
-> (TransmissionAuth -> String)
-> ([TransmissionAuth] -> ShowS)
-> Show TransmissionAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransmissionAuth -> ShowS
showsPrec :: Int -> TransmissionAuth -> ShowS
$cshow :: TransmissionAuth -> String
show :: TransmissionAuth -> String
$cshowList :: [TransmissionAuth] -> ShowS
showList :: [TransmissionAuth] -> ShowS
Show)

-- this encoding is backwards compatible with v6 that used Maybe C.ASignature instead of TransmissionAuth
tEncodeAuth :: Bool -> Maybe TAuthorizations -> ByteString
tEncodeAuth :: Bool -> Maybe TAuthorizations -> MsgId
tEncodeAuth Bool
serviceAuth = \case
  Maybe TAuthorizations
Nothing -> MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode MsgId
B.empty
  Just (TransmissionAuth
auth, Maybe (Signature 'Ed25519)
sig)
    | Bool
serviceAuth -> (MsgId, Maybe (Signature 'Ed25519)) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (TransmissionAuth -> MsgId
authBytes TransmissionAuth
auth, Maybe (Signature 'Ed25519)
sig)
    | Bool
otherwise -> MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (TransmissionAuth -> MsgId
authBytes TransmissionAuth
auth)
  where
    authBytes :: TransmissionAuth -> MsgId
authBytes = \case
      TASignature ASignature
s -> ASignature -> MsgId
forall s. CryptoSignature s => s -> MsgId
C.signatureBytes ASignature
s
      TAAuthenticator (C.CbAuthenticator MsgId
s) -> MsgId
s

decodeTAuthBytes :: ByteString -> Maybe (C.Signature 'C.Ed25519) -> Either String (Maybe TAuthorizations)
decodeTAuthBytes :: MsgId
-> Maybe (Signature 'Ed25519)
-> Either String (Maybe TAuthorizations)
decodeTAuthBytes MsgId
s Maybe (Signature 'Ed25519)
serviceSig
  | MsgId -> Bool
B.null MsgId
s = Maybe TAuthorizations -> Either String (Maybe TAuthorizations)
forall a b. b -> Either a b
Right Maybe TAuthorizations
forall a. Maybe a
Nothing
  | MsgId -> Int
B.length MsgId
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
C.cbAuthenticatorSize = Maybe TAuthorizations -> Either String (Maybe TAuthorizations)
forall a b. b -> Either a b
Right (Maybe TAuthorizations -> Either String (Maybe TAuthorizations))
-> Maybe TAuthorizations -> Either String (Maybe TAuthorizations)
forall a b. (a -> b) -> a -> b
$ TAuthorizations -> Maybe TAuthorizations
forall a. a -> Maybe a
Just (CbAuthenticator -> TransmissionAuth
TAAuthenticator (MsgId -> CbAuthenticator
C.CbAuthenticator MsgId
s), Maybe (Signature 'Ed25519)
serviceSig)
  | Bool
otherwise = (\ASignature
sig -> TAuthorizations -> Maybe TAuthorizations
forall a. a -> Maybe a
Just (ASignature -> TransmissionAuth
TASignature ASignature
sig, Maybe (Signature 'Ed25519)
serviceSig)) (ASignature -> Maybe TAuthorizations)
-> Either String ASignature
-> Either String (Maybe TAuthorizations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MsgId -> Either String ASignature
forall s. CryptoSignature s => MsgId -> Either String s
C.decodeSignature MsgId
s

-- | unparsed sent SMP transmission with signature.
type SentRawTransmission = (Maybe TAuthorizations, ByteString)

-- | SMP queue ID for the recipient.
type RecipientId = QueueId

-- | SMP queue ID for the sender.
type SenderId = QueueId

-- | SMP queue ID for notifications.
type NotifierId = QueueId

type LinkId = QueueId

-- | SMP queue ID on the server.
type QueueId = EntityId

-- | Parameterized type for SMP protocol commands from all clients.
data Command (p :: Party) where
  -- SMP recipient commands
  -- RcvPublicAuthKey is the key used for command authorization:
  -- v6 of SMP servers only support signature algorithm for command authorization.
  -- v7 of SMP servers additionally support additional layer of authenticated encryption.
  -- RcvPublicAuthKey is defined as C.APublicKey - it can be either signature or DH public keys.
  NEW :: NewQueueReq -> Command Creator
  SUB :: Command Recipient
  -- | subscribe all associated queues. Service ID must be used as entity ID, and service session key must sign the command.
  SUBS :: Command RecipientService
  KEY :: SndPublicAuthKey -> Command Recipient
  RKEY :: NonEmpty RcvPublicAuthKey -> Command Recipient
  LSET :: LinkId -> QueueLinkData -> Command Recipient
  LDEL :: Command Recipient
  NKEY :: NtfPublicAuthKey -> RcvNtfPublicDhKey -> Command Recipient
  NDEL :: Command Recipient
  GET :: Command Recipient
  ACK :: MsgId -> Command Recipient
  OFF :: Command Recipient
  DEL :: Command Recipient
  QUE :: Command Recipient
  -- SMP sender commands
  SKEY :: SndPublicAuthKey -> Command Sender
  -- SEND v1 has to be supported for encoding/decoding
  -- SEND :: MsgBody -> Command Sender
  SEND :: MsgFlags -> MsgBody -> Command Sender
  PING :: Command IdleClient
  -- Client accessing short links
  LKEY :: SndPublicAuthKey -> Command LinkClient
  LGET :: Command LinkClient
  -- SMP notification subscriber commands
  NSUB :: Command Notifier
  -- | subscribe all associated queues. Service ID must be used as entity ID, and service session key must sign the command.
  NSUBS :: Command NotifierService
  PRXY :: SMPServer -> Maybe BasicAuth -> Command ProxiedClient -- request a relay server connection by URI
  -- Transmission to proxy:
  -- - entity ID: ID of the session with relay returned in PKEY (response to PRXY)
  -- - corrId: also used as a nonce to encrypt transmission to relay, corrId + 1 - from relay
  -- - key (1st param in the command) is used to agree DH secret for this particular transmission and its response
  -- Encrypted transmission should include session ID (tlsunique) from proxy-relay connection.
  PFWD :: VersionSMP -> C.PublicKeyX25519 -> EncTransmission -> Command ProxiedClient -- use CorrId as CbNonce, client to proxy
  -- Transmission forwarded to relay:
  -- - entity ID: empty
  -- - corrId: unique correlation ID between proxy and relay, also used as a nonce to encrypt forwarded transmission
  RFWD :: EncFwdTransmission -> Command ProxyService -- use CorrId as CbNonce, proxy to relay

deriving instance Show (Command p)

data NewQueueReq = NewQueueReq
  { NewQueueReq -> SndPublicAuthKey
rcvAuthKey :: RcvPublicAuthKey,
    NewQueueReq -> RcvNtfPublicDhKey
rcvDhKey :: RcvPublicDhKey,
    NewQueueReq -> Maybe BasicAuth
auth_ :: Maybe BasicAuth,
    NewQueueReq -> SubscriptionMode
subMode :: SubscriptionMode,
    NewQueueReq -> Maybe QueueReqData
queueReqData :: Maybe QueueReqData,
    NewQueueReq -> Maybe NewNtfCreds
ntfCreds :: Maybe NewNtfCreds
  }
  deriving (Int -> NewQueueReq -> ShowS
[NewQueueReq] -> ShowS
NewQueueReq -> String
(Int -> NewQueueReq -> ShowS)
-> (NewQueueReq -> String)
-> ([NewQueueReq] -> ShowS)
-> Show NewQueueReq
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewQueueReq -> ShowS
showsPrec :: Int -> NewQueueReq -> ShowS
$cshow :: NewQueueReq -> String
show :: NewQueueReq -> String
$cshowList :: [NewQueueReq] -> ShowS
showList :: [NewQueueReq] -> ShowS
Show)

data SubscriptionMode = SMSubscribe | SMOnlyCreate
  deriving (SubscriptionMode -> SubscriptionMode -> Bool
(SubscriptionMode -> SubscriptionMode -> Bool)
-> (SubscriptionMode -> SubscriptionMode -> Bool)
-> Eq SubscriptionMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubscriptionMode -> SubscriptionMode -> Bool
== :: SubscriptionMode -> SubscriptionMode -> Bool
$c/= :: SubscriptionMode -> SubscriptionMode -> Bool
/= :: SubscriptionMode -> SubscriptionMode -> Bool
Eq, Int -> SubscriptionMode -> ShowS
[SubscriptionMode] -> ShowS
SubscriptionMode -> String
(Int -> SubscriptionMode -> ShowS)
-> (SubscriptionMode -> String)
-> ([SubscriptionMode] -> ShowS)
-> Show SubscriptionMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubscriptionMode -> ShowS
showsPrec :: Int -> SubscriptionMode -> ShowS
$cshow :: SubscriptionMode -> String
show :: SubscriptionMode -> String
$cshowList :: [SubscriptionMode] -> ShowS
showList :: [SubscriptionMode] -> ShowS
Show)

-- SenderId must be computed client-side as `sha3-256(corr_id)`, `corr_id` - a random transmission ID.
-- The server must verify and reject it if it does not match (and in case of collision).
-- This allows to include SenderId in FixedDataBytes in full connection request,
-- and at the same time prevents the possibility of checking whether a queue with a known ID exists.
data QueueReqData = QRMessaging (Maybe (SenderId, QueueLinkData)) | QRContact (Maybe (LinkId, (SenderId, QueueLinkData)))
  deriving (Int -> QueueReqData -> ShowS
[QueueReqData] -> ShowS
QueueReqData -> String
(Int -> QueueReqData -> ShowS)
-> (QueueReqData -> String)
-> ([QueueReqData] -> ShowS)
-> Show QueueReqData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueueReqData -> ShowS
showsPrec :: Int -> QueueReqData -> ShowS
$cshow :: QueueReqData -> String
show :: QueueReqData -> String
$cshowList :: [QueueReqData] -> ShowS
showList :: [QueueReqData] -> ShowS
Show)

queueReqMode :: QueueReqData -> QueueMode
queueReqMode :: QueueReqData -> QueueMode
queueReqMode = \case
  QRMessaging Maybe (LinkId, QueueLinkData)
_ -> QueueMode
QMMessaging
  QRContact Maybe (LinkId, (LinkId, QueueLinkData))
_ -> QueueMode
QMContact

senderCanSecure :: Maybe QueueMode -> Bool
senderCanSecure :: Maybe QueueMode -> Bool
senderCanSecure = \case
  Just QueueMode
QMMessaging -> Bool
True
  Maybe QueueMode
_ -> Bool
False

type QueueLinkData = (EncFixedDataBytes, EncUserDataBytes)

type EncFixedDataBytes = EncDataBytes

type EncUserDataBytes = EncDataBytes

newtype EncDataBytes = EncDataBytes ByteString
  deriving (EncDataBytes -> EncDataBytes -> Bool
(EncDataBytes -> EncDataBytes -> Bool)
-> (EncDataBytes -> EncDataBytes -> Bool) -> Eq EncDataBytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EncDataBytes -> EncDataBytes -> Bool
== :: EncDataBytes -> EncDataBytes -> Bool
$c/= :: EncDataBytes -> EncDataBytes -> Bool
/= :: EncDataBytes -> EncDataBytes -> Bool
Eq, Int -> EncDataBytes -> ShowS
[EncDataBytes] -> ShowS
EncDataBytes -> String
(Int -> EncDataBytes -> ShowS)
-> (EncDataBytes -> String)
-> ([EncDataBytes] -> ShowS)
-> Show EncDataBytes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncDataBytes -> ShowS
showsPrec :: Int -> EncDataBytes -> ShowS
$cshow :: EncDataBytes -> String
show :: EncDataBytes -> String
$cshowList :: [EncDataBytes] -> ShowS
showList :: [EncDataBytes] -> ShowS
Show)
  deriving newtype (FieldParser EncDataBytes
FieldParser EncDataBytes -> FromField EncDataBytes
forall a. FieldParser a -> FromField a
$cfromField :: FieldParser EncDataBytes
fromField :: FieldParser EncDataBytes
FromField, Parser EncDataBytes
MsgId -> Either String EncDataBytes
EncDataBytes -> MsgId
(EncDataBytes -> MsgId)
-> (MsgId -> Either String EncDataBytes)
-> Parser EncDataBytes
-> StrEncoding EncDataBytes
forall a.
(a -> MsgId)
-> (MsgId -> Either String a) -> Parser a -> StrEncoding a
$cstrEncode :: EncDataBytes -> MsgId
strEncode :: EncDataBytes -> MsgId
$cstrDecode :: MsgId -> Either String EncDataBytes
strDecode :: MsgId -> Either String EncDataBytes
$cstrP :: Parser EncDataBytes
strP :: Parser EncDataBytes
StrEncoding)

instance Encoding EncDataBytes where
  smpEncode :: EncDataBytes -> MsgId
smpEncode (EncDataBytes MsgId
s) = Large -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (MsgId -> Large
Large MsgId
s)
  {-# INLINE smpEncode #-}
  smpP :: Parser EncDataBytes
smpP = MsgId -> EncDataBytes
EncDataBytes (MsgId -> EncDataBytes)
-> (Large -> MsgId) -> Large -> EncDataBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Large -> MsgId
unLarge (Large -> EncDataBytes)
-> Parser MsgId Large -> Parser EncDataBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId Large
forall a. Encoding a => Parser a
smpP
  {-# INLINE smpP #-}

instance ToField EncDataBytes where
  toField :: EncDataBytes -> SQLData
toField (EncDataBytes MsgId
s) = Binary MsgId -> SQLData
forall a. ToField a => a -> SQLData
toField (MsgId -> Binary MsgId
forall a. a -> Binary a
Binary MsgId
s)
  {-# INLINE toField #-}

data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Int -> NewNtfCreds -> ShowS
[NewNtfCreds] -> ShowS
NewNtfCreds -> String
(Int -> NewNtfCreds -> ShowS)
-> (NewNtfCreds -> String)
-> ([NewNtfCreds] -> ShowS)
-> Show NewNtfCreds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NewNtfCreds -> ShowS
showsPrec :: Int -> NewNtfCreds -> ShowS
$cshow :: NewNtfCreds -> String
show :: NewNtfCreds -> String
$cshowList :: [NewNtfCreds] -> ShowS
showList :: [NewNtfCreds] -> ShowS
Show)

instance StrEncoding SubscriptionMode where
  strEncode :: SubscriptionMode -> MsgId
strEncode = \case
    SubscriptionMode
SMSubscribe -> MsgId
"subscribe"
    SubscriptionMode
SMOnlyCreate -> MsgId
"only-create"
  strP :: Parser SubscriptionMode
strP =
    (MsgId -> Parser MsgId MsgId
A.string MsgId
"subscribe" Parser MsgId MsgId -> SubscriptionMode -> Parser SubscriptionMode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SubscriptionMode
SMSubscribe)
      Parser SubscriptionMode
-> Parser SubscriptionMode -> Parser SubscriptionMode
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (MsgId -> Parser MsgId MsgId
A.string MsgId
"only-create" Parser MsgId MsgId -> SubscriptionMode -> Parser SubscriptionMode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SubscriptionMode
SMOnlyCreate)
        Parser SubscriptionMode -> String -> Parser SubscriptionMode
forall i a. Parser i a -> String -> Parser i a
<?> String
"SubscriptionMode"

instance Encoding SubscriptionMode where
  smpEncode :: SubscriptionMode -> MsgId
smpEncode = \case
    SubscriptionMode
SMSubscribe -> MsgId
"S"
    SubscriptionMode
SMOnlyCreate -> MsgId
"C"
  smpP :: Parser SubscriptionMode
smpP =
    Parser Char
A.anyChar Parser Char
-> (Char -> Parser SubscriptionMode) -> Parser SubscriptionMode
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'S' -> SubscriptionMode -> Parser SubscriptionMode
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubscriptionMode
SMSubscribe
      Char
'C' -> SubscriptionMode -> Parser SubscriptionMode
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubscriptionMode
SMOnlyCreate
      Char
_ -> String -> Parser SubscriptionMode
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad SubscriptionMode"

instance Encoding QueueReqData where
  smpEncode :: QueueReqData -> MsgId
smpEncode = \case
    QRMessaging Maybe (LinkId, QueueLinkData)
d -> (Char, Maybe (LinkId, QueueLinkData)) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (Char
'M', Maybe (LinkId, QueueLinkData)
d)
    QRContact Maybe (LinkId, (LinkId, QueueLinkData))
d -> (Char, Maybe (LinkId, (LinkId, QueueLinkData))) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (Char
'C', Maybe (LinkId, (LinkId, QueueLinkData))
d)
  smpP :: Parser QueueReqData
smpP =
    Parser Char
A.anyChar Parser Char -> (Char -> Parser QueueReqData) -> Parser QueueReqData
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'M' -> Maybe (LinkId, QueueLinkData) -> QueueReqData
QRMessaging (Maybe (LinkId, QueueLinkData) -> QueueReqData)
-> Parser MsgId (Maybe (LinkId, QueueLinkData))
-> Parser QueueReqData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId (Maybe (LinkId, QueueLinkData))
forall a. Encoding a => Parser a
smpP
      Char
'C' -> Maybe (LinkId, (LinkId, QueueLinkData)) -> QueueReqData
QRContact (Maybe (LinkId, (LinkId, QueueLinkData)) -> QueueReqData)
-> Parser MsgId (Maybe (LinkId, (LinkId, QueueLinkData)))
-> Parser QueueReqData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId (Maybe (LinkId, (LinkId, QueueLinkData)))
forall a. Encoding a => Parser a
smpP
      Char
_ -> String -> Parser QueueReqData
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad QueueReqData"

instance Encoding NewNtfCreds where
  smpEncode :: NewNtfCreds -> MsgId
smpEncode (NewNtfCreds SndPublicAuthKey
authKey RcvNtfPublicDhKey
dhKey) = (SndPublicAuthKey, RcvNtfPublicDhKey) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (SndPublicAuthKey
authKey, RcvNtfPublicDhKey
dhKey)
  smpP :: Parser NewNtfCreds
smpP = SndPublicAuthKey -> RcvNtfPublicDhKey -> NewNtfCreds
NewNtfCreds (SndPublicAuthKey -> RcvNtfPublicDhKey -> NewNtfCreds)
-> Parser MsgId SndPublicAuthKey
-> Parser MsgId (RcvNtfPublicDhKey -> NewNtfCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
smpP Parser MsgId (RcvNtfPublicDhKey -> NewNtfCreds)
-> Parser MsgId RcvNtfPublicDhKey -> Parser NewNtfCreds
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP

newtype EncTransmission = EncTransmission ByteString
  deriving (Int -> EncTransmission -> ShowS
[EncTransmission] -> ShowS
EncTransmission -> String
(Int -> EncTransmission -> ShowS)
-> (EncTransmission -> String)
-> ([EncTransmission] -> ShowS)
-> Show EncTransmission
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncTransmission -> ShowS
showsPrec :: Int -> EncTransmission -> ShowS
$cshow :: EncTransmission -> String
show :: EncTransmission -> String
$cshowList :: [EncTransmission] -> ShowS
showList :: [EncTransmission] -> ShowS
Show)

data FwdTransmission = FwdTransmission
  { FwdTransmission -> CorrId
fwdCorrId :: CorrId,
    FwdTransmission -> VersionSMP
fwdVersion :: VersionSMP,
    FwdTransmission -> RcvNtfPublicDhKey
fwdKey :: C.PublicKeyX25519,
    FwdTransmission -> EncTransmission
fwdTransmission :: EncTransmission
  }

instance Encoding FwdTransmission where
  smpEncode :: FwdTransmission -> MsgId
smpEncode FwdTransmission {$sel:fwdCorrId:FwdTransmission :: FwdTransmission -> CorrId
fwdCorrId = CorrId MsgId
corrId, VersionSMP
$sel:fwdVersion:FwdTransmission :: FwdTransmission -> VersionSMP
fwdVersion :: VersionSMP
fwdVersion, RcvNtfPublicDhKey
$sel:fwdKey:FwdTransmission :: FwdTransmission -> RcvNtfPublicDhKey
fwdKey :: RcvNtfPublicDhKey
fwdKey, $sel:fwdTransmission:FwdTransmission :: FwdTransmission -> EncTransmission
fwdTransmission = EncTransmission MsgId
t} =
    (MsgId, VersionSMP, RcvNtfPublicDhKey, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (MsgId
corrId, VersionSMP
fwdVersion, RcvNtfPublicDhKey
fwdKey, MsgId -> Tail
Tail MsgId
t)
  smpP :: Parser FwdTransmission
smpP = do
    (MsgId
corrId, VersionSMP
fwdVersion, RcvNtfPublicDhKey
fwdKey, Tail MsgId
t) <- Parser (MsgId, VersionSMP, RcvNtfPublicDhKey, Tail)
forall a. Encoding a => Parser a
smpP
    FwdTransmission -> Parser FwdTransmission
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FwdTransmission {$sel:fwdCorrId:FwdTransmission :: CorrId
fwdCorrId = MsgId -> CorrId
CorrId MsgId
corrId, VersionSMP
$sel:fwdVersion:FwdTransmission :: VersionSMP
fwdVersion :: VersionSMP
fwdVersion, RcvNtfPublicDhKey
$sel:fwdKey:FwdTransmission :: RcvNtfPublicDhKey
fwdKey :: RcvNtfPublicDhKey
fwdKey, $sel:fwdTransmission:FwdTransmission :: EncTransmission
fwdTransmission = MsgId -> EncTransmission
EncTransmission MsgId
t}

newtype EncFwdTransmission = EncFwdTransmission ByteString
  deriving (Int -> EncFwdTransmission -> ShowS
[EncFwdTransmission] -> ShowS
EncFwdTransmission -> String
(Int -> EncFwdTransmission -> ShowS)
-> (EncFwdTransmission -> String)
-> ([EncFwdTransmission] -> ShowS)
-> Show EncFwdTransmission
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EncFwdTransmission -> ShowS
showsPrec :: Int -> EncFwdTransmission -> ShowS
$cshow :: EncFwdTransmission -> String
show :: EncFwdTransmission -> String
$cshowList :: [EncFwdTransmission] -> ShowS
showList :: [EncFwdTransmission] -> ShowS
Show)

data BrokerMsg where
  -- SMP broker messages (responses, client messages, notifications)
  IDS :: QueueIdsKeys -> BrokerMsg
  LNK :: SenderId -> QueueLinkData -> BrokerMsg
  -- | Service subscription success - confirms when queue was associated with the service
  SOK :: Maybe ServiceId -> BrokerMsg
  -- | The number of queues subscribed with SUBS command
  SOKS :: Int64 -> BrokerMsg
  -- MSG v1/2 has to be supported for encoding/decoding
  -- v1: MSG :: MsgId -> SystemTime -> MsgBody -> BrokerMsg
  -- v2: MsgId -> SystemTime -> MsgFlags -> MsgBody -> BrokerMsg
  MSG :: RcvMessage -> BrokerMsg
  NID :: NotifierId -> RcvNtfPublicDhKey -> BrokerMsg
  NMSG :: C.CbNonce -> EncNMsgMeta -> BrokerMsg
  -- Should include certificate chain
  PKEY :: SessionId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg -- TLS-signed server key for proxy shared secret and initial sender key
  RRES :: EncFwdResponse -> BrokerMsg -- relay to proxy
  PRES :: EncResponse -> BrokerMsg -- proxy to client
  END :: BrokerMsg
  ENDS :: Int64 -> BrokerMsg
  DELD :: BrokerMsg
  INFO :: QueueInfo -> BrokerMsg
  OK :: BrokerMsg
  ERR :: ErrorType -> BrokerMsg
  PONG :: BrokerMsg
  deriving (BrokerMsg -> BrokerMsg -> Bool
(BrokerMsg -> BrokerMsg -> Bool)
-> (BrokerMsg -> BrokerMsg -> Bool) -> Eq BrokerMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BrokerMsg -> BrokerMsg -> Bool
== :: BrokerMsg -> BrokerMsg -> Bool
$c/= :: BrokerMsg -> BrokerMsg -> Bool
/= :: BrokerMsg -> BrokerMsg -> Bool
Eq, Int -> BrokerMsg -> ShowS
[BrokerMsg] -> ShowS
BrokerMsg -> String
(Int -> BrokerMsg -> ShowS)
-> (BrokerMsg -> String)
-> ([BrokerMsg] -> ShowS)
-> Show BrokerMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BrokerMsg -> ShowS
showsPrec :: Int -> BrokerMsg -> ShowS
$cshow :: BrokerMsg -> String
show :: BrokerMsg -> String
$cshowList :: [BrokerMsg] -> ShowS
showList :: [BrokerMsg] -> ShowS
Show)

data RcvMessage = RcvMessage
  { RcvMessage -> MsgId
msgId :: MsgId,
    RcvMessage -> EncRcvMsgBody
msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
  }
  deriving (RcvMessage -> RcvMessage -> Bool
(RcvMessage -> RcvMessage -> Bool)
-> (RcvMessage -> RcvMessage -> Bool) -> Eq RcvMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RcvMessage -> RcvMessage -> Bool
== :: RcvMessage -> RcvMessage -> Bool
$c/= :: RcvMessage -> RcvMessage -> Bool
/= :: RcvMessage -> RcvMessage -> Bool
Eq, Int -> RcvMessage -> ShowS
[RcvMessage] -> ShowS
RcvMessage -> String
(Int -> RcvMessage -> ShowS)
-> (RcvMessage -> String)
-> ([RcvMessage] -> ShowS)
-> Show RcvMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RcvMessage -> ShowS
showsPrec :: Int -> RcvMessage -> ShowS
$cshow :: RcvMessage -> String
show :: RcvMessage -> String
$cshowList :: [RcvMessage] -> ShowS
showList :: [RcvMessage] -> ShowS
Show)

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

data FwdResponse = FwdResponse
  { FwdResponse -> CorrId
fwdCorrId :: CorrId,
    FwdResponse -> EncResponse
fwdResponse :: EncResponse
  }

instance Encoding FwdResponse where
  smpEncode :: FwdResponse -> MsgId
smpEncode FwdResponse {$sel:fwdCorrId:FwdResponse :: FwdResponse -> CorrId
fwdCorrId = CorrId MsgId
corrId, $sel:fwdResponse:FwdResponse :: FwdResponse -> EncResponse
fwdResponse = EncResponse MsgId
t} =
    (MsgId, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (MsgId
corrId, MsgId -> Tail
Tail MsgId
t)
  smpP :: Parser FwdResponse
smpP = do
    (MsgId
corrId, Tail MsgId
t) <- Parser (MsgId, Tail)
forall a. Encoding a => Parser a
smpP
    FwdResponse -> Parser FwdResponse
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FwdResponse {$sel:fwdCorrId:FwdResponse :: CorrId
fwdCorrId = MsgId -> CorrId
CorrId MsgId
corrId, $sel:fwdResponse:FwdResponse :: EncResponse
fwdResponse = MsgId -> EncResponse
EncResponse MsgId
t}

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

-- | received message without server/recipient encryption
data Message
  = Message
      { Message -> MsgId
msgId :: MsgId,
        Message -> SystemTime
msgTs :: SystemTime,
        Message -> MsgFlags
msgFlags :: MsgFlags,
        Message -> MaxLenBS MaxMessageLen
msgBody :: C.MaxLenBS MaxMessageLen
      }
  | MessageQuota
      { msgId :: MsgId,
        msgTs :: SystemTime
      }

toMsgInfo :: Message -> MsgInfo
toMsgInfo :: Message -> MsgInfo
toMsgInfo = \case
  Message {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs} -> MsgId -> SystemTime -> MsgType -> MsgInfo
msgInfo MsgId
msgId SystemTime
msgTs MsgType
MTMessage
  MessageQuota {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs} -> MsgId -> SystemTime -> MsgType -> MsgInfo
msgInfo MsgId
msgId SystemTime
msgTs MsgType
MTQuota
  where
    msgInfo :: MsgId -> SystemTime -> MsgType -> MsgInfo
msgInfo MsgId
msgId SystemTime
msgTs MsgType
msgType = MsgInfo {msgId :: Text
msgId = MsgId -> Text
decodeLatin1 (MsgId -> Text) -> MsgId -> Text
forall a b. (a -> b) -> a -> b
$ MsgId -> MsgId
B64.encode MsgId
msgId, msgTs :: UTCTime
msgTs = SystemTime -> UTCTime
systemToUTCTime SystemTime
msgTs, MsgType
msgType :: MsgType
msgType :: MsgType
msgType}

messageId :: Message -> MsgId
messageId :: Message -> MsgId
messageId = \case
  Message {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId} -> MsgId
msgId
  MessageQuota {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId} -> MsgId
msgId
{-# INLINE messageId #-}

messageTs :: Message -> SystemTime
messageTs :: Message -> SystemTime
messageTs = \case
  Message {SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs} -> SystemTime
msgTs
  MessageQuota {SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs} -> SystemTime
msgTs
{-# INLINE messageTs #-}

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

data RcvMsgBody
  = RcvMsgBody
      { RcvMsgBody -> SystemTime
msgTs :: SystemTime,
        RcvMsgBody -> MsgFlags
msgFlags :: MsgFlags,
        RcvMsgBody -> MaxLenBS MaxMessageLen
msgBody :: C.MaxLenBS MaxMessageLen
      }
  | RcvMsgQuota
      { msgTs :: SystemTime
      }

msgQuotaTag :: ByteString
msgQuotaTag :: MsgId
msgQuotaTag = MsgId
"QUOTA"

encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
encodeRcvMsgBody :: RcvMsgBody -> MaxLenBS MaxRcvMessageLen
encodeRcvMsgBody = \case
  RcvMsgBody {SystemTime
$sel:msgTs:RcvMsgBody :: RcvMsgBody -> SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:RcvMsgBody :: RcvMsgBody -> MsgFlags
msgFlags :: MsgFlags
msgFlags, MaxLenBS MaxMessageLen
$sel:msgBody:RcvMsgBody :: RcvMsgBody -> MaxLenBS MaxMessageLen
msgBody :: MaxLenBS MaxMessageLen
msgBody} ->
    let MaxLenBS 16
rcvMeta :: C.MaxLenBS 16 = MsgId -> MaxLenBS 16
forall (i :: Nat). KnownNat i => MsgId -> MaxLenBS i
C.unsafeMaxLenBS (MsgId -> MaxLenBS 16) -> MsgId -> MaxLenBS 16
forall a b. (a -> b) -> a -> b
$ (SystemTime, MsgFlags, Char) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (SystemTime
msgTs, MsgFlags
msgFlags, Char
' ')
     in MaxLenBS 16
-> MaxLenBS MaxMessageLen -> MaxLenBS (16 + MaxMessageLen)
forall (i :: Nat) (j :: Nat).
(KnownNat i, KnownNat j) =>
MaxLenBS i -> MaxLenBS j -> MaxLenBS (i + j)
C.appendMaxLenBS MaxLenBS 16
rcvMeta MaxLenBS MaxMessageLen
msgBody
  RcvMsgQuota {SystemTime
$sel:msgTs:RcvMsgBody :: RcvMsgBody -> SystemTime
msgTs :: SystemTime
msgTs} ->
    MsgId -> MaxLenBS MaxRcvMessageLen
forall (i :: Nat). KnownNat i => MsgId -> MaxLenBS i
C.unsafeMaxLenBS (MsgId -> MaxLenBS MaxRcvMessageLen)
-> MsgId -> MaxLenBS MaxRcvMessageLen
forall a b. (a -> b) -> a -> b
$ MsgId
msgQuotaTag MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
" " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> SystemTime -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode SystemTime
msgTs

data ClientRcvMsgBody
  = ClientRcvMsgBody
      { ClientRcvMsgBody -> SystemTime
msgTs :: SystemTime,
        ClientRcvMsgBody -> MsgFlags
msgFlags :: MsgFlags,
        ClientRcvMsgBody -> MsgId
msgBody :: ByteString
      }
  | ClientRcvMsgQuota
      { msgTs :: SystemTime
      }

clientRcvMsgBodyP :: Parser ClientRcvMsgBody
clientRcvMsgBodyP :: Parser ClientRcvMsgBody
clientRcvMsgBodyP = Parser ClientRcvMsgBody
msgQuotaP Parser ClientRcvMsgBody
-> Parser ClientRcvMsgBody -> Parser ClientRcvMsgBody
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ClientRcvMsgBody
msgBodyP
  where
    msgQuotaP :: Parser ClientRcvMsgBody
msgQuotaP = MsgId -> Parser MsgId MsgId
A.string MsgId
msgQuotaTag Parser MsgId MsgId
-> Parser ClientRcvMsgBody -> Parser ClientRcvMsgBody
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SystemTime -> ClientRcvMsgBody
ClientRcvMsgQuota (SystemTime -> ClientRcvMsgBody)
-> Parser MsgId SystemTime -> Parser ClientRcvMsgBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SystemTime
forall a. Encoding a => Parser a
_smpP)
    msgBodyP :: Parser ClientRcvMsgBody
msgBodyP = do
      SystemTime
msgTs <- Parser MsgId SystemTime
forall a. Encoding a => Parser a
smpP
      MsgFlags
msgFlags <- Parser MsgFlags
forall a. Encoding a => Parser a
smpP
      Tail MsgId
msgBody <- Parser Tail
forall a. Encoding a => Parser a
_smpP
      ClientRcvMsgBody -> Parser ClientRcvMsgBody
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientRcvMsgBody {SystemTime
$sel:msgTs:ClientRcvMsgBody :: SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:ClientRcvMsgBody :: MsgFlags
msgFlags :: MsgFlags
msgFlags, MsgId
$sel:msgBody:ClientRcvMsgBody :: MsgId
msgBody :: MsgId
msgBody}

instance StrEncoding Message where
  strEncode :: Message -> MsgId
strEncode = \case
    Message {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:Message :: Message -> MsgFlags
msgFlags :: MsgFlags
msgFlags, MaxLenBS MaxMessageLen
$sel:msgBody:Message :: Message -> MaxLenBS MaxMessageLen
msgBody :: MaxLenBS MaxMessageLen
msgBody} ->
      [MsgId] -> MsgId
B.unwords
        [ MsgId -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode MsgId
msgId,
          SystemTime -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode SystemTime
msgTs,
          MsgId
"flags=" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgFlags -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode MsgFlags
msgFlags,
          MaxLenBS MaxMessageLen -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode MaxLenBS MaxMessageLen
msgBody
        ]
    MessageQuota {MsgId
$sel:msgId:Message :: Message -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: Message -> SystemTime
msgTs :: SystemTime
msgTs} ->
      [MsgId] -> MsgId
B.unwords
        [ MsgId -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode MsgId
msgId,
          SystemTime -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode SystemTime
msgTs,
          MsgId
Item [MsgId]
"quota"
        ]
  strP :: Parser Message
strP = do
    MsgId
msgId <- Parser MsgId MsgId
forall a. StrEncoding a => Parser a
strP_
    SystemTime
msgTs <- Parser MsgId SystemTime
forall a. StrEncoding a => Parser a
strP_
    MsgId -> SystemTime -> Parser Message
forall {f :: * -> *} {a}.
(Functor f, IsString (f a)) =>
MsgId -> SystemTime -> f Message
msgQuotaP MsgId
msgId SystemTime
msgTs Parser Message -> Parser Message -> Parser Message
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MsgId -> SystemTime -> Parser Message
msgP MsgId
msgId SystemTime
msgTs
    where
      msgQuotaP :: MsgId -> SystemTime -> f Message
msgQuotaP MsgId
msgId SystemTime
msgTs = f a
"quota" f a -> Message -> f Message
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> MessageQuota {MsgId
$sel:msgId:Message :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: SystemTime
msgTs :: SystemTime
msgTs}
      msgP :: MsgId -> SystemTime -> Parser Message
msgP MsgId
msgId SystemTime
msgTs = do
        MsgFlags
msgFlags <- (Parser MsgId MsgId
"flags=" Parser MsgId MsgId -> Parser MsgFlags -> Parser MsgFlags
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser MsgFlags
forall a. StrEncoding a => Parser a
strP_) Parser MsgFlags -> Parser MsgFlags -> Parser MsgFlags
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MsgFlags -> Parser MsgFlags
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgFlags
noMsgFlags
        MaxLenBS MaxMessageLen
msgBody <- Parser (MaxLenBS MaxMessageLen)
forall a. StrEncoding a => Parser a
strP
        Message -> Parser Message
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message {MsgId
$sel:msgId:Message :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:Message :: SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:Message :: MsgFlags
msgFlags :: MsgFlags
msgFlags, MaxLenBS MaxMessageLen
$sel:msgBody:Message :: MaxLenBS MaxMessageLen
msgBody :: MaxLenBS MaxMessageLen
msgBody}

type EncNMsgMeta = ByteString

data SMPMsgMeta = SMPMsgMeta
  { SMPMsgMeta -> MsgId
msgId :: MsgId,
    SMPMsgMeta -> SystemTime
msgTs :: SystemTime,
    SMPMsgMeta -> MsgFlags
msgFlags :: MsgFlags
  }
  deriving (SMPMsgMeta -> SMPMsgMeta -> Bool
(SMPMsgMeta -> SMPMsgMeta -> Bool)
-> (SMPMsgMeta -> SMPMsgMeta -> Bool) -> Eq SMPMsgMeta
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMPMsgMeta -> SMPMsgMeta -> Bool
== :: SMPMsgMeta -> SMPMsgMeta -> Bool
$c/= :: SMPMsgMeta -> SMPMsgMeta -> Bool
/= :: SMPMsgMeta -> SMPMsgMeta -> Bool
Eq, Int -> SMPMsgMeta -> ShowS
[SMPMsgMeta] -> ShowS
SMPMsgMeta -> String
(Int -> SMPMsgMeta -> ShowS)
-> (SMPMsgMeta -> String)
-> ([SMPMsgMeta] -> ShowS)
-> Show SMPMsgMeta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMPMsgMeta -> ShowS
showsPrec :: Int -> SMPMsgMeta -> ShowS
$cshow :: SMPMsgMeta -> String
show :: SMPMsgMeta -> String
$cshowList :: [SMPMsgMeta] -> ShowS
showList :: [SMPMsgMeta] -> ShowS
Show)

instance StrEncoding SMPMsgMeta where
  strEncode :: SMPMsgMeta -> MsgId
strEncode SMPMsgMeta {MsgId
$sel:msgId:SMPMsgMeta :: SMPMsgMeta -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:SMPMsgMeta :: SMPMsgMeta -> SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:SMPMsgMeta :: SMPMsgMeta -> MsgFlags
msgFlags :: MsgFlags
msgFlags} =
    (MsgId, SystemTime, MsgFlags) -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode (MsgId
msgId, SystemTime
msgTs, MsgFlags
msgFlags)
  strP :: Parser SMPMsgMeta
strP = do
    (MsgId
msgId, SystemTime
msgTs, MsgFlags
msgFlags) <- Parser (MsgId, SystemTime, MsgFlags)
forall a. StrEncoding a => Parser a
strP
    SMPMsgMeta -> Parser SMPMsgMeta
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMPMsgMeta {MsgId
$sel:msgId:SMPMsgMeta :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:SMPMsgMeta :: SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:SMPMsgMeta :: MsgFlags
msgFlags :: MsgFlags
msgFlags}

rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
rcvMessageMeta :: MsgId -> ClientRcvMsgBody -> SMPMsgMeta
rcvMessageMeta MsgId
msgId = \case
  ClientRcvMsgBody {SystemTime
$sel:msgTs:ClientRcvMsgBody :: ClientRcvMsgBody -> SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:ClientRcvMsgBody :: ClientRcvMsgBody -> MsgFlags
msgFlags :: MsgFlags
msgFlags} -> SMPMsgMeta {MsgId
$sel:msgId:SMPMsgMeta :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:SMPMsgMeta :: SystemTime
msgTs :: SystemTime
msgTs, MsgFlags
$sel:msgFlags:SMPMsgMeta :: MsgFlags
msgFlags :: MsgFlags
msgFlags}
  ClientRcvMsgQuota {SystemTime
$sel:msgTs:ClientRcvMsgBody :: ClientRcvMsgBody -> SystemTime
msgTs :: SystemTime
msgTs} -> SMPMsgMeta {MsgId
$sel:msgId:SMPMsgMeta :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:SMPMsgMeta :: SystemTime
msgTs :: SystemTime
msgTs, $sel:msgFlags:SMPMsgMeta :: MsgFlags
msgFlags = MsgFlags
noMsgFlags}

data NMsgMeta = NMsgMeta
  { NMsgMeta -> MsgId
msgId :: MsgId,
    NMsgMeta -> SystemTime
msgTs :: SystemTime
  }
  deriving (Int -> NMsgMeta -> ShowS
[NMsgMeta] -> ShowS
NMsgMeta -> String
(Int -> NMsgMeta -> ShowS)
-> (NMsgMeta -> String) -> ([NMsgMeta] -> ShowS) -> Show NMsgMeta
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NMsgMeta -> ShowS
showsPrec :: Int -> NMsgMeta -> ShowS
$cshow :: NMsgMeta -> String
show :: NMsgMeta -> String
$cshowList :: [NMsgMeta] -> ShowS
showList :: [NMsgMeta] -> ShowS
Show)

instance Encoding NMsgMeta where
  smpEncode :: NMsgMeta -> MsgId
smpEncode NMsgMeta {MsgId
$sel:msgId:NMsgMeta :: NMsgMeta -> MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:NMsgMeta :: NMsgMeta -> SystemTime
msgTs :: SystemTime
msgTs} =
    (MsgId, SystemTime) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (MsgId
msgId, SystemTime
msgTs)
  smpP :: Parser NMsgMeta
smpP = do
    -- Tail here is to allow extension in the future clients/servers
    (MsgId
msgId, SystemTime
msgTs, Tail MsgId
_) <- Parser (MsgId, SystemTime, Tail)
forall a. Encoding a => Parser a
smpP
    NMsgMeta -> Parser NMsgMeta
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NMsgMeta {MsgId
$sel:msgId:NMsgMeta :: MsgId
msgId :: MsgId
msgId, SystemTime
$sel:msgTs:NMsgMeta :: SystemTime
msgTs :: SystemTime
msgTs}

-- it must be data for correct JSON encoding
data MsgFlags = MsgFlags {MsgFlags -> Bool
notification :: Bool}
  deriving (MsgFlags -> MsgFlags -> Bool
(MsgFlags -> MsgFlags -> Bool)
-> (MsgFlags -> MsgFlags -> Bool) -> Eq MsgFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MsgFlags -> MsgFlags -> Bool
== :: MsgFlags -> MsgFlags -> Bool
$c/= :: MsgFlags -> MsgFlags -> Bool
/= :: MsgFlags -> MsgFlags -> Bool
Eq, Int -> MsgFlags -> ShowS
[MsgFlags] -> ShowS
MsgFlags -> String
(Int -> MsgFlags -> ShowS)
-> (MsgFlags -> String) -> ([MsgFlags] -> ShowS) -> Show MsgFlags
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MsgFlags -> ShowS
showsPrec :: Int -> MsgFlags -> ShowS
$cshow :: MsgFlags -> String
show :: MsgFlags -> String
$cshowList :: [MsgFlags] -> ShowS
showList :: [MsgFlags] -> ShowS
Show)

-- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
instance Encoding MsgFlags where
  smpEncode :: MsgFlags -> MsgId
smpEncode MsgFlags {Bool
$sel:notification:MsgFlags :: MsgFlags -> Bool
notification :: Bool
notification} = Bool -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode Bool
notification
  smpP :: Parser MsgFlags
smpP = do
    Bool
notification <- Parser Bool
forall a. Encoding a => Parser a
smpP Parser Bool -> Parser MsgId MsgId -> Parser Bool
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
    MsgFlags -> Parser MsgFlags
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgFlags {Bool
$sel:notification:MsgFlags :: Bool
notification :: Bool
notification}

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

noMsgFlags :: MsgFlags
noMsgFlags :: MsgFlags
noMsgFlags = MsgFlags {$sel:notification:MsgFlags :: Bool
notification = Bool
False}

-- * SMP command tags

data CommandTag (p :: Party) where
  NEW_ :: CommandTag Creator
  SUB_ :: CommandTag Recipient
  SUBS_ :: CommandTag RecipientService
  KEY_ :: CommandTag Recipient
  RKEY_ :: CommandTag Recipient
  LSET_ :: CommandTag Recipient
  LDEL_ :: CommandTag Recipient
  NKEY_ :: CommandTag Recipient
  NDEL_ :: CommandTag Recipient
  GET_ :: CommandTag Recipient
  ACK_ :: CommandTag Recipient
  OFF_ :: CommandTag Recipient
  DEL_ :: CommandTag Recipient
  QUE_ :: CommandTag Recipient
  SKEY_ :: CommandTag Sender
  SEND_ :: CommandTag Sender
  PING_ :: CommandTag IdleClient
  LKEY_ :: CommandTag LinkClient
  LGET_ :: CommandTag LinkClient
  PRXY_ :: CommandTag ProxiedClient
  PFWD_ :: CommandTag ProxiedClient
  RFWD_ :: CommandTag ProxyService
  NSUB_ :: CommandTag Notifier
  NSUBS_ :: CommandTag NotifierService

data CmdTag = forall p. PartyI p => CT (SParty p) (CommandTag p)

deriving instance Show (CommandTag p)

deriving instance Show CmdTag

data BrokerMsgTag
  = IDS_
  | LNK_
  | SOK_
  | SOKS_
  | MSG_
  | NID_
  | NMSG_
  | PKEY_
  | RRES_
  | PRES_
  | END_
  | ENDS_
  | DELD_
  | INFO_
  | OK_
  | ERR_
  | PONG_
  deriving (Int -> BrokerMsgTag -> ShowS
[BrokerMsgTag] -> ShowS
BrokerMsgTag -> String
(Int -> BrokerMsgTag -> ShowS)
-> (BrokerMsgTag -> String)
-> ([BrokerMsgTag] -> ShowS)
-> Show BrokerMsgTag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BrokerMsgTag -> ShowS
showsPrec :: Int -> BrokerMsgTag -> ShowS
$cshow :: BrokerMsgTag -> String
show :: BrokerMsgTag -> String
$cshowList :: [BrokerMsgTag] -> ShowS
showList :: [BrokerMsgTag] -> ShowS
Show)

class ProtocolMsgTag t where
  decodeTag :: ByteString -> Maybe t

messageTagP :: ProtocolMsgTag t => Parser t
messageTagP :: forall t. ProtocolMsgTag t => Parser t
messageTagP =
  Parser MsgId t
-> (t -> Parser MsgId t) -> Maybe t -> Parser MsgId t
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser MsgId t
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad message") t -> Parser MsgId t
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe t -> Parser MsgId t)
-> (MsgId -> Maybe t) -> MsgId -> Parser MsgId t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> Maybe t
forall t. ProtocolMsgTag t => MsgId -> Maybe t
decodeTag
    (MsgId -> Parser MsgId t) -> Parser MsgId MsgId -> Parser MsgId t
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> Parser MsgId (Maybe Char) -> Parser MsgId MsgId
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Char -> Parser MsgId (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Char
A.space)

instance PartyI p => Encoding (CommandTag p) where
  smpEncode :: CommandTag p -> MsgId
smpEncode = \case
    CommandTag p
NEW_ -> MsgId
"NEW"
    CommandTag p
SUB_ -> MsgId
"SUB"
    CommandTag p
SUBS_ -> MsgId
"SUBS"
    CommandTag p
KEY_ -> MsgId
"KEY"
    CommandTag p
RKEY_ -> MsgId
"RKEY"
    CommandTag p
LSET_ -> MsgId
"LSET"
    CommandTag p
LDEL_ -> MsgId
"LDEL"
    CommandTag p
NKEY_ -> MsgId
"NKEY"
    CommandTag p
NDEL_ -> MsgId
"NDEL"
    CommandTag p
GET_ -> MsgId
"GET"
    CommandTag p
ACK_ -> MsgId
"ACK"
    CommandTag p
OFF_ -> MsgId
"OFF"
    CommandTag p
DEL_ -> MsgId
"DEL"
    CommandTag p
QUE_ -> MsgId
"QUE"
    CommandTag p
SKEY_ -> MsgId
"SKEY"
    CommandTag p
SEND_ -> MsgId
"SEND"
    CommandTag p
PING_ -> MsgId
"PING"
    CommandTag p
LKEY_ -> MsgId
"LKEY"
    CommandTag p
LGET_ -> MsgId
"LGET"
    CommandTag p
PRXY_ -> MsgId
"PRXY"
    CommandTag p
PFWD_ -> MsgId
"PFWD"
    CommandTag p
RFWD_ -> MsgId
"RFWD"
    CommandTag p
NSUB_ -> MsgId
"NSUB"
    CommandTag p
NSUBS_ -> MsgId
"NSUBS"
  smpP :: Parser (CommandTag p)
smpP = Parser (CommandTag p)
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance ProtocolMsgTag CmdTag where
  decodeTag :: MsgId -> Maybe CmdTag
decodeTag = \case
    MsgId
"NEW" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Creator -> CommandTag 'Creator -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Creator
SCreator CommandTag 'Creator
NEW_
    MsgId
"SUB" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
SUB_
    MsgId
"SUBS" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'RecipientService -> CommandTag 'RecipientService -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'RecipientService
SRecipientService CommandTag 'RecipientService
SUBS_
    MsgId
"KEY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
KEY_
    MsgId
"RKEY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
RKEY_
    MsgId
"LSET" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
LSET_
    MsgId
"LDEL" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
LDEL_
    MsgId
"NKEY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
NKEY_
    MsgId
"NDEL" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
NDEL_
    MsgId
"GET" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
GET_
    MsgId
"ACK" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
ACK_
    MsgId
"OFF" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
OFF_
    MsgId
"DEL" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
DEL_
    MsgId
"QUE" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Recipient -> CommandTag 'Recipient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Recipient
SRecipient CommandTag 'Recipient
QUE_
    MsgId
"SKEY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Sender -> CommandTag 'Sender -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Sender
SSender CommandTag 'Sender
SKEY_
    MsgId
"SEND" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Sender -> CommandTag 'Sender -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Sender
SSender CommandTag 'Sender
SEND_
    MsgId
"PING" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'IdleClient -> CommandTag 'IdleClient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'IdleClient
SIdleClient CommandTag 'IdleClient
PING_
    MsgId
"LKEY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'LinkClient -> CommandTag 'LinkClient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'LinkClient
SSenderLink CommandTag 'LinkClient
LKEY_
    MsgId
"LGET" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'LinkClient -> CommandTag 'LinkClient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'LinkClient
SSenderLink CommandTag 'LinkClient
LGET_
    MsgId
"PRXY" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'ProxiedClient -> CommandTag 'ProxiedClient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'ProxiedClient
SProxiedClient CommandTag 'ProxiedClient
PRXY_
    MsgId
"PFWD" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'ProxiedClient -> CommandTag 'ProxiedClient -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'ProxiedClient
SProxiedClient CommandTag 'ProxiedClient
PFWD_
    MsgId
"RFWD" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'ProxyService -> CommandTag 'ProxyService -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'ProxyService
SProxyService CommandTag 'ProxyService
RFWD_
    MsgId
"NSUB" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'Notifier -> CommandTag 'Notifier -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'Notifier
SNotifier CommandTag 'Notifier
NSUB_
    MsgId
"NSUBS" -> CmdTag -> Maybe CmdTag
forall a. a -> Maybe a
Just (CmdTag -> Maybe CmdTag) -> CmdTag -> Maybe CmdTag
forall a b. (a -> b) -> a -> b
$ SParty 'NotifierService -> CommandTag 'NotifierService -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT SParty 'NotifierService
SNotifierService CommandTag 'NotifierService
NSUBS_
    MsgId
_ -> Maybe CmdTag
forall a. Maybe a
Nothing

instance Encoding CmdTag where
  smpEncode :: CmdTag -> MsgId
smpEncode (CT SParty p
_ CommandTag p
t) = CommandTag p -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode CommandTag p
t
  smpP :: Parser CmdTag
smpP = Parser CmdTag
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance PartyI p => ProtocolMsgTag (CommandTag p) where
  decodeTag :: MsgId -> Maybe (CommandTag p)
decodeTag MsgId
s = MsgId -> Maybe CmdTag
forall t. ProtocolMsgTag t => MsgId -> Maybe t
decodeTag MsgId
s Maybe CmdTag
-> (CmdTag -> Maybe (CommandTag p)) -> Maybe (CommandTag p)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\(CT SParty p
_ CommandTag p
t) -> CommandTag p -> Maybe (CommandTag p)
forall (t :: Party -> *) (p :: Party) (p' :: Party).
(PartyI p, PartyI p') =>
t p' -> Maybe (t p)
checkParty' CommandTag p
t)

instance Encoding BrokerMsgTag where
  smpEncode :: BrokerMsgTag -> MsgId
smpEncode = \case
    BrokerMsgTag
IDS_ -> MsgId
"IDS"
    BrokerMsgTag
LNK_ -> MsgId
"LNK"
    BrokerMsgTag
SOK_ -> MsgId
"SOK"
    BrokerMsgTag
SOKS_ -> MsgId
"SOKS"
    BrokerMsgTag
MSG_ -> MsgId
"MSG"
    BrokerMsgTag
NID_ -> MsgId
"NID"
    BrokerMsgTag
NMSG_ -> MsgId
"NMSG"
    BrokerMsgTag
PKEY_ -> MsgId
"PKEY"
    BrokerMsgTag
RRES_ -> MsgId
"RRES"
    BrokerMsgTag
PRES_ -> MsgId
"PRES"
    BrokerMsgTag
END_ -> MsgId
"END"
    BrokerMsgTag
ENDS_ -> MsgId
"ENDS"
    BrokerMsgTag
DELD_ -> MsgId
"DELD"
    BrokerMsgTag
INFO_ -> MsgId
"INFO"
    BrokerMsgTag
OK_ -> MsgId
"OK"
    BrokerMsgTag
ERR_ -> MsgId
"ERR"
    BrokerMsgTag
PONG_ -> MsgId
"PONG"
  smpP :: Parser BrokerMsgTag
smpP = Parser BrokerMsgTag
forall t. ProtocolMsgTag t => Parser t
messageTagP

instance ProtocolMsgTag BrokerMsgTag where
  decodeTag :: MsgId -> Maybe BrokerMsgTag
decodeTag = \case
    MsgId
"IDS" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
IDS_
    MsgId
"LNK" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
LNK_
    MsgId
"SOK" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
SOK_
    MsgId
"SOKS" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
SOKS_
    MsgId
"MSG" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
MSG_
    MsgId
"NID" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
NID_
    MsgId
"NMSG" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
NMSG_
    MsgId
"PKEY" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
PKEY_
    MsgId
"RRES" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
RRES_
    MsgId
"PRES" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
PRES_
    MsgId
"END" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
END_
    MsgId
"ENDS" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
ENDS_
    MsgId
"DELD" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
DELD_
    MsgId
"INFO" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
INFO_
    MsgId
"OK" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
OK_
    MsgId
"ERR" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
ERR_
    MsgId
"PONG" -> BrokerMsgTag -> Maybe BrokerMsgTag
forall a. a -> Maybe a
Just BrokerMsgTag
PONG_
    MsgId
_ -> Maybe BrokerMsgTag
forall a. Maybe a
Nothing

-- | SMP message body format
data ClientMsgEnvelope = ClientMsgEnvelope
  { ClientMsgEnvelope -> PubHeader
cmHeader :: PubHeader,
    ClientMsgEnvelope -> CbNonce
cmNonce :: C.CbNonce,
    ClientMsgEnvelope -> MsgId
cmEncBody :: ByteString
  }
  deriving (Int -> ClientMsgEnvelope -> ShowS
[ClientMsgEnvelope] -> ShowS
ClientMsgEnvelope -> String
(Int -> ClientMsgEnvelope -> ShowS)
-> (ClientMsgEnvelope -> String)
-> ([ClientMsgEnvelope] -> ShowS)
-> Show ClientMsgEnvelope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClientMsgEnvelope -> ShowS
showsPrec :: Int -> ClientMsgEnvelope -> ShowS
$cshow :: ClientMsgEnvelope -> String
show :: ClientMsgEnvelope -> String
$cshowList :: [ClientMsgEnvelope] -> ShowS
showList :: [ClientMsgEnvelope] -> ShowS
Show)

data PubHeader = PubHeader
  { PubHeader -> VersionSMPC
phVersion :: VersionSMPC,
    PubHeader -> Maybe RcvNtfPublicDhKey
phE2ePubDhKey :: Maybe C.PublicKeyX25519
  }
  deriving (Int -> PubHeader -> ShowS
[PubHeader] -> ShowS
PubHeader -> String
(Int -> PubHeader -> ShowS)
-> (PubHeader -> String)
-> ([PubHeader] -> ShowS)
-> Show PubHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PubHeader -> ShowS
showsPrec :: Int -> PubHeader -> ShowS
$cshow :: PubHeader -> String
show :: PubHeader -> String
$cshowList :: [PubHeader] -> ShowS
showList :: [PubHeader] -> ShowS
Show)

instance Encoding PubHeader where
  smpEncode :: PubHeader -> MsgId
smpEncode (PubHeader VersionSMPC
v Maybe RcvNtfPublicDhKey
k) = (VersionSMPC, Maybe RcvNtfPublicDhKey) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (VersionSMPC
v, Maybe RcvNtfPublicDhKey
k)
  smpP :: Parser PubHeader
smpP = VersionSMPC -> Maybe RcvNtfPublicDhKey -> PubHeader
PubHeader (VersionSMPC -> Maybe RcvNtfPublicDhKey -> PubHeader)
-> Parser MsgId VersionSMPC
-> Parser MsgId (Maybe RcvNtfPublicDhKey -> PubHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId VersionSMPC
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe RcvNtfPublicDhKey -> PubHeader)
-> Parser MsgId (Maybe RcvNtfPublicDhKey) -> Parser PubHeader
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId (Maybe RcvNtfPublicDhKey)
forall a. Encoding a => Parser a
smpP

instance Encoding ClientMsgEnvelope where
  smpEncode :: ClientMsgEnvelope -> MsgId
smpEncode ClientMsgEnvelope {PubHeader
$sel:cmHeader:ClientMsgEnvelope :: ClientMsgEnvelope -> PubHeader
cmHeader :: PubHeader
cmHeader, CbNonce
$sel:cmNonce:ClientMsgEnvelope :: ClientMsgEnvelope -> CbNonce
cmNonce :: CbNonce
cmNonce, MsgId
$sel:cmEncBody:ClientMsgEnvelope :: ClientMsgEnvelope -> MsgId
cmEncBody :: MsgId
cmEncBody} =
    (PubHeader, CbNonce, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (PubHeader
cmHeader, CbNonce
cmNonce, MsgId -> Tail
Tail MsgId
cmEncBody)
  smpP :: Parser ClientMsgEnvelope
smpP = do
    (PubHeader
cmHeader, CbNonce
cmNonce, Tail MsgId
cmEncBody) <- Parser (PubHeader, CbNonce, Tail)
forall a. Encoding a => Parser a
smpP
    ClientMsgEnvelope -> Parser ClientMsgEnvelope
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientMsgEnvelope {PubHeader
$sel:cmHeader:ClientMsgEnvelope :: PubHeader
cmHeader :: PubHeader
cmHeader, CbNonce
$sel:cmNonce:ClientMsgEnvelope :: CbNonce
cmNonce :: CbNonce
cmNonce, MsgId
$sel:cmEncBody:ClientMsgEnvelope :: MsgId
cmEncBody :: MsgId
cmEncBody}

data ClientMessage = ClientMessage PrivHeader ByteString

data PrivHeader
  = PHConfirmation C.APublicAuthKey
  | PHEmpty
  deriving (Int -> PrivHeader -> ShowS
[PrivHeader] -> ShowS
PrivHeader -> String
(Int -> PrivHeader -> ShowS)
-> (PrivHeader -> String)
-> ([PrivHeader] -> ShowS)
-> Show PrivHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrivHeader -> ShowS
showsPrec :: Int -> PrivHeader -> ShowS
$cshow :: PrivHeader -> String
show :: PrivHeader -> String
$cshowList :: [PrivHeader] -> ShowS
showList :: [PrivHeader] -> ShowS
Show)

instance Encoding PrivHeader where
  smpEncode :: PrivHeader -> MsgId
smpEncode = \case
    PHConfirmation SndPublicAuthKey
k -> MsgId
"K" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> SndPublicAuthKey -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode SndPublicAuthKey
k
    PrivHeader
PHEmpty -> MsgId
"_"
  smpP :: Parser PrivHeader
smpP =
    Parser Char
A.anyChar Parser Char -> (Char -> Parser PrivHeader) -> Parser PrivHeader
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
'K' -> SndPublicAuthKey -> PrivHeader
PHConfirmation (SndPublicAuthKey -> PrivHeader)
-> Parser MsgId SndPublicAuthKey -> Parser PrivHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
smpP
      Char
'_' -> PrivHeader -> Parser PrivHeader
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PrivHeader
PHEmpty
      Char
_ -> String -> Parser PrivHeader
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid PrivHeader"

instance Encoding ClientMessage where
  smpEncode :: ClientMessage -> MsgId
smpEncode (ClientMessage PrivHeader
h MsgId
msg) = PrivHeader -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode PrivHeader
h MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
msg
  smpP :: Parser ClientMessage
smpP = PrivHeader -> MsgId -> ClientMessage
ClientMessage (PrivHeader -> MsgId -> ClientMessage)
-> Parser PrivHeader -> Parser MsgId (MsgId -> ClientMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PrivHeader
forall a. Encoding a => Parser a
smpP Parser MsgId (MsgId -> ClientMessage)
-> Parser MsgId MsgId -> Parser ClientMessage
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId MsgId
A.takeByteString

type SMPServer = ProtocolServer 'PSMP

pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
pattern $mSMPServer :: forall {r}.
SMPServer
-> (NonEmpty TransportHost -> String -> KeyHash -> r)
-> ((# #) -> r)
-> r
$bSMPServer :: NonEmpty TransportHost -> String -> KeyHash -> SMPServer
SMPServer host port keyHash = ProtocolServer SPSMP host port keyHash

{-# COMPLETE SMPServer #-}

type SMPServerWithAuth = ProtoServerWithAuth 'PSMP

type NtfServer = ProtocolServer 'PNTF

pattern NtfServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PNTF
pattern $mNtfServer :: forall {r}.
ProtocolServer 'PNTF
-> (NonEmpty TransportHost -> String -> KeyHash -> r)
-> ((# #) -> r)
-> r
$bNtfServer :: NonEmpty TransportHost -> String -> KeyHash -> ProtocolServer 'PNTF
NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash

{-# COMPLETE NtfServer #-}

type NtfServerWithAuth = ProtoServerWithAuth 'PNTF

type XFTPServer = ProtocolServer 'PXFTP

pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP
pattern $mXFTPServer :: forall {r}.
ProtocolServer 'PXFTP
-> (NonEmpty TransportHost -> String -> KeyHash -> r)
-> ((# #) -> r)
-> r
$bXFTPServer :: NonEmpty TransportHost
-> String -> KeyHash -> ProtocolServer 'PXFTP
XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash

{-# COMPLETE XFTPServer #-}

type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP

sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
sameSrvAddr' :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
sameSrvAddr' (ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
_) (ProtoServerWithAuth ProtocolServer p
srv' Maybe BasicAuth
_) = ProtocolServer p -> ProtocolServer p -> Bool
forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
sameSrvAddr ProtocolServer p
srv ProtocolServer p
srv'
{-# INLINE sameSrvAddr' #-}

sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
sameSrvAddr :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
sameSrvAddr ProtocolServer {NonEmpty TransportHost
host :: NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host, String
port :: String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port} ProtocolServer {$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host = NonEmpty TransportHost
h', $sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port = String
p'} = NonEmpty TransportHost
host NonEmpty TransportHost -> NonEmpty TransportHost -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty TransportHost
h' Bool -> Bool -> Bool
&& String
port String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
p'
{-# INLINE sameSrvAddr #-}

data ProtocolType = PSMP | PNTF | PXFTP
  deriving (ProtocolType -> ProtocolType -> Bool
(ProtocolType -> ProtocolType -> Bool)
-> (ProtocolType -> ProtocolType -> Bool) -> Eq ProtocolType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolType -> ProtocolType -> Bool
== :: ProtocolType -> ProtocolType -> Bool
$c/= :: ProtocolType -> ProtocolType -> Bool
/= :: ProtocolType -> ProtocolType -> Bool
Eq, Eq ProtocolType
Eq ProtocolType =>
(ProtocolType -> ProtocolType -> Ordering)
-> (ProtocolType -> ProtocolType -> Bool)
-> (ProtocolType -> ProtocolType -> Bool)
-> (ProtocolType -> ProtocolType -> Bool)
-> (ProtocolType -> ProtocolType -> Bool)
-> (ProtocolType -> ProtocolType -> ProtocolType)
-> (ProtocolType -> ProtocolType -> ProtocolType)
-> Ord ProtocolType
ProtocolType -> ProtocolType -> Bool
ProtocolType -> ProtocolType -> Ordering
ProtocolType -> ProtocolType -> ProtocolType
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 :: ProtocolType -> ProtocolType -> Ordering
compare :: ProtocolType -> ProtocolType -> Ordering
$c< :: ProtocolType -> ProtocolType -> Bool
< :: ProtocolType -> ProtocolType -> Bool
$c<= :: ProtocolType -> ProtocolType -> Bool
<= :: ProtocolType -> ProtocolType -> Bool
$c> :: ProtocolType -> ProtocolType -> Bool
> :: ProtocolType -> ProtocolType -> Bool
$c>= :: ProtocolType -> ProtocolType -> Bool
>= :: ProtocolType -> ProtocolType -> Bool
$cmax :: ProtocolType -> ProtocolType -> ProtocolType
max :: ProtocolType -> ProtocolType -> ProtocolType
$cmin :: ProtocolType -> ProtocolType -> ProtocolType
min :: ProtocolType -> ProtocolType -> ProtocolType
Ord, Int -> ProtocolType -> ShowS
[ProtocolType] -> ShowS
ProtocolType -> String
(Int -> ProtocolType -> ShowS)
-> (ProtocolType -> String)
-> ([ProtocolType] -> ShowS)
-> Show ProtocolType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProtocolType -> ShowS
showsPrec :: Int -> ProtocolType -> ShowS
$cshow :: ProtocolType -> String
show :: ProtocolType -> String
$cshowList :: [ProtocolType] -> ShowS
showList :: [ProtocolType] -> ShowS
Show)

instance StrEncoding ProtocolType where
  strEncode :: ProtocolType -> MsgId
strEncode = \case
    ProtocolType
PSMP -> MsgId
"smp"
    ProtocolType
PNTF -> MsgId
"ntf"
    ProtocolType
PXFTP -> MsgId
"xftp"
  strP :: Parser ProtocolType
strP =
    (Char -> Bool) -> Parser MsgId MsgId
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 MsgId MsgId
-> (MsgId -> Parser ProtocolType) -> Parser ProtocolType
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"smp" -> ProtocolType -> Parser ProtocolType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolType
PSMP
      MsgId
"ntf" -> ProtocolType -> Parser ProtocolType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolType
PNTF
      MsgId
"xftp" -> ProtocolType -> Parser ProtocolType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolType
PXFTP
      MsgId
_ -> String -> Parser ProtocolType
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ProtocolType"

data SProtocolType (p :: ProtocolType) where
  SPSMP :: SProtocolType 'PSMP
  SPNTF :: SProtocolType 'PNTF
  SPXFTP :: SProtocolType 'PXFTP

deriving instance Eq (SProtocolType p)

deriving instance Ord (SProtocolType p)

deriving instance Show (SProtocolType p)

data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)

instance Eq AProtocolType where
  AProtocolType SProtocolType p
p == :: AProtocolType -> AProtocolType -> Bool
== AProtocolType SProtocolType p
p' = Maybe (p :~: p) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (p :~: p) -> Bool) -> Maybe (p :~: p) -> Bool
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> SProtocolType p -> Maybe (p :~: p)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: ProtocolType) (b :: ProtocolType).
SProtocolType a -> SProtocolType b -> Maybe (a :~: b)
testEquality SProtocolType p
p SProtocolType p
p'

deriving instance Show AProtocolType

instance TestEquality SProtocolType where
  testEquality :: forall (a :: ProtocolType) (b :: ProtocolType).
SProtocolType a -> SProtocolType b -> Maybe (a :~: b)
testEquality SProtocolType a
SPSMP SProtocolType b
SPSMP = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SProtocolType a
SPNTF SProtocolType b
SPNTF = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SProtocolType a
SPXFTP SProtocolType b
SPXFTP = (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
  testEquality SProtocolType a
_ SProtocolType b
_ = Maybe (a :~: b)
forall a. Maybe a
Nothing

protocolType :: SProtocolType p -> ProtocolType
protocolType :: forall (p :: ProtocolType). SProtocolType p -> ProtocolType
protocolType = \case
  SProtocolType p
SPSMP -> ProtocolType
PSMP
  SProtocolType p
SPNTF -> ProtocolType
PNTF
  SProtocolType p
SPXFTP -> ProtocolType
PXFTP

aProtocolType :: ProtocolType -> AProtocolType
aProtocolType :: ProtocolType -> AProtocolType
aProtocolType = \case
  ProtocolType
PSMP -> SProtocolType 'PSMP -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType 'PSMP
SPSMP
  ProtocolType
PNTF -> SProtocolType 'PNTF -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType 'PNTF
SPNTF
  ProtocolType
PXFTP -> SProtocolType 'PXFTP -> AProtocolType
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> AProtocolType
AProtocolType SProtocolType 'PXFTP
SPXFTP

instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
  strEncode :: SProtocolType p -> MsgId
strEncode = ProtocolType -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode (ProtocolType -> MsgId)
-> (SProtocolType p -> ProtocolType) -> SProtocolType p -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SProtocolType p -> ProtocolType
forall (p :: ProtocolType). SProtocolType p -> ProtocolType
protocolType
  strP :: Parser (SProtocolType p)
strP = (\(AProtocolType SProtocolType p
p) -> SProtocolType p -> Either String (SProtocolType p)
forall (t :: ProtocolType -> *) (p :: ProtocolType)
       (p' :: ProtocolType).
(ProtocolTypeI p, ProtocolTypeI p') =>
t p' -> Either String (t p)
checkProtocolType SProtocolType p
p) (AProtocolType -> Either String (SProtocolType p))
-> Parser MsgId AProtocolType -> Parser (SProtocolType p)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser MsgId AProtocolType
forall a. StrEncoding a => Parser a
strP

instance StrEncoding AProtocolType where
  strEncode :: AProtocolType -> MsgId
strEncode (AProtocolType SProtocolType p
p) = SProtocolType p -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode SProtocolType p
p
  strP :: Parser MsgId AProtocolType
strP = ProtocolType -> AProtocolType
aProtocolType (ProtocolType -> AProtocolType)
-> Parser ProtocolType -> Parser MsgId AProtocolType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ProtocolType
forall a. StrEncoding a => Parser a
strP

instance ProtocolTypeI p => ToJSON (SProtocolType p) where
  toEncoding :: SProtocolType p -> Encoding
toEncoding = SProtocolType p -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding
  toJSON :: SProtocolType p -> Value
toJSON = SProtocolType p -> Value
forall a. StrEncoding a => a -> Value
strToJSON

instance ProtocolTypeI p => FromJSON (SProtocolType p) where
  parseJSON :: Value -> Parser (SProtocolType p)
parseJSON = String -> Value -> Parser (SProtocolType p)
forall a. StrEncoding a => String -> Value -> Parser a
strParseJSON String
"SProtocolType"

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

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

checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
checkProtocolType :: forall (t :: ProtocolType -> *) (p :: ProtocolType)
       (p' :: ProtocolType).
(ProtocolTypeI p, ProtocolTypeI p') =>
t p' -> Either String (t p)
checkProtocolType t p'
p = case SProtocolType p -> SProtocolType p' -> Maybe (p :~: p')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: ProtocolType) (b :: ProtocolType).
SProtocolType a -> SProtocolType b -> Maybe (a :~: b)
testEquality (forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p) (forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p') of
  Just p :~: p'
Refl -> t p -> Either String (t p)
forall a b. b -> Either a b
Right t p
t p'
p
  Maybe (p :~: p')
Nothing -> String -> Either String (t p)
forall a b. a -> Either a b
Left String
"bad ProtocolType"

class ProtocolTypeI (p :: ProtocolType) where
  protocolTypeI :: SProtocolType p

instance ProtocolTypeI 'PSMP where protocolTypeI :: SProtocolType 'PSMP
protocolTypeI = SProtocolType 'PSMP
SPSMP

instance ProtocolTypeI 'PNTF where protocolTypeI :: SProtocolType 'PNTF
protocolTypeI = SProtocolType 'PNTF
SPNTF

instance ProtocolTypeI 'PXFTP where protocolTypeI :: SProtocolType 'PXFTP
protocolTypeI = SProtocolType 'PXFTP
SPXFTP

type family UserProtocol (p :: ProtocolType) :: Constraint where
  UserProtocol PSMP = ()
  UserProtocol PXFTP = ()
  UserProtocol a =
    (Int ~ Bool, TypeError (TE.Text "Servers for protocol " :<>: ShowType a :<>: TE.Text " cannot be configured by the users"))

userProtocol :: SProtocolType p -> Maybe (Dict (UserProtocol p))
userProtocol :: forall (p :: ProtocolType).
SProtocolType p -> Maybe (Dict (UserProtocol p))
userProtocol = \case
  SProtocolType p
SPSMP -> Dict (() :: Constraint) -> Maybe (Dict (() :: Constraint))
forall a. a -> Maybe a
Just Dict (() :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SProtocolType p
SPXFTP -> Dict (() :: Constraint) -> Maybe (Dict (() :: Constraint))
forall a. a -> Maybe a
Just Dict (() :: Constraint)
forall (a :: Constraint). a => Dict a
Dict
  SProtocolType p
_ -> Maybe (Dict (UserProtocol p))
forall a. Maybe a
Nothing

-- | server location and transport key digest (hash).
data ProtocolServer p = ProtocolServer
  { forall (p :: ProtocolType). ProtocolServer p -> SProtocolType p
scheme :: SProtocolType p,
    forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost,
    forall (p :: ProtocolType). ProtocolServer p -> String
port :: ServiceName,
    forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: C.KeyHash
  }
  deriving (ProtocolServer p -> ProtocolServer p -> Bool
(ProtocolServer p -> ProtocolServer p -> Bool)
-> (ProtocolServer p -> ProtocolServer p -> Bool)
-> Eq (ProtocolServer p)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
$c== :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
== :: ProtocolServer p -> ProtocolServer p -> Bool
$c/= :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
/= :: ProtocolServer p -> ProtocolServer p -> Bool
Eq, Eq (ProtocolServer p)
Eq (ProtocolServer p) =>
(ProtocolServer p -> ProtocolServer p -> Ordering)
-> (ProtocolServer p -> ProtocolServer p -> Bool)
-> (ProtocolServer p -> ProtocolServer p -> Bool)
-> (ProtocolServer p -> ProtocolServer p -> Bool)
-> (ProtocolServer p -> ProtocolServer p -> Bool)
-> (ProtocolServer p -> ProtocolServer p -> ProtocolServer p)
-> (ProtocolServer p -> ProtocolServer p -> ProtocolServer p)
-> Ord (ProtocolServer p)
ProtocolServer p -> ProtocolServer p -> Bool
ProtocolServer p -> ProtocolServer p -> Ordering
ProtocolServer p -> ProtocolServer p -> ProtocolServer p
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
forall (p :: ProtocolType). Eq (ProtocolServer p)
forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Ordering
forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> ProtocolServer p
$ccompare :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Ordering
compare :: ProtocolServer p -> ProtocolServer p -> Ordering
$c< :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
< :: ProtocolServer p -> ProtocolServer p -> Bool
$c<= :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
<= :: ProtocolServer p -> ProtocolServer p -> Bool
$c> :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
> :: ProtocolServer p -> ProtocolServer p -> Bool
$c>= :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> Bool
>= :: ProtocolServer p -> ProtocolServer p -> Bool
$cmax :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> ProtocolServer p
max :: ProtocolServer p -> ProtocolServer p -> ProtocolServer p
$cmin :: forall (p :: ProtocolType).
ProtocolServer p -> ProtocolServer p -> ProtocolServer p
min :: ProtocolServer p -> ProtocolServer p -> ProtocolServer p
Ord, Int -> ProtocolServer p -> ShowS
[ProtocolServer p] -> ShowS
ProtocolServer p -> String
(Int -> ProtocolServer p -> ShowS)
-> (ProtocolServer p -> String)
-> ([ProtocolServer p] -> ShowS)
-> Show (ProtocolServer p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (p :: ProtocolType). Int -> ProtocolServer p -> ShowS
forall (p :: ProtocolType). [ProtocolServer p] -> ShowS
forall (p :: ProtocolType). ProtocolServer p -> String
$cshowsPrec :: forall (p :: ProtocolType). Int -> ProtocolServer p -> ShowS
showsPrec :: Int -> ProtocolServer p -> ShowS
$cshow :: forall (p :: ProtocolType). ProtocolServer p -> String
show :: ProtocolServer p -> String
$cshowList :: forall (p :: ProtocolType). [ProtocolServer p] -> ShowS
showList :: [ProtocolServer p] -> ShowS
Show)

data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p)

instance ProtocolTypeI p => IsString (ProtocolServer p) where
  fromString :: String -> ProtocolServer p
fromString = (MsgId -> Either String (ProtocolServer p))
-> String -> ProtocolServer p
forall a. (MsgId -> Either String a) -> String -> a
parseString MsgId -> Either String (ProtocolServer p)
forall a. StrEncoding a => MsgId -> Either String a
strDecode

instance ProtocolTypeI p => Encoding (ProtocolServer p) where
  smpEncode :: ProtocolServer p -> MsgId
smpEncode ProtocolServer {NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: KeyHash
keyHash} =
    (NonEmpty TransportHost, String, KeyHash) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (NonEmpty TransportHost
host, String
port, KeyHash
keyHash)
  smpP :: Parser (ProtocolServer p)
smpP = do
    (NonEmpty TransportHost
host, String
port, KeyHash
keyHash) <- Parser (NonEmpty TransportHost, String, KeyHash)
forall a. Encoding a => Parser a
smpP
    ProtocolServer p -> Parser (ProtocolServer p)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolServer {$sel:scheme:ProtocolServer :: SProtocolType p
scheme = forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p, NonEmpty TransportHost
$sel:host:ProtocolServer :: NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: KeyHash
keyHash :: KeyHash
keyHash}

instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
  strEncode :: ProtocolServer p -> MsgId
strEncode ProtocolServer {SProtocolType p
$sel:scheme:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> SProtocolType p
scheme :: SProtocolType p
scheme, NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: KeyHash
keyHash} =
    SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
strEncodeServer SProtocolType p
scheme (NonEmpty TransportHost -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode NonEmpty TransportHost
host) String
port KeyHash
keyHash Maybe BasicAuth
forall a. Maybe a
Nothing
  strP :: Parser (ProtocolServer p)
strP =
    Parser (AProtocolServer, Maybe BasicAuth)
serverStrP Parser (AProtocolServer, Maybe BasicAuth)
-> ((AProtocolServer, Maybe BasicAuth)
    -> Parser (ProtocolServer p))
-> Parser (ProtocolServer p)
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (AProtocolServer SProtocolType p
_ ProtocolServer p
srv, Maybe BasicAuth
Nothing) -> (String -> Parser (ProtocolServer p))
-> (ProtocolServer p -> Parser (ProtocolServer p))
-> Either String (ProtocolServer p)
-> Parser (ProtocolServer p)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser (ProtocolServer p)
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ProtocolServer p -> Parser (ProtocolServer p)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (ProtocolServer p) -> Parser (ProtocolServer p))
-> Either String (ProtocolServer p) -> Parser (ProtocolServer p)
forall a b. (a -> b) -> a -> b
$ ProtocolServer p -> Either String (ProtocolServer p)
forall (t :: ProtocolType -> *) (p :: ProtocolType)
       (p' :: ProtocolType).
(ProtocolTypeI p, ProtocolTypeI p') =>
t p' -> Either String (t p)
checkProtocolType ProtocolServer p
srv
      (AProtocolServer, Maybe BasicAuth)
_ -> String -> Parser (ProtocolServer p)
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ProtocolServer with basic auth not allowed"

instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
  toJSON :: ProtocolServer p -> Value
toJSON = ProtocolServer p -> Value
forall a. StrEncoding a => a -> Value
strToJSON
  toEncoding :: ProtocolServer p -> Encoding
toEncoding = ProtocolServer p -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding

instance ProtocolTypeI p => FromJSON (ProtocolServer p) where
  parseJSON :: Value -> Parser (ProtocolServer p)
parseJSON = String -> Value -> Parser (ProtocolServer p)
forall a. StrEncoding a => String -> Value -> Parser a
strParseJSON String
"ProtocolServer"

newtype BasicAuth = BasicAuth {BasicAuth -> MsgId
unBasicAuth :: ByteString}
  deriving (BasicAuth -> BasicAuth -> Bool
(BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool) -> Eq BasicAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BasicAuth -> BasicAuth -> Bool
== :: BasicAuth -> BasicAuth -> Bool
$c/= :: BasicAuth -> BasicAuth -> Bool
/= :: BasicAuth -> BasicAuth -> Bool
Eq, Eq BasicAuth
Eq BasicAuth =>
(BasicAuth -> BasicAuth -> Ordering)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> Bool)
-> (BasicAuth -> BasicAuth -> BasicAuth)
-> (BasicAuth -> BasicAuth -> BasicAuth)
-> Ord BasicAuth
BasicAuth -> BasicAuth -> Bool
BasicAuth -> BasicAuth -> Ordering
BasicAuth -> BasicAuth -> BasicAuth
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 :: BasicAuth -> BasicAuth -> Ordering
compare :: BasicAuth -> BasicAuth -> Ordering
$c< :: BasicAuth -> BasicAuth -> Bool
< :: BasicAuth -> BasicAuth -> Bool
$c<= :: BasicAuth -> BasicAuth -> Bool
<= :: BasicAuth -> BasicAuth -> Bool
$c> :: BasicAuth -> BasicAuth -> Bool
> :: BasicAuth -> BasicAuth -> Bool
$c>= :: BasicAuth -> BasicAuth -> Bool
>= :: BasicAuth -> BasicAuth -> Bool
$cmax :: BasicAuth -> BasicAuth -> BasicAuth
max :: BasicAuth -> BasicAuth -> BasicAuth
$cmin :: BasicAuth -> BasicAuth -> BasicAuth
min :: BasicAuth -> BasicAuth -> BasicAuth
Ord, Int -> BasicAuth -> ShowS
[BasicAuth] -> ShowS
BasicAuth -> String
(Int -> BasicAuth -> ShowS)
-> (BasicAuth -> String)
-> ([BasicAuth] -> ShowS)
-> Show BasicAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BasicAuth -> ShowS
showsPrec :: Int -> BasicAuth -> ShowS
$cshow :: BasicAuth -> String
show :: BasicAuth -> String
$cshowList :: [BasicAuth] -> ShowS
showList :: [BasicAuth] -> ShowS
Show)

instance IsString BasicAuth where fromString :: String -> BasicAuth
fromString = MsgId -> BasicAuth
BasicAuth (MsgId -> BasicAuth) -> (String -> MsgId) -> String -> BasicAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MsgId
B.pack

instance Encoding BasicAuth where
  smpEncode :: BasicAuth -> MsgId
smpEncode (BasicAuth MsgId
s) = MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode MsgId
s
  smpP :: Parser BasicAuth
smpP = MsgId -> Either String BasicAuth
basicAuth (MsgId -> Either String BasicAuth)
-> Parser MsgId MsgId -> Parser BasicAuth
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser MsgId MsgId
forall a. Encoding a => Parser a
smpP

instance StrEncoding BasicAuth where
  strEncode :: BasicAuth -> MsgId
strEncode (BasicAuth MsgId
s) = MsgId
s
  strP :: Parser BasicAuth
strP = MsgId -> Either String BasicAuth
basicAuth (MsgId -> Either String BasicAuth)
-> Parser MsgId MsgId -> Parser BasicAuth
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> (Char -> Bool) -> Parser MsgId MsgId
A.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'@')

basicAuth :: ByteString -> Either String BasicAuth
basicAuth :: MsgId -> Either String BasicAuth
basicAuth MsgId
s
  | (Char -> Bool) -> MsgId -> Bool
B.all Char -> Bool
valid MsgId
s = BasicAuth -> Either String BasicAuth
forall a b. b -> Either a b
Right (BasicAuth -> Either String BasicAuth)
-> BasicAuth -> Either String BasicAuth
forall a b. (a -> b) -> a -> b
$ MsgId -> BasicAuth
BasicAuth MsgId
s
  | Bool
otherwise = String -> Either String BasicAuth
forall a b. a -> Either a b
Left String
"invalid character in BasicAuth"
  where
    valid :: Char -> Bool
valid Char
c = Char -> Bool
isPrint Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& 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
':' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/'

data ProtoServerWithAuth p = ProtoServerWithAuth {forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtocolServer p
protoServer :: ProtocolServer p, forall (p :: ProtocolType).
ProtoServerWithAuth p -> Maybe BasicAuth
serverBasicAuth :: Maybe BasicAuth}
  deriving (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
(ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> Eq (ProtoServerWithAuth p)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$c== :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
== :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$c/= :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
/= :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
Eq, Eq (ProtoServerWithAuth p)
Eq (ProtoServerWithAuth p) =>
(ProtoServerWithAuth p -> ProtoServerWithAuth p -> Ordering)
-> (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> (ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool)
-> (ProtoServerWithAuth p
    -> ProtoServerWithAuth p -> ProtoServerWithAuth p)
-> (ProtoServerWithAuth p
    -> ProtoServerWithAuth p -> ProtoServerWithAuth p)
-> Ord (ProtoServerWithAuth p)
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Ordering
ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
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
forall (p :: ProtocolType). Eq (ProtoServerWithAuth p)
forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Ordering
forall (p :: ProtocolType).
ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
$ccompare :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Ordering
compare :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Ordering
$c< :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
< :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$c<= :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
<= :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$c> :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
> :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$c>= :: forall (p :: ProtocolType).
ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
>= :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
$cmax :: forall (p :: ProtocolType).
ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
max :: ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
$cmin :: forall (p :: ProtocolType).
ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
min :: ProtoServerWithAuth p
-> ProtoServerWithAuth p -> ProtoServerWithAuth p
Ord, Int -> ProtoServerWithAuth p -> ShowS
[ProtoServerWithAuth p] -> ShowS
ProtoServerWithAuth p -> String
(Int -> ProtoServerWithAuth p -> ShowS)
-> (ProtoServerWithAuth p -> String)
-> ([ProtoServerWithAuth p] -> ShowS)
-> Show (ProtoServerWithAuth p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (p :: ProtocolType). Int -> ProtoServerWithAuth p -> ShowS
forall (p :: ProtocolType). [ProtoServerWithAuth p] -> ShowS
forall (p :: ProtocolType). ProtoServerWithAuth p -> String
$cshowsPrec :: forall (p :: ProtocolType). Int -> ProtoServerWithAuth p -> ShowS
showsPrec :: Int -> ProtoServerWithAuth p -> ShowS
$cshow :: forall (p :: ProtocolType). ProtoServerWithAuth p -> String
show :: ProtoServerWithAuth p -> String
$cshowList :: forall (p :: ProtocolType). [ProtoServerWithAuth p] -> ShowS
showList :: [ProtoServerWithAuth p] -> ShowS
Show)

instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
  fromString :: String -> ProtoServerWithAuth p
fromString = (MsgId -> Either String (ProtoServerWithAuth p))
-> String -> ProtoServerWithAuth p
forall a. (MsgId -> Either String a) -> String -> a
parseString MsgId -> Either String (ProtoServerWithAuth p)
forall a. StrEncoding a => MsgId -> Either String a
strDecode

data AProtoServerWithAuth = forall p. ProtocolTypeI p => AProtoServerWithAuth (SProtocolType p) (ProtoServerWithAuth p)

deriving instance Show AProtoServerWithAuth

instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where
  strEncode :: ProtoServerWithAuth p -> MsgId
strEncode (ProtoServerWithAuth ProtocolServer {SProtocolType p
$sel:scheme:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> SProtocolType p
scheme :: SProtocolType p
scheme, NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: KeyHash
keyHash} Maybe BasicAuth
auth_) =
    SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
strEncodeServer SProtocolType p
scheme (NonEmpty TransportHost -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode NonEmpty TransportHost
host) String
port KeyHash
keyHash Maybe BasicAuth
auth_
  strP :: Parser (ProtoServerWithAuth p)
strP = (\(AProtoServerWithAuth SProtocolType p
_ ProtoServerWithAuth p
srv) -> ProtoServerWithAuth p -> Either String (ProtoServerWithAuth p)
forall (t :: ProtocolType -> *) (p :: ProtocolType)
       (p' :: ProtocolType).
(ProtocolTypeI p, ProtocolTypeI p') =>
t p' -> Either String (t p)
checkProtocolType ProtoServerWithAuth p
srv) (AProtoServerWithAuth -> Either String (ProtoServerWithAuth p))
-> Parser MsgId AProtoServerWithAuth
-> Parser (ProtoServerWithAuth p)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser MsgId AProtoServerWithAuth
forall a. StrEncoding a => Parser a
strP

instance StrEncoding AProtoServerWithAuth where
  strEncode :: AProtoServerWithAuth -> MsgId
strEncode (AProtoServerWithAuth SProtocolType p
_ ProtoServerWithAuth p
srv) = ProtoServerWithAuth p -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode ProtoServerWithAuth p
srv
  strP :: Parser MsgId AProtoServerWithAuth
strP =
    Parser (AProtocolServer, Maybe BasicAuth)
serverStrP Parser (AProtocolServer, Maybe BasicAuth)
-> ((AProtocolServer, Maybe BasicAuth)
    -> Parser MsgId AProtoServerWithAuth)
-> Parser MsgId AProtoServerWithAuth
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(AProtocolServer SProtocolType p
p ProtocolServer p
srv, Maybe BasicAuth
auth) ->
      AProtoServerWithAuth -> Parser MsgId AProtoServerWithAuth
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AProtoServerWithAuth -> Parser MsgId AProtoServerWithAuth)
-> AProtoServerWithAuth -> Parser MsgId AProtoServerWithAuth
forall a b. (a -> b) -> a -> b
$ SProtocolType p -> ProtoServerWithAuth p -> AProtoServerWithAuth
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> ProtoServerWithAuth p -> AProtoServerWithAuth
AProtoServerWithAuth SProtocolType p
p (ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
auth)

instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
  toJSON :: ProtoServerWithAuth p -> Value
toJSON = ProtoServerWithAuth p -> Value
forall a. StrEncoding a => a -> Value
strToJSON
  toEncoding :: ProtoServerWithAuth p -> Encoding
toEncoding = ProtoServerWithAuth p -> Encoding
forall a. StrEncoding a => a -> Encoding
strToJEncoding

instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
  parseJSON :: Value -> Parser (ProtoServerWithAuth p)
parseJSON = String -> Value -> Parser (ProtoServerWithAuth p)
forall a. StrEncoding a => String -> Value -> Parser a
strParseJSON String
"ProtoServerWithAuth"

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

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

noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
noAuthSrv :: forall (p :: ProtocolType).
ProtocolServer p -> ProtoServerWithAuth p
noAuthSrv ProtocolServer p
srv = ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
forall (p :: ProtocolType).
ProtocolServer p -> Maybe BasicAuth -> ProtoServerWithAuth p
ProtoServerWithAuth ProtocolServer p
srv Maybe BasicAuth
forall a. Maybe a
Nothing

legacyEncodeServer :: ProtocolServer p -> ByteString
legacyEncodeServer :: forall (p :: ProtocolType). ProtocolServer p -> MsgId
legacyEncodeServer ProtocolServer {NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: KeyHash
keyHash} =
  (TransportHost, String, KeyHash) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (NonEmpty TransportHost -> TransportHost
forall a. NonEmpty a -> a
L.head NonEmpty TransportHost
host, String
port, KeyHash
keyHash)

legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
legacyServerP :: forall (p :: ProtocolType).
ProtocolTypeI p =>
Parser (ProtocolServer p)
legacyServerP = do
  (TransportHost
h, String
port, KeyHash
keyHash) <- Parser (TransportHost, String, KeyHash)
forall a. Encoding a => Parser a
smpP
  ProtocolServer p -> Parser (ProtocolServer p)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProtocolServer {$sel:scheme:ProtocolServer :: SProtocolType p
scheme = forall (p :: ProtocolType). ProtocolTypeI p => SProtocolType p
protocolTypeI @p, $sel:host:ProtocolServer :: NonEmpty TransportHost
host = [Item (NonEmpty TransportHost)
TransportHost
h], String
$sel:port:ProtocolServer :: String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: KeyHash
keyHash :: KeyHash
keyHash}

legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
legacyStrEncodeServer :: forall (p :: ProtocolType).
ProtocolTypeI p =>
ProtocolServer p -> MsgId
legacyStrEncodeServer ProtocolServer {SProtocolType p
$sel:scheme:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> SProtocolType p
scheme :: SProtocolType p
scheme, NonEmpty TransportHost
$sel:host:ProtocolServer :: forall (p :: ProtocolType).
ProtocolServer p -> NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: forall (p :: ProtocolType). ProtocolServer p -> KeyHash
keyHash :: KeyHash
keyHash} =
  SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
strEncodeServer SProtocolType p
scheme (TransportHost -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode (TransportHost -> MsgId) -> TransportHost -> MsgId
forall a b. (a -> b) -> a -> b
$ NonEmpty TransportHost -> TransportHost
forall a. NonEmpty a -> a
L.head NonEmpty TransportHost
host) String
port KeyHash
keyHash Maybe BasicAuth
forall a. Maybe a
Nothing

strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
strEncodeServer :: forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p
-> MsgId -> String -> KeyHash -> Maybe BasicAuth -> MsgId
strEncodeServer SProtocolType p
scheme MsgId
host String
port KeyHash
keyHash Maybe BasicAuth
auth_ =
  SProtocolType p -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode SProtocolType p
scheme MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
"://" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> KeyHash -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode KeyHash
keyHash MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId -> (BasicAuth -> MsgId) -> Maybe BasicAuth -> MsgId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MsgId
"" ((MsgId
":" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<>) (MsgId -> MsgId) -> (BasicAuth -> MsgId) -> BasicAuth -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BasicAuth -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode) Maybe BasicAuth
auth_ MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
"@" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
host MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
portStr
  where
    portStr :: MsgId
portStr = String -> MsgId
B.pack (String -> MsgId) -> String -> MsgId
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
port then String
"" else Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: String
port

serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
serverStrP = do
  AProtocolType
scheme <- Parser MsgId AProtocolType
forall a. StrEncoding a => Parser a
strP Parser MsgId AProtocolType
-> Parser MsgId MsgId -> Parser MsgId AProtocolType
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser MsgId MsgId
"://"
  KeyHash
keyHash <- Parser KeyHash
forall a. StrEncoding a => Parser a
strP
  Maybe BasicAuth
auth_ <- Parser BasicAuth -> Parser MsgId (Maybe BasicAuth)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser BasicAuth -> Parser MsgId (Maybe BasicAuth))
-> Parser BasicAuth -> Parser MsgId (Maybe BasicAuth)
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
A.char Char
':' Parser Char -> Parser BasicAuth -> Parser BasicAuth
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser BasicAuth
forall a. StrEncoding a => Parser a
strP
  TransportHosts NonEmpty TransportHost
host <- Char -> Parser Char
A.char Char
'@' Parser Char
-> Parser MsgId TransportHosts -> Parser MsgId TransportHosts
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser MsgId TransportHosts
forall a. StrEncoding a => Parser a
strP
  String
port <- Parser MsgId String
portP Parser MsgId String -> Parser MsgId String -> Parser MsgId String
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Parser MsgId String
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
""
  (AProtocolServer, Maybe BasicAuth)
-> Parser (AProtocolServer, Maybe BasicAuth)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((AProtocolServer, Maybe BasicAuth)
 -> Parser (AProtocolServer, Maybe BasicAuth))
-> (AProtocolServer, Maybe BasicAuth)
-> Parser (AProtocolServer, Maybe BasicAuth)
forall a b. (a -> b) -> a -> b
$ case AProtocolType
scheme of
    AProtocolType SProtocolType p
s -> (SProtocolType p -> ProtocolServer p -> AProtocolServer
forall (p :: ProtocolType).
ProtocolTypeI p =>
SProtocolType p -> ProtocolServer p -> AProtocolServer
AProtocolServer SProtocolType p
s (ProtocolServer p -> AProtocolServer)
-> ProtocolServer p -> AProtocolServer
forall a b. (a -> b) -> a -> b
$ ProtocolServer {$sel:scheme:ProtocolServer :: SProtocolType p
scheme = SProtocolType p
s, NonEmpty TransportHost
$sel:host:ProtocolServer :: NonEmpty TransportHost
host :: NonEmpty TransportHost
host, String
$sel:port:ProtocolServer :: String
port :: String
port, KeyHash
$sel:keyHash:ProtocolServer :: KeyHash
keyHash :: KeyHash
keyHash}, Maybe BasicAuth
auth_)
  where
    portP :: Parser MsgId String
portP = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Parser MsgId Int -> Parser MsgId String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char
A.char Char
':' Parser Char -> Parser MsgId Int -> Parser MsgId Int
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser MsgId Int
forall a. Integral a => Parser a
A.decimal :: Parser Int))

-- | Transmission correlation ID.
newtype CorrId = CorrId {CorrId -> MsgId
bs :: ByteString}
  deriving (CorrId -> CorrId -> Bool
(CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> Bool) -> Eq CorrId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CorrId -> CorrId -> Bool
== :: CorrId -> CorrId -> Bool
$c/= :: CorrId -> CorrId -> Bool
/= :: CorrId -> CorrId -> Bool
Eq, Eq CorrId
Eq CorrId =>
(CorrId -> CorrId -> Ordering)
-> (CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> CorrId)
-> (CorrId -> CorrId -> CorrId)
-> Ord CorrId
CorrId -> CorrId -> Bool
CorrId -> CorrId -> Ordering
CorrId -> CorrId -> CorrId
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 :: CorrId -> CorrId -> Ordering
compare :: CorrId -> CorrId -> Ordering
$c< :: CorrId -> CorrId -> Bool
< :: CorrId -> CorrId -> Bool
$c<= :: CorrId -> CorrId -> Bool
<= :: CorrId -> CorrId -> Bool
$c> :: CorrId -> CorrId -> Bool
> :: CorrId -> CorrId -> Bool
$c>= :: CorrId -> CorrId -> Bool
>= :: CorrId -> CorrId -> Bool
$cmax :: CorrId -> CorrId -> CorrId
max :: CorrId -> CorrId -> CorrId
$cmin :: CorrId -> CorrId -> CorrId
min :: CorrId -> CorrId -> CorrId
Ord, Int -> CorrId -> ShowS
[CorrId] -> ShowS
CorrId -> String
(Int -> CorrId -> ShowS)
-> (CorrId -> String) -> ([CorrId] -> ShowS) -> Show CorrId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CorrId -> ShowS
showsPrec :: Int -> CorrId -> ShowS
$cshow :: CorrId -> String
show :: CorrId -> String
$cshowList :: [CorrId] -> ShowS
showList :: [CorrId] -> ShowS
Show)
  deriving newtype (Parser CorrId
MsgId -> Either String CorrId
CorrId -> MsgId
(CorrId -> MsgId)
-> (MsgId -> Either String CorrId)
-> Parser CorrId
-> Encoding CorrId
forall a.
(a -> MsgId)
-> (MsgId -> Either String a) -> Parser a -> Encoding a
$csmpEncode :: CorrId -> MsgId
smpEncode :: CorrId -> MsgId
$csmpDecode :: MsgId -> Either String CorrId
smpDecode :: MsgId -> Either String CorrId
$csmpP :: Parser CorrId
smpP :: Parser CorrId
Encoding)

pattern NoCorrId :: CorrId
pattern $mNoCorrId :: forall {r}. CorrId -> ((# #) -> r) -> ((# #) -> r) -> r
$bNoCorrId :: CorrId
NoCorrId = CorrId ""

instance IsString CorrId where
  fromString :: String -> CorrId
fromString = MsgId -> CorrId
CorrId (MsgId -> CorrId) -> (String -> MsgId) -> String -> CorrId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MsgId
forall a. IsString a => String -> a
fromString
  {-# INLINE fromString #-}

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

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

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

-- | Queue IDs and keys
data QueueIdsKeys = QIK
  { QueueIdsKeys -> LinkId
rcvId :: RecipientId,
    QueueIdsKeys -> LinkId
sndId :: SenderId,
    QueueIdsKeys -> RcvNtfPublicDhKey
rcvPublicDhKey :: RcvPublicDhKey,
    QueueIdsKeys -> Maybe QueueMode
queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
    QueueIdsKeys -> Maybe LinkId
linkId :: Maybe LinkId,
    QueueIdsKeys -> Maybe LinkId
serviceId :: Maybe ServiceId,
    QueueIdsKeys -> Maybe ServerNtfCreds
serverNtfCreds :: Maybe ServerNtfCreds
  }
  deriving (QueueIdsKeys -> QueueIdsKeys -> Bool
(QueueIdsKeys -> QueueIdsKeys -> Bool)
-> (QueueIdsKeys -> QueueIdsKeys -> Bool) -> Eq QueueIdsKeys
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QueueIdsKeys -> QueueIdsKeys -> Bool
== :: QueueIdsKeys -> QueueIdsKeys -> Bool
$c/= :: QueueIdsKeys -> QueueIdsKeys -> Bool
/= :: QueueIdsKeys -> QueueIdsKeys -> Bool
Eq, Int -> QueueIdsKeys -> ShowS
[QueueIdsKeys] -> ShowS
QueueIdsKeys -> String
(Int -> QueueIdsKeys -> ShowS)
-> (QueueIdsKeys -> String)
-> ([QueueIdsKeys] -> ShowS)
-> Show QueueIdsKeys
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueueIdsKeys -> ShowS
showsPrec :: Int -> QueueIdsKeys -> ShowS
$cshow :: QueueIdsKeys -> String
show :: QueueIdsKeys -> String
$cshowList :: [QueueIdsKeys] -> ShowS
showList :: [QueueIdsKeys] -> ShowS
Show)

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

instance Encoding ServerNtfCreds where
  smpEncode :: ServerNtfCreds -> MsgId
smpEncode (ServerNtfCreds LinkId
nId RcvNtfPublicDhKey
dhKey) = (LinkId, RcvNtfPublicDhKey) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (LinkId
nId, RcvNtfPublicDhKey
dhKey)
  smpP :: Parser ServerNtfCreds
smpP = LinkId -> RcvNtfPublicDhKey -> ServerNtfCreds
ServerNtfCreds (LinkId -> RcvNtfPublicDhKey -> ServerNtfCreds)
-> Parser MsgId LinkId
-> Parser MsgId (RcvNtfPublicDhKey -> ServerNtfCreds)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId LinkId
forall a. Encoding a => Parser a
smpP Parser MsgId (RcvNtfPublicDhKey -> ServerNtfCreds)
-> Parser MsgId RcvNtfPublicDhKey -> Parser ServerNtfCreds
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP

-- | Recipient's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type RcvPrivateAuthKey = C.APrivateAuthKey

-- | Recipient's public key used by SMP server to verify authorization of SMP commands.
type RcvPublicAuthKey = C.APublicAuthKey

-- | Public key used for DH exchange to encrypt message bodies from server to recipient
type RcvPublicDhKey = C.PublicKeyX25519

-- | DH Secret used to encrypt message bodies from server to recipient
type RcvDhSecret = C.DhSecretX25519

-- | Sender's private key used by the recipient to authorize (v6: sign, v7: encrypt hash) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type SndPrivateAuthKey = C.APrivateAuthKey

-- | Sender's public key used by SMP server to verify authorization of SMP commands.
type SndPublicAuthKey = C.APublicAuthKey

-- | Private key used by push notifications server to authorize (sign or encrypt hash) NSUB command.
type NtfPrivateAuthKey = C.APrivateAuthKey

-- | Public key used by SMP server to verify authorization of NSUB command sent by push notifications server.
type NtfPublicAuthKey = C.APublicAuthKey

-- | Public key used for DH exchange to encrypt notification metadata from server to recipient
type RcvNtfPublicDhKey = C.PublicKeyX25519

-- | DH Secret used to encrypt notification metadata from server to recipient
type RcvNtfDhSecret = C.DhSecretX25519

-- | SMP message server ID.
type MsgId = ByteString

-- | SMP message body.
type MsgBody = ByteString

data ProtocolErrorType = PECmdSyntax | PECmdUnknown | PESession | PEBlock

-- | Type for protocol errors.
data ErrorType
  = -- | incorrect block format, encoding or signature size
    BLOCK
  | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929)
    SESSION
  | -- | SMP command is unknown or has invalid syntax
    CMD {ErrorType -> CommandError
cmdErr :: CommandError}
  | -- | error from proxied relay
    PROXY {ErrorType -> ProxyError
proxyErr :: ProxyError}
  | -- | command authorization error - bad signature or non-existing SMP queue
    AUTH
  | -- | command with the entity that was blocked
    BLOCKED {ErrorType -> BlockingInfo
blockInfo :: BlockingInfo}
  | -- | service signature is not allowed for command or session; service command is sent not in service session
    SERVICE
  | -- | encryption/decryption error in proxy protocol
    CRYPTO
  | -- | SMP queue capacity is exceeded on the server
    QUOTA
  | -- | SMP server storage error
    STORE {ErrorType -> Text
storeErr :: Text}
  | -- | ACK command is sent without message to be acknowledged
    NO_MSG
  | -- | sent message is too large (> maxMessageLength = 16088 bytes)
    LARGE_MSG
  | -- | relay public key is expired
    EXPIRED
  | -- | internal server error
    INTERNAL
  | -- | used internally, never returned by the server (to be removed)
    DUPLICATE_ -- not part of SMP protocol, used internally
  deriving (ErrorType -> ErrorType -> Bool
(ErrorType -> ErrorType -> Bool)
-> (ErrorType -> ErrorType -> Bool) -> Eq ErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorType -> ErrorType -> Bool
== :: ErrorType -> ErrorType -> Bool
$c/= :: ErrorType -> ErrorType -> Bool
/= :: ErrorType -> ErrorType -> Bool
Eq, Int -> ErrorType -> ShowS
[ErrorType] -> ShowS
ErrorType -> String
(Int -> ErrorType -> ShowS)
-> (ErrorType -> String)
-> ([ErrorType] -> ShowS)
-> Show ErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorType -> ShowS
showsPrec :: Int -> ErrorType -> ShowS
$cshow :: ErrorType -> String
show :: ErrorType -> String
$cshowList :: [ErrorType] -> ShowS
showList :: [ErrorType] -> ShowS
Show)

instance StrEncoding ErrorType where
  strEncode :: ErrorType -> MsgId
strEncode = \case
    ErrorType
BLOCK -> MsgId
"BLOCK"
    ErrorType
SESSION -> MsgId
"SESSION"
    CMD CommandError
e -> MsgId
"CMD " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> CommandError -> MsgId
forall a. Show a => a -> MsgId
bshow CommandError
e
    PROXY ProxyError
e -> MsgId
"PROXY " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> ProxyError -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode ProxyError
e
    ErrorType
AUTH -> MsgId
"AUTH"
    BLOCKED BlockingInfo
info -> MsgId
"BLOCKED " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode BlockingInfo
info
    ErrorType
SERVICE -> MsgId
"SERVICE"
    ErrorType
CRYPTO -> MsgId
"CRYPTO"
    ErrorType
QUOTA -> MsgId
"QUOTA"
    STORE Text
e -> MsgId
"STORE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 Text
e
    ErrorType
NO_MSG -> MsgId
"NO_MSG"
    ErrorType
LARGE_MSG -> MsgId
"LARGE_MSG"
    ErrorType
EXPIRED -> MsgId
"EXPIRED"
    ErrorType
INTERNAL -> MsgId
"INTERNAL"
    ErrorType
DUPLICATE_ -> MsgId
"DUPLICATE_"
  strP :: Parser ErrorType
strP =
    [Parser ErrorType] -> Parser ErrorType
forall (f :: * -> *) a. Alternative f => [f a] -> f a
A.choice
      [ Parser MsgId MsgId
"BLOCK" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
BLOCK,
        Parser MsgId MsgId
"SESSION" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
SESSION,
        Parser MsgId MsgId
"CMD " Parser MsgId MsgId -> Parser ErrorType -> Parser ErrorType
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (CommandError -> ErrorType
CMD (CommandError -> ErrorType)
-> Parser MsgId CommandError -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId CommandError
forall a. Read a => Parser a
parseRead1),
        Parser MsgId MsgId
"PROXY " Parser MsgId MsgId -> Parser ErrorType -> Parser ErrorType
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType)
-> Parser MsgId ProxyError -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId ProxyError
forall a. StrEncoding a => Parser a
strP),
        Parser MsgId MsgId
"AUTH" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
AUTH,
        Parser MsgId MsgId
"BLOCKED " Parser MsgId MsgId -> Parser ErrorType -> Parser ErrorType
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ErrorType
forall a. StrEncoding a => Parser a
strP,
        Parser MsgId MsgId
"SERVICE" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
SERVICE,
        Parser MsgId MsgId
"CRYPTO" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
CRYPTO,
        Parser MsgId MsgId
"QUOTA" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
QUOTA,
        Parser MsgId MsgId
"STORE " Parser MsgId MsgId -> Parser ErrorType -> Parser ErrorType
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> ErrorType
STORE (Text -> ErrorType) -> (MsgId -> Text) -> MsgId -> ErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> Text
safeDecodeUtf8 (MsgId -> ErrorType) -> Parser MsgId MsgId -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId MsgId
A.takeByteString),
        Parser MsgId MsgId
"NO_MSG" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
NO_MSG,
        Parser MsgId MsgId
"LARGE_MSG" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
LARGE_MSG,
        Parser MsgId MsgId
"EXPIRED" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
EXPIRED,
        Parser MsgId MsgId
"INTERNAL" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
INTERNAL,
        Parser MsgId MsgId
"DUPLICATE_" Parser MsgId MsgId -> ErrorType -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ErrorType
DUPLICATE_
      ]

-- | SMP command error type.
data CommandError
  = -- | unknown command
    UNKNOWN
  | -- | error parsing command
    SYNTAX
  | -- | command is not allowed (bad service role, or SUB/GET used with the same queue in the same TCP session)
    PROHIBITED
  | -- | transmission has no required credentials (signature or queue ID)
    NO_AUTH
  | -- | transmission has credentials that are not allowed for this command
    HAS_AUTH
  | -- | transmission has no required entity ID (e.g. SMP queue)
    NO_ENTITY
  deriving (CommandError -> CommandError -> Bool
(CommandError -> CommandError -> Bool)
-> (CommandError -> CommandError -> Bool) -> Eq CommandError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandError -> CommandError -> Bool
== :: CommandError -> CommandError -> Bool
$c/= :: CommandError -> CommandError -> Bool
/= :: CommandError -> CommandError -> Bool
Eq, ReadPrec [CommandError]
ReadPrec CommandError
Int -> ReadS CommandError
ReadS [CommandError]
(Int -> ReadS CommandError)
-> ReadS [CommandError]
-> ReadPrec CommandError
-> ReadPrec [CommandError]
-> Read CommandError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS CommandError
readsPrec :: Int -> ReadS CommandError
$creadList :: ReadS [CommandError]
readList :: ReadS [CommandError]
$creadPrec :: ReadPrec CommandError
readPrec :: ReadPrec CommandError
$creadListPrec :: ReadPrec [CommandError]
readListPrec :: ReadPrec [CommandError]
Read, Int -> CommandError -> ShowS
[CommandError] -> ShowS
CommandError -> String
(Int -> CommandError -> ShowS)
-> (CommandError -> String)
-> ([CommandError] -> ShowS)
-> Show CommandError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandError -> ShowS
showsPrec :: Int -> CommandError -> ShowS
$cshow :: CommandError -> String
show :: CommandError -> String
$cshowList :: [CommandError] -> ShowS
showList :: [CommandError] -> ShowS
Show)

data ProxyError
  = -- | Correctly parsed SMP server ERR response.
    -- This error is forwarded to the agent client as AgentErrorType `ERR PROXY PROTOCOL err`.
    PROTOCOL {ProxyError -> ErrorType
protocolErr :: ErrorType}
  | -- | destination server error
    BROKER {ProxyError -> BrokerErrorType
brokerErr :: BrokerErrorType}
  | -- | basic auth provided to proxy is invalid
    BASIC_AUTH
  | -- no destination server error
    NO_SESSION
  deriving (ProxyError -> ProxyError -> Bool
(ProxyError -> ProxyError -> Bool)
-> (ProxyError -> ProxyError -> Bool) -> Eq ProxyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProxyError -> ProxyError -> Bool
== :: ProxyError -> ProxyError -> Bool
$c/= :: ProxyError -> ProxyError -> Bool
/= :: ProxyError -> ProxyError -> Bool
Eq, Int -> ProxyError -> ShowS
[ProxyError] -> ShowS
ProxyError -> String
(Int -> ProxyError -> ShowS)
-> (ProxyError -> String)
-> ([ProxyError] -> ShowS)
-> Show ProxyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProxyError -> ShowS
showsPrec :: Int -> ProxyError -> ShowS
$cshow :: ProxyError -> String
show :: ProxyError -> String
$cshowList :: [ProxyError] -> ShowS
showList :: [ProxyError] -> ShowS
Show)

-- | SMP server errors.
data BrokerErrorType
  = -- | invalid server response (failed to parse)
    RESPONSE {BrokerErrorType -> String
respErr :: String}
  | -- | unexpected response
    UNEXPECTED {respErr :: String}
  | -- | network error
    NETWORK {BrokerErrorType -> NetworkError
networkError :: NetworkError}
  | -- | no compatible server host (e.g. onion when public is required, or vice versa)
    HOST
  | -- | service unavailable client-side - used in agent errors
    NO_SERVICE
  | -- | handshake or other transport error
    TRANSPORT {BrokerErrorType -> TransportError
transportErr :: TransportError}
  | -- | command response timeout
    TIMEOUT
  deriving (BrokerErrorType -> BrokerErrorType -> Bool
(BrokerErrorType -> BrokerErrorType -> Bool)
-> (BrokerErrorType -> BrokerErrorType -> Bool)
-> Eq BrokerErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BrokerErrorType -> BrokerErrorType -> Bool
== :: BrokerErrorType -> BrokerErrorType -> Bool
$c/= :: BrokerErrorType -> BrokerErrorType -> Bool
/= :: BrokerErrorType -> BrokerErrorType -> Bool
Eq, ReadPrec [BrokerErrorType]
ReadPrec BrokerErrorType
Int -> ReadS BrokerErrorType
ReadS [BrokerErrorType]
(Int -> ReadS BrokerErrorType)
-> ReadS [BrokerErrorType]
-> ReadPrec BrokerErrorType
-> ReadPrec [BrokerErrorType]
-> Read BrokerErrorType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BrokerErrorType
readsPrec :: Int -> ReadS BrokerErrorType
$creadList :: ReadS [BrokerErrorType]
readList :: ReadS [BrokerErrorType]
$creadPrec :: ReadPrec BrokerErrorType
readPrec :: ReadPrec BrokerErrorType
$creadListPrec :: ReadPrec [BrokerErrorType]
readListPrec :: ReadPrec [BrokerErrorType]
Read, Int -> BrokerErrorType -> ShowS
[BrokerErrorType] -> ShowS
BrokerErrorType -> String
(Int -> BrokerErrorType -> ShowS)
-> (BrokerErrorType -> String)
-> ([BrokerErrorType] -> ShowS)
-> Show BrokerErrorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BrokerErrorType -> ShowS
showsPrec :: Int -> BrokerErrorType -> ShowS
$cshow :: BrokerErrorType -> String
show :: BrokerErrorType -> String
$cshowList :: [BrokerErrorType] -> ShowS
showList :: [BrokerErrorType] -> ShowS
Show, Show BrokerErrorType
Typeable BrokerErrorType
(Typeable BrokerErrorType, Show BrokerErrorType) =>
(BrokerErrorType -> SomeException)
-> (SomeException -> Maybe BrokerErrorType)
-> (BrokerErrorType -> String)
-> Exception BrokerErrorType
SomeException -> Maybe BrokerErrorType
BrokerErrorType -> String
BrokerErrorType -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: BrokerErrorType -> SomeException
toException :: BrokerErrorType -> SomeException
$cfromException :: SomeException -> Maybe BrokerErrorType
fromException :: SomeException -> Maybe BrokerErrorType
$cdisplayException :: BrokerErrorType -> String
displayException :: BrokerErrorType -> String
Exception)

data NetworkError
  = NEConnectError {NetworkError -> String
connectError :: String}
  | NETLSError {NetworkError -> String
tlsError :: String}
  | NEUnknownCAError
  | NEFailedError
  | NETimeoutError
  | NESubscribeError {NetworkError -> String
subscribeError :: String}
  deriving (NetworkError -> NetworkError -> Bool
(NetworkError -> NetworkError -> Bool)
-> (NetworkError -> NetworkError -> Bool) -> Eq NetworkError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkError -> NetworkError -> Bool
== :: NetworkError -> NetworkError -> Bool
$c/= :: NetworkError -> NetworkError -> Bool
/= :: NetworkError -> NetworkError -> Bool
Eq, ReadPrec [NetworkError]
ReadPrec NetworkError
Int -> ReadS NetworkError
ReadS [NetworkError]
(Int -> ReadS NetworkError)
-> ReadS [NetworkError]
-> ReadPrec NetworkError
-> ReadPrec [NetworkError]
-> Read NetworkError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS NetworkError
readsPrec :: Int -> ReadS NetworkError
$creadList :: ReadS [NetworkError]
readList :: ReadS [NetworkError]
$creadPrec :: ReadPrec NetworkError
readPrec :: ReadPrec NetworkError
$creadListPrec :: ReadPrec [NetworkError]
readListPrec :: ReadPrec [NetworkError]
Read, Int -> NetworkError -> ShowS
[NetworkError] -> ShowS
NetworkError -> String
(Int -> NetworkError -> ShowS)
-> (NetworkError -> String)
-> ([NetworkError] -> ShowS)
-> Show NetworkError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NetworkError -> ShowS
showsPrec :: Int -> NetworkError -> ShowS
$cshow :: NetworkError -> String
show :: NetworkError -> String
$cshowList :: [NetworkError] -> ShowS
showList :: [NetworkError] -> ShowS
Show)

toNetworkError :: SomeException -> NetworkError
toNetworkError :: SomeException -> NetworkError
toNetworkError SomeException
e = NetworkError
-> (TLSException -> NetworkError)
-> Maybe TLSException
-> NetworkError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NetworkError
NEConnectError String
err) TLSException -> NetworkError
fromTLSError (SomeException -> Maybe TLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e)
  where
    err :: String
err = SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e
    fromTLSError :: TLS.TLSException -> NetworkError
    fromTLSError :: TLSException -> NetworkError
fromTLSError = \case
      TLS.HandshakeFailed (TLS.Error_Protocol (String
_, Bool
_, AlertDescription
TLS.UnknownCa)) -> NetworkError
NEUnknownCAError
      TLSException
_ -> String -> NetworkError
NETLSError String
err

data BlockingInfo = BlockingInfo
  { BlockingInfo -> BlockingReason
reason :: BlockingReason,
    BlockingInfo -> Maybe ClientNotice
notice :: Maybe ClientNotice
  }
  deriving (BlockingInfo -> BlockingInfo -> Bool
(BlockingInfo -> BlockingInfo -> Bool)
-> (BlockingInfo -> BlockingInfo -> Bool) -> Eq BlockingInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockingInfo -> BlockingInfo -> Bool
== :: BlockingInfo -> BlockingInfo -> Bool
$c/= :: BlockingInfo -> BlockingInfo -> Bool
/= :: BlockingInfo -> BlockingInfo -> Bool
Eq, Int -> BlockingInfo -> ShowS
[BlockingInfo] -> ShowS
BlockingInfo -> String
(Int -> BlockingInfo -> ShowS)
-> (BlockingInfo -> String)
-> ([BlockingInfo] -> ShowS)
-> Show BlockingInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockingInfo -> ShowS
showsPrec :: Int -> BlockingInfo -> ShowS
$cshow :: BlockingInfo -> String
show :: BlockingInfo -> String
$cshowList :: [BlockingInfo] -> ShowS
showList :: [BlockingInfo] -> ShowS
Show)

data BlockingReason = BRSpam | BRContent
  deriving (BlockingReason -> BlockingReason -> Bool
(BlockingReason -> BlockingReason -> Bool)
-> (BlockingReason -> BlockingReason -> Bool) -> Eq BlockingReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockingReason -> BlockingReason -> Bool
== :: BlockingReason -> BlockingReason -> Bool
$c/= :: BlockingReason -> BlockingReason -> Bool
/= :: BlockingReason -> BlockingReason -> Bool
Eq, Int -> BlockingReason -> ShowS
[BlockingReason] -> ShowS
BlockingReason -> String
(Int -> BlockingReason -> ShowS)
-> (BlockingReason -> String)
-> ([BlockingReason] -> ShowS)
-> Show BlockingReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockingReason -> ShowS
showsPrec :: Int -> BlockingReason -> ShowS
$cshow :: BlockingReason -> String
show :: BlockingReason -> String
$cshowList :: [BlockingReason] -> ShowS
showList :: [BlockingReason] -> ShowS
Show)

instance StrEncoding BlockingInfo where
  strEncode :: BlockingInfo -> MsgId
strEncode BlockingInfo {BlockingReason
$sel:reason:BlockingInfo :: BlockingInfo -> BlockingReason
reason :: BlockingReason
reason, Maybe ClientNotice
$sel:notice:BlockingInfo :: BlockingInfo -> Maybe ClientNotice
notice :: Maybe ClientNotice
notice} =
    MsgId
"reason=" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> BlockingReason -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode BlockingReason
reason MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId -> (ClientNotice -> MsgId) -> Maybe ClientNotice -> MsgId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MsgId
"" ((MsgId
",notice=" MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<>) (MsgId -> MsgId)
-> (ClientNotice -> MsgId) -> ClientNotice -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> MsgId
LB.toStrict (ByteString -> MsgId)
-> (ClientNotice -> ByteString) -> ClientNotice -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientNotice -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode) Maybe ClientNotice
notice
  strP :: Parser BlockingInfo
strP = do
    BlockingReason
reason <- Parser MsgId MsgId
"reason=" Parser MsgId MsgId
-> Parser MsgId BlockingReason -> Parser MsgId BlockingReason
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser MsgId BlockingReason
forall a. StrEncoding a => Parser a
strP
    Maybe ClientNotice
notice <- Parser MsgId ClientNotice -> Parser MsgId (Maybe ClientNotice)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser MsgId ClientNotice -> Parser MsgId (Maybe ClientNotice))
-> Parser MsgId ClientNotice -> Parser MsgId (Maybe ClientNotice)
forall a b. (a -> b) -> a -> b
$ Parser MsgId MsgId
",notice=" Parser MsgId MsgId
-> Parser MsgId ClientNotice -> Parser MsgId ClientNotice
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (MsgId -> Either String ClientNotice
forall a. FromJSON a => MsgId -> Either String a
J.eitherDecodeStrict (MsgId -> Either String ClientNotice)
-> Parser MsgId MsgId -> Parser MsgId ClientNotice
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser MsgId MsgId
A.takeByteString)
    BlockingInfo -> Parser BlockingInfo
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockingInfo {BlockingReason
$sel:reason:BlockingInfo :: BlockingReason
reason :: BlockingReason
reason, Maybe ClientNotice
$sel:notice:BlockingInfo :: Maybe ClientNotice
notice :: Maybe ClientNotice
notice}

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

instance StrEncoding BlockingReason where
  strEncode :: BlockingReason -> MsgId
strEncode = \case
    BlockingReason
BRSpam -> MsgId
"spam"
    BlockingReason
BRContent -> MsgId
"content"
  strP :: Parser MsgId BlockingReason
strP = Parser MsgId MsgId
"spam" Parser MsgId MsgId -> BlockingReason -> Parser MsgId BlockingReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockingReason
BRSpam Parser MsgId BlockingReason
-> Parser MsgId BlockingReason -> Parser MsgId BlockingReason
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser MsgId MsgId
"content" Parser MsgId MsgId -> BlockingReason -> Parser MsgId BlockingReason
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BlockingReason
BRContent

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

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

-- | SMP transmission parser.
transmissionP :: THandleParams v p -> Parser RawTransmission
transmissionP :: forall v (p :: TransportPeer).
THandleParams v p -> Parser RawTransmission
transmissionP THandleParams {MsgId
sessionId :: MsgId
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> MsgId
sessionId, Bool
implySessId :: Bool
$sel:implySessId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId, Bool
serviceAuth :: Bool
$sel:serviceAuth:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
serviceAuth} = do
  MsgId
authenticator <- Parser MsgId MsgId
forall a. Encoding a => Parser a
smpP
  Maybe (Signature 'Ed25519)
serviceSig <- if Bool
serviceAuth Bool -> Bool -> Bool
&& Bool -> Bool
not (MsgId -> Bool
B.null MsgId
authenticator) then Parser (Maybe (Signature 'Ed25519))
forall a. Encoding a => Parser a
smpP else Maybe (Signature 'Ed25519) -> Parser (Maybe (Signature 'Ed25519))
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Signature 'Ed25519)
forall a. Maybe a
Nothing
  MsgId
authorized <- Parser MsgId MsgId
A.takeByteString
  (String -> Parser RawTransmission)
-> (RawTransmission -> Parser RawTransmission)
-> Either String RawTransmission
-> Parser RawTransmission
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser RawTransmission
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail RawTransmission -> Parser RawTransmission
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String RawTransmission -> Parser RawTransmission)
-> Either String RawTransmission -> Parser RawTransmission
forall a b. (a -> b) -> a -> b
$ Parser RawTransmission -> MsgId -> Either String RawTransmission
forall a. Parser a -> MsgId -> Either String a
parseAll (MsgId
-> Maybe (Signature 'Ed25519) -> MsgId -> Parser RawTransmission
trn MsgId
authenticator Maybe (Signature 'Ed25519)
serviceSig MsgId
authorized) MsgId
authorized
  where
    trn :: MsgId
-> Maybe (Signature 'Ed25519) -> MsgId -> Parser RawTransmission
trn MsgId
authenticator Maybe (Signature 'Ed25519)
serviceSig MsgId
authorized = do
      MsgId
sessId <- if Bool
implySessId then MsgId -> Parser MsgId MsgId
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MsgId
"" else Parser MsgId MsgId
forall a. Encoding a => Parser a
smpP
      let authorized' :: MsgId
authorized' = if Bool
implySessId then MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode MsgId
sessionId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
authorized else MsgId
authorized
      CorrId
corrId <- Parser CorrId
forall a. Encoding a => Parser a
smpP
      LinkId
entityId <- Parser MsgId LinkId
forall a. Encoding a => Parser a
smpP
      MsgId
command <- Parser MsgId MsgId
A.takeByteString
      RawTransmission -> Parser RawTransmission
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawTransmission {MsgId
$sel:authenticator:RawTransmission :: MsgId
authenticator :: MsgId
authenticator, Maybe (Signature 'Ed25519)
$sel:serviceSig:RawTransmission :: Maybe (Signature 'Ed25519)
serviceSig :: Maybe (Signature 'Ed25519)
serviceSig, $sel:authorized:RawTransmission :: MsgId
authorized = MsgId
authorized', MsgId
$sel:sessId:RawTransmission :: MsgId
sessId :: MsgId
sessId, CorrId
$sel:corrId:RawTransmission :: CorrId
corrId :: CorrId
corrId, LinkId
$sel:entityId:RawTransmission :: LinkId
entityId :: LinkId
entityId, MsgId
$sel:command:RawTransmission :: MsgId
command :: MsgId
command}

class (ProtocolTypeI (ProtoType msg), ProtocolEncoding v err msg, ProtocolEncoding v err (ProtoCommand msg), Show err, Show msg) => Protocol v err msg | msg -> v, msg -> err where
  type ProtoCommand msg = cmd | cmd -> msg
  type ProtoType msg = (sch :: ProtocolType) | sch -> msg
  protocolClientHandshake :: Transport c => c 'TClient -> Maybe C.KeyPairX25519 -> C.KeyHash -> VersionRange v -> Bool -> Maybe (ServiceCredentials, C.KeyPairEd25519) -> ExceptT TransportError IO (THandle v c 'TClient)
  useServiceAuth :: ProtoCommand msg -> Bool
  protocolPing :: ProtoCommand msg
  protocolError :: msg -> Maybe err

type ProtoServer msg = ProtocolServer (ProtoType msg)

instance Protocol SMPVersion ErrorType BrokerMsg where
  type ProtoCommand BrokerMsg = Cmd
  type ProtoType BrokerMsg = 'PSMP
  protocolClientHandshake :: forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRangeSMP
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandle SMPVersion c 'TClient)
protocolClientHandshake = c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRangeSMP
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandleSMP c 'TClient)
forall (c :: TransportPeer -> *).
Transport c =>
c 'TClient
-> Maybe KeyPairX25519
-> KeyHash
-> VersionRangeSMP
-> Bool
-> Maybe (ServiceCredentials, KeyPairEd25519)
-> ExceptT TransportError IO (THandle SMPVersion c 'TClient)
smpClientHandshake
  {-# INLINE protocolClientHandshake #-}
  useServiceAuth :: ProtoCommand BrokerMsg -> Bool
useServiceAuth = \case
    Cmd SParty p
_ (NEW NewQueueReq
_) -> Bool
True
    Cmd SParty p
_ Command p
SUB -> Bool
True
    Cmd SParty p
_ Command p
NSUB -> Bool
True
    ProtoCommand BrokerMsg
_ -> Bool
False
  {-# INLINE useServiceAuth #-}
  protocolPing :: ProtoCommand BrokerMsg
protocolPing = SParty 'IdleClient -> Command 'IdleClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'IdleClient
SIdleClient Command 'IdleClient
PING
  {-# INLINE protocolPing #-}
  protocolError :: BrokerMsg -> Maybe ErrorType
protocolError = \case
    ERR ErrorType
e -> ErrorType -> Maybe ErrorType
forall a. a -> Maybe a
Just ErrorType
e
    BrokerMsg
_ -> Maybe ErrorType
forall a. Maybe a
Nothing
  {-# INLINE protocolError #-}

class ProtocolMsgTag (Tag msg) => ProtocolEncoding v err msg | msg -> err, msg -> v where
  type Tag msg
  encodeProtocol :: Version v -> msg -> ByteString
  protocolP :: Version v -> Tag msg -> Parser msg
  fromProtocolError :: ProtocolErrorType -> err
  checkCredentials :: Maybe TAuthorizations -> EntityId -> msg -> Either err msg

instance PartyI p => ProtocolEncoding SMPVersion ErrorType (Command p) where
  type Tag (Command p) = CommandTag p
  encodeProtocol :: VersionSMP -> Command p -> MsgId
encodeProtocol VersionSMP
v = \case
    NEW NewQueueReq {$sel:rcvAuthKey:NewQueueReq :: NewQueueReq -> SndPublicAuthKey
rcvAuthKey = SndPublicAuthKey
rKey, $sel:rcvDhKey:NewQueueReq :: NewQueueReq -> RcvNtfPublicDhKey
rcvDhKey = RcvNtfPublicDhKey
dhKey, Maybe BasicAuth
$sel:auth_:NewQueueReq :: NewQueueReq -> Maybe BasicAuth
auth_ :: Maybe BasicAuth
auth_, SubscriptionMode
$sel:subMode:NewQueueReq :: NewQueueReq -> SubscriptionMode
subMode :: SubscriptionMode
subMode, Maybe QueueReqData
$sel:queueReqData:NewQueueReq :: NewQueueReq -> Maybe QueueReqData
queueReqData :: Maybe QueueReqData
queueReqData, Maybe NewNtfCreds
$sel:ntfCreds:NewQueueReq :: NewQueueReq -> Maybe NewNtfCreds
ntfCreds :: Maybe NewNtfCreds
ntfCreds}
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
newNtfCredsSMPVersion -> MsgId
new MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> (Maybe BasicAuth, SubscriptionMode, Maybe QueueReqData,
 Maybe NewNtfCreds)
-> MsgId
forall a. Encoding a => a -> MsgId
e (Maybe BasicAuth
auth_, SubscriptionMode
subMode, Maybe QueueReqData
queueReqData, Maybe NewNtfCreds
ntfCreds)
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
shortLinksSMPVersion -> MsgId
new MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> (Maybe BasicAuth, SubscriptionMode, Maybe QueueReqData) -> MsgId
forall a. Encoding a => a -> MsgId
e (Maybe BasicAuth
auth_, SubscriptionMode
subMode, Maybe QueueReqData
queueReqData)
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
sndAuthKeySMPVersion -> MsgId
new MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> (Maybe BasicAuth, SubscriptionMode, Bool) -> MsgId
forall a. Encoding a => a -> MsgId
e (Maybe BasicAuth
auth_, SubscriptionMode
subMode, Maybe QueueMode -> Bool
senderCanSecure (QueueReqData -> QueueMode
queueReqMode (QueueReqData -> QueueMode)
-> Maybe QueueReqData -> Maybe QueueMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe QueueReqData
queueReqData))
      | Bool
otherwise -> MsgId
new MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
auth MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> SubscriptionMode -> MsgId
forall a. Encoding a => a -> MsgId
e SubscriptionMode
subMode
      where
        new :: MsgId
new = (CommandTag 'Creator, Char, SndPublicAuthKey, RcvNtfPublicDhKey)
-> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Creator
NEW_, Char
' ', SndPublicAuthKey
rKey, RcvNtfPublicDhKey
dhKey)
        auth :: MsgId
auth = MsgId -> (BasicAuth -> MsgId) -> Maybe BasicAuth -> MsgId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MsgId
"" ((Char, BasicAuth) -> MsgId
forall a. Encoding a => a -> MsgId
e ((Char, BasicAuth) -> MsgId)
-> (BasicAuth -> (Char, BasicAuth)) -> BasicAuth -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'A',)) Maybe BasicAuth
auth_
    Command p
SUB -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
SUB_
    Command p
SUBS -> CommandTag 'RecipientService -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'RecipientService
SUBS_
    KEY SndPublicAuthKey
k -> (CommandTag 'Recipient, Char, SndPublicAuthKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Recipient
KEY_, Char
' ', SndPublicAuthKey
k)
    RKEY NonEmpty SndPublicAuthKey
ks -> (CommandTag 'Recipient, Char, NonEmpty SndPublicAuthKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Recipient
RKEY_, Char
' ', NonEmpty SndPublicAuthKey
ks)
    LSET LinkId
lnkId QueueLinkData
d -> (CommandTag 'Recipient, Char, LinkId, QueueLinkData) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Recipient
LSET_, Char
' ', LinkId
lnkId, QueueLinkData
d)
    Command p
LDEL -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
LDEL_
    NKEY SndPublicAuthKey
k RcvNtfPublicDhKey
dhKey -> (CommandTag 'Recipient, Char, SndPublicAuthKey, RcvNtfPublicDhKey)
-> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Recipient
NKEY_, Char
' ', SndPublicAuthKey
k, RcvNtfPublicDhKey
dhKey)
    Command p
NDEL -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
NDEL_
    Command p
GET -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
GET_
    ACK MsgId
msgId -> (CommandTag 'Recipient, Char, MsgId) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Recipient
ACK_, Char
' ', MsgId
msgId)
    Command p
OFF -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
OFF_
    Command p
DEL -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
DEL_
    Command p
QUE -> CommandTag 'Recipient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Recipient
QUE_
    SKEY SndPublicAuthKey
k -> (CommandTag 'Sender, Char, SndPublicAuthKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Sender
SKEY_, Char
' ', SndPublicAuthKey
k)
    SEND MsgFlags
flags MsgId
msg -> (CommandTag 'Sender, Char, MsgFlags, Char, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'Sender
SEND_, Char
' ', MsgFlags
flags, Char
' ', MsgId -> Tail
Tail MsgId
msg)
    Command p
PING -> CommandTag 'IdleClient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'IdleClient
PING_
    Command p
NSUB -> CommandTag 'Notifier -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'Notifier
NSUB_
    Command p
NSUBS -> CommandTag 'NotifierService -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'NotifierService
NSUBS_
    LKEY SndPublicAuthKey
k -> (CommandTag 'LinkClient, Char, SndPublicAuthKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'LinkClient
LKEY_, Char
' ', SndPublicAuthKey
k)
    Command p
LGET -> CommandTag 'LinkClient -> MsgId
forall a. Encoding a => a -> MsgId
e CommandTag 'LinkClient
LGET_
    PRXY SMPServer
host Maybe BasicAuth
auth_ -> (CommandTag 'ProxiedClient, Char, SMPServer, Maybe BasicAuth)
-> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'ProxiedClient
PRXY_, Char
' ', SMPServer
host, Maybe BasicAuth
auth_)
    PFWD VersionSMP
fwdV RcvNtfPublicDhKey
pubKey (EncTransmission MsgId
s) -> (CommandTag 'ProxiedClient, Char, VersionSMP, RcvNtfPublicDhKey,
 Tail)
-> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'ProxiedClient
PFWD_, Char
' ', VersionSMP
fwdV, RcvNtfPublicDhKey
pubKey, MsgId -> Tail
Tail MsgId
s)
    RFWD (EncFwdTransmission MsgId
s) -> (CommandTag 'ProxyService, Char, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
e (CommandTag 'ProxyService
RFWD_, Char
' ', MsgId -> Tail
Tail MsgId
s)
    where
      e :: Encoding a => a -> ByteString
      e :: forall a. Encoding a => a -> MsgId
e = a -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode

  protocolP :: VersionSMP -> Tag (Command p) -> Parser (Command p)
protocolP VersionSMP
v Tag (Command p)
tag = (\(Cmd SParty p
_ Command p
c) -> Command p -> Either String (Command p)
forall (t :: Party -> *) (p :: Party) (p' :: Party).
(PartyI p, PartyI p') =>
t p' -> Either String (t p)
checkParty Command p
c) (Cmd -> Either String (Command p))
-> Parser MsgId Cmd -> Parser (Command p)
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> VersionSMP -> Tag Cmd -> Parser MsgId Cmd
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> Tag msg -> Parser msg
protocolP VersionSMP
v (SParty p -> CommandTag p -> CmdTag
forall (p :: Party). PartyI p => SParty p -> CommandTag p -> CmdTag
CT (forall (p :: Party). PartyI p => SParty p
sParty @p) Tag (Command p)
CommandTag p
tag)

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

  checkCredentials :: Maybe TAuthorizations
-> LinkId -> Command p -> Either ErrorType (Command p)
checkCredentials Maybe TAuthorizations
auth (EntityId MsgId
entId) Command p
cmd = case Command p
cmd of
    -- NEW must have signature but NOT queue ID
    NEW {}
      | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth -> ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
      | Bool -> Bool
not (MsgId -> Bool
B.null MsgId
entId) -> ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
      | Bool
otherwise -> Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd
    -- SEND must have queue ID, signature is not always required
    SEND {}
      | MsgId -> Bool
B.null MsgId
entId -> ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_ENTITY
      | Bool
otherwise -> Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd
    Command p
LGET -> Either ErrorType (Command p)
entityCmd
    Command p
PING -> Either ErrorType (Command p)
noAuthCmd
    PRXY {} -> Either ErrorType (Command p)
noAuthCmd
    PFWD {} -> Either ErrorType (Command p)
entityCmd
    RFWD EncFwdTransmission
_ -> Either ErrorType (Command p)
noAuthCmd
    Command p
SUB -> Either ErrorType (Command p)
serviceCmd
    Command p
NSUB -> Either ErrorType (Command p)
serviceCmd
    -- other client commands must have both signature and queue ID
    Command p
_
      | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth Bool -> Bool -> Bool
|| MsgId -> Bool
B.null MsgId
entId -> ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
      | Bool
otherwise -> Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd
    where
      -- command must not have entity ID (queue or session ID) or signature
      noAuthCmd :: Either ErrorType (Command p)
      noAuthCmd :: Either ErrorType (Command p)
noAuthCmd
        | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth Bool -> Bool -> Bool
&& MsgId -> Bool
B.null MsgId
entId = Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd
        | Bool
otherwise = ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
      entityCmd :: Either ErrorType (Command p)
      entityCmd :: Either ErrorType (Command p)
entityCmd
        | MsgId -> Bool
B.null MsgId
entId = ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_ENTITY
        | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth = Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd
        | Bool
otherwise = ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
      serviceCmd :: Either ErrorType (Command p)
      serviceCmd :: Either ErrorType (Command p)
serviceCmd
        | Maybe TAuthorizations -> Bool
forall a. Maybe a -> Bool
isNothing Maybe TAuthorizations
auth Bool -> Bool -> Bool
|| MsgId -> Bool
B.null MsgId
entId = ErrorType -> Either ErrorType (Command p)
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType (Command p))
-> ErrorType -> Either ErrorType (Command p)
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
        | Bool
otherwise = Command p -> Either ErrorType (Command p)
forall a b. b -> Either a b
Right Command p
cmd

instance ProtocolEncoding SMPVersion ErrorType Cmd where
  type Tag Cmd = CmdTag
  encodeProtocol :: VersionSMP -> Cmd -> MsgId
encodeProtocol VersionSMP
v (Cmd SParty p
_ Command p
c) = VersionSMP -> Command p -> MsgId
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> msg -> MsgId
encodeProtocol VersionSMP
v Command p
c
  {-# INLINE encodeProtocol #-}

  protocolP :: VersionSMP -> Tag Cmd -> Parser MsgId Cmd
protocolP VersionSMP
v = \case
    CT SParty p
SCreator CommandTag p
NEW_ -> SParty 'Creator -> Command 'Creator -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Creator
SCreator (Command 'Creator -> Cmd)
-> Parser MsgId (Command 'Creator) -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId (Command 'Creator)
newCmd
      where
        newCmd :: Parser MsgId (Command 'Creator)
newCmd
          | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
newNtfCredsSMPVersion = Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Maybe QueueReqData)
-> Parser MsgId (Maybe NewNtfCreds)
-> Parser MsgId (Command 'Creator)
new Parser MsgId (Maybe BasicAuth)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe QueueReqData)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe NewNtfCreds)
forall a. Encoding a => Parser a
smpP
          | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
shortLinksSMPVersion = Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Maybe QueueReqData)
-> Parser MsgId (Maybe NewNtfCreds)
-> Parser MsgId (Command 'Creator)
new Parser MsgId (Maybe BasicAuth)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe QueueReqData)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe NewNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
          | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
sndAuthKeySMPVersion = Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Maybe QueueReqData)
-> Parser MsgId (Maybe NewNtfCreds)
-> Parser MsgId (Command 'Creator)
new Parser MsgId (Maybe BasicAuth)
forall a. Encoding a => Parser a
smpP (Bool -> Maybe QueueReqData
qReq (Bool -> Maybe QueueReqData)
-> Parser Bool -> Parser MsgId (Maybe QueueReqData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
forall a. Encoding a => Parser a
smpP) Parser MsgId (Maybe NewNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
          | Bool
otherwise = Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Maybe QueueReqData)
-> Parser MsgId (Maybe NewNtfCreds)
-> Parser MsgId (Command 'Creator)
new Parser MsgId (Maybe BasicAuth)
auth Parser MsgId (Maybe QueueReqData)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe NewNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
          where
            nothing :: Parser MsgId (Maybe a)
nothing = Maybe a -> Parser MsgId (Maybe a)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
            new :: Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Maybe QueueReqData)
-> Parser MsgId (Maybe NewNtfCreds)
-> Parser MsgId (Command 'Creator)
new Parser MsgId (Maybe BasicAuth)
p1 Parser MsgId (Maybe QueueReqData)
p2 Parser MsgId (Maybe NewNtfCreds)
p3 = NewQueueReq -> Command 'Creator
NEW (NewQueueReq -> Command 'Creator)
-> Parser MsgId NewQueueReq -> Parser MsgId (Command 'Creator)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              SndPublicAuthKey
rcvAuthKey <- Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
_smpP
              RcvNtfPublicDhKey
rcvDhKey <- Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP
              Maybe BasicAuth
auth_ <- Parser MsgId (Maybe BasicAuth)
p1
              SubscriptionMode
subMode <- Parser SubscriptionMode
forall a. Encoding a => Parser a
smpP
              Maybe QueueReqData
queueReqData <- Parser MsgId (Maybe QueueReqData)
p2
              Maybe NewNtfCreds
ntfCreds <- Parser MsgId (Maybe NewNtfCreds)
p3
              NewQueueReq -> Parser MsgId NewQueueReq
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NewQueueReq {SndPublicAuthKey
$sel:rcvAuthKey:NewQueueReq :: SndPublicAuthKey
rcvAuthKey :: SndPublicAuthKey
rcvAuthKey, RcvNtfPublicDhKey
$sel:rcvDhKey:NewQueueReq :: RcvNtfPublicDhKey
rcvDhKey :: RcvNtfPublicDhKey
rcvDhKey, Maybe BasicAuth
$sel:auth_:NewQueueReq :: Maybe BasicAuth
auth_ :: Maybe BasicAuth
auth_, SubscriptionMode
$sel:subMode:NewQueueReq :: SubscriptionMode
subMode :: SubscriptionMode
subMode, Maybe QueueReqData
$sel:queueReqData:NewQueueReq :: Maybe QueueReqData
queueReqData :: Maybe QueueReqData
queueReqData, Maybe NewNtfCreds
$sel:ntfCreds:NewQueueReq :: Maybe NewNtfCreds
ntfCreds :: Maybe NewNtfCreds
ntfCreds}
            auth :: Parser MsgId (Maybe BasicAuth)
auth = Parser BasicAuth -> Parser MsgId (Maybe BasicAuth)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Char
A.char Char
'A' Parser Char -> Parser BasicAuth -> Parser BasicAuth
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser BasicAuth
forall a. Encoding a => Parser a
smpP)
            qReq :: Bool -> Maybe QueueReqData
qReq Bool
sndSecure = QueueReqData -> Maybe QueueReqData
forall a. a -> Maybe a
Just (QueueReqData -> Maybe QueueReqData)
-> QueueReqData -> Maybe QueueReqData
forall a b. (a -> b) -> a -> b
$ if Bool
sndSecure then Maybe (LinkId, QueueLinkData) -> QueueReqData
QRMessaging Maybe (LinkId, QueueLinkData)
forall a. Maybe a
Nothing else Maybe (LinkId, (LinkId, QueueLinkData)) -> QueueReqData
QRContact Maybe (LinkId, (LinkId, QueueLinkData))
forall a. Maybe a
Nothing
    CT SParty p
SRecipient CommandTag p
tag ->
      SParty 'Recipient -> Command 'Recipient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd)
-> Parser MsgId (Command 'Recipient) -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CommandTag p
tag of
        CommandTag p
SUB_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
SUB
        CommandTag p
KEY_ -> SndPublicAuthKey -> Command 'Recipient
KEY (SndPublicAuthKey -> Command 'Recipient)
-> Parser MsgId SndPublicAuthKey
-> Parser MsgId (Command 'Recipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
_smpP
        CommandTag p
RKEY_ -> NonEmpty SndPublicAuthKey -> Command 'Recipient
RKEY (NonEmpty SndPublicAuthKey -> Command 'Recipient)
-> Parser MsgId (NonEmpty SndPublicAuthKey)
-> Parser MsgId (Command 'Recipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId (NonEmpty SndPublicAuthKey)
forall a. Encoding a => Parser a
_smpP
        CommandTag p
LSET_ -> LinkId -> QueueLinkData -> Command 'Recipient
LSET (LinkId -> QueueLinkData -> Command 'Recipient)
-> Parser MsgId LinkId
-> Parser MsgId (QueueLinkData -> Command 'Recipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId LinkId
forall a. Encoding a => Parser a
_smpP Parser MsgId (QueueLinkData -> Command 'Recipient)
-> Parser MsgId QueueLinkData -> Parser MsgId (Command 'Recipient)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId QueueLinkData
forall a. Encoding a => Parser a
smpP
        CommandTag p
LDEL_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
LDEL
        CommandTag p
NKEY_ -> SndPublicAuthKey -> RcvNtfPublicDhKey -> Command 'Recipient
NKEY (SndPublicAuthKey -> RcvNtfPublicDhKey -> Command 'Recipient)
-> Parser MsgId SndPublicAuthKey
-> Parser MsgId (RcvNtfPublicDhKey -> Command 'Recipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
_smpP Parser MsgId (RcvNtfPublicDhKey -> Command 'Recipient)
-> Parser MsgId RcvNtfPublicDhKey
-> Parser MsgId (Command 'Recipient)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP
        CommandTag p
NDEL_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
NDEL
        CommandTag p
GET_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
GET
        CommandTag p
ACK_ -> MsgId -> Command 'Recipient
ACK (MsgId -> Command 'Recipient)
-> Parser MsgId MsgId -> Parser MsgId (Command 'Recipient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId MsgId
forall a. Encoding a => Parser a
_smpP
        CommandTag p
OFF_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
OFF
        CommandTag p
DEL_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
DEL
        CommandTag p
QUE_ -> Command 'Recipient -> Parser MsgId (Command 'Recipient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'Recipient
QUE
    CT SParty p
SRecipientService CommandTag p
SUBS_ -> Cmd -> Parser MsgId Cmd
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> Parser MsgId Cmd) -> Cmd -> Parser MsgId Cmd
forall a b. (a -> b) -> a -> b
$ SParty 'RecipientService -> Command 'RecipientService -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'RecipientService
SRecipientService Command 'RecipientService
SUBS
    CT SParty p
SSender CommandTag p
tag ->
      SParty 'Sender -> Command 'Sender -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Sender
SSender (Command 'Sender -> Cmd)
-> Parser MsgId (Command 'Sender) -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CommandTag p
tag of
        CommandTag p
SKEY_ -> SndPublicAuthKey -> Command 'Sender
SKEY (SndPublicAuthKey -> Command 'Sender)
-> Parser MsgId SndPublicAuthKey -> Parser MsgId (Command 'Sender)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
_smpP
        CommandTag p
SEND_ -> MsgFlags -> MsgId -> Command 'Sender
SEND (MsgFlags -> MsgId -> Command 'Sender)
-> Parser MsgFlags -> Parser MsgId (MsgId -> Command 'Sender)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgFlags
forall a. Encoding a => Parser a
_smpP Parser MsgId (MsgId -> Command 'Sender)
-> Parser MsgId MsgId -> Parser MsgId (Command 'Sender)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Tail -> MsgId
unTail (Tail -> MsgId) -> Parser Tail -> Parser MsgId MsgId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
_smpP)
    CT SParty p
SIdleClient CommandTag p
PING_ -> Cmd -> Parser MsgId Cmd
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> Parser MsgId Cmd) -> Cmd -> Parser MsgId Cmd
forall a b. (a -> b) -> a -> b
$ SParty 'IdleClient -> Command 'IdleClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'IdleClient
SIdleClient Command 'IdleClient
PING
    CT SParty p
SProxyService CommandTag p
RFWD_ ->
      SParty 'ProxyService -> Command 'ProxyService -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'ProxyService
SProxyService (Command 'ProxyService -> Cmd)
-> (Tail -> Command 'ProxyService) -> Tail -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncFwdTransmission -> Command 'ProxyService
RFWD (EncFwdTransmission -> Command 'ProxyService)
-> (Tail -> EncFwdTransmission) -> Tail -> Command 'ProxyService
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> EncFwdTransmission
EncFwdTransmission (MsgId -> EncFwdTransmission)
-> (Tail -> MsgId) -> Tail -> EncFwdTransmission
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MsgId
unTail (Tail -> Cmd) -> Parser Tail -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
_smpP
    CT SParty p
SSenderLink CommandTag p
tag ->
      SParty 'LinkClient -> Command 'LinkClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'LinkClient
SSenderLink (Command 'LinkClient -> Cmd)
-> Parser MsgId (Command 'LinkClient) -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CommandTag p
tag of
        CommandTag p
LKEY_ -> SndPublicAuthKey -> Command 'LinkClient
LKEY (SndPublicAuthKey -> Command 'LinkClient)
-> Parser MsgId SndPublicAuthKey
-> Parser MsgId (Command 'LinkClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SndPublicAuthKey
forall a. Encoding a => Parser a
_smpP
        CommandTag p
LGET_ -> Command 'LinkClient -> Parser MsgId (Command 'LinkClient)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command 'LinkClient
LGET
    CT SParty p
SProxiedClient CommandTag p
tag ->
      SParty 'ProxiedClient -> Command 'ProxiedClient -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'ProxiedClient
SProxiedClient (Command 'ProxiedClient -> Cmd)
-> Parser MsgId (Command 'ProxiedClient) -> Parser MsgId Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CommandTag p
tag of
        CommandTag p
PFWD_ -> VersionSMP
-> RcvNtfPublicDhKey -> EncTransmission -> Command 'ProxiedClient
PFWD (VersionSMP
 -> RcvNtfPublicDhKey -> EncTransmission -> Command 'ProxiedClient)
-> Parser MsgId VersionSMP
-> Parser
     MsgId
     (RcvNtfPublicDhKey -> EncTransmission -> Command 'ProxiedClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId VersionSMP
forall a. Encoding a => Parser a
_smpP Parser
  MsgId
  (RcvNtfPublicDhKey -> EncTransmission -> Command 'ProxiedClient)
-> Parser MsgId RcvNtfPublicDhKey
-> Parser MsgId (EncTransmission -> Command 'ProxiedClient)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP Parser MsgId (EncTransmission -> Command 'ProxiedClient)
-> Parser MsgId EncTransmission
-> Parser MsgId (Command 'ProxiedClient)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MsgId -> EncTransmission
EncTransmission (MsgId -> EncTransmission)
-> (Tail -> MsgId) -> Tail -> EncTransmission
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MsgId
unTail (Tail -> EncTransmission)
-> Parser Tail -> Parser MsgId EncTransmission
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
smpP)
        CommandTag p
PRXY_ -> SMPServer -> Maybe BasicAuth -> Command 'ProxiedClient
PRXY (SMPServer -> Maybe BasicAuth -> Command 'ProxiedClient)
-> Parser MsgId SMPServer
-> Parser MsgId (Maybe BasicAuth -> Command 'ProxiedClient)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId SMPServer
forall a. Encoding a => Parser a
_smpP Parser MsgId (Maybe BasicAuth -> Command 'ProxiedClient)
-> Parser MsgId (Maybe BasicAuth)
-> Parser MsgId (Command 'ProxiedClient)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId (Maybe BasicAuth)
forall a. Encoding a => Parser a
smpP
    CT SParty p
SNotifier CommandTag p
NSUB_ -> Cmd -> Parser MsgId Cmd
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> Parser MsgId Cmd) -> Cmd -> Parser MsgId Cmd
forall a b. (a -> b) -> a -> b
$ SParty 'Notifier -> Command 'Notifier -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'Notifier
SNotifier Command 'Notifier
NSUB
    CT SParty p
SNotifierService CommandTag p
NSUBS_ -> Cmd -> Parser MsgId Cmd
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cmd -> Parser MsgId Cmd) -> Cmd -> Parser MsgId Cmd
forall a b. (a -> b) -> a -> b
$ SParty 'NotifierService -> Command 'NotifierService -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty 'NotifierService
SNotifierService Command 'NotifierService
NSUBS

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

  checkCredentials :: Maybe TAuthorizations -> LinkId -> Cmd -> Either ErrorType Cmd
checkCredentials Maybe TAuthorizations
tAuth LinkId
entId (Cmd SParty p
p Command p
c) = SParty p -> Command p -> Cmd
forall (p :: Party). PartyI p => SParty p -> Command p -> Cmd
Cmd SParty p
p (Command p -> Cmd)
-> Either ErrorType (Command p) -> Either ErrorType Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TAuthorizations
-> LinkId -> Command p -> Either ErrorType (Command p)
forall v err msg.
ProtocolEncoding v err msg =>
Maybe TAuthorizations -> LinkId -> msg -> Either err msg
checkCredentials Maybe TAuthorizations
tAuth LinkId
entId Command p
c
  {-# INLINE checkCredentials #-}

instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
  type Tag BrokerMsg = BrokerMsgTag
  encodeProtocol :: VersionSMP -> BrokerMsg -> MsgId
encodeProtocol VersionSMP
v = \case
    IDS QIK {LinkId
$sel:rcvId:QIK :: QueueIdsKeys -> LinkId
rcvId :: LinkId
rcvId, LinkId
$sel:sndId:QIK :: QueueIdsKeys -> LinkId
sndId :: LinkId
sndId, $sel:rcvPublicDhKey:QIK :: QueueIdsKeys -> RcvNtfPublicDhKey
rcvPublicDhKey = RcvNtfPublicDhKey
srvDh, Maybe QueueMode
$sel:queueMode:QIK :: QueueIdsKeys -> Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe LinkId
$sel:linkId:QIK :: QueueIdsKeys -> Maybe LinkId
linkId :: Maybe LinkId
linkId, Maybe LinkId
$sel:serviceId:QIK :: QueueIdsKeys -> Maybe LinkId
serviceId :: Maybe LinkId
serviceId, Maybe ServerNtfCreds
$sel:serverNtfCreds:QIK :: QueueIdsKeys -> Maybe ServerNtfCreds
serverNtfCreds :: Maybe ServerNtfCreds
serverNtfCreds}
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
newNtfCredsSMPVersion -> MsgId
ids MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe QueueMode -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe QueueMode
queueMode MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe LinkId -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe LinkId
linkId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe LinkId -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe LinkId
serviceId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe ServerNtfCreds -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe ServerNtfCreds
serverNtfCreds
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
serviceCertsSMPVersion -> MsgId
ids MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe QueueMode -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe QueueMode
queueMode MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe LinkId -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe LinkId
linkId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe LinkId -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe LinkId
serviceId
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
shortLinksSMPVersion -> MsgId
ids MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe QueueMode -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe QueueMode
queueMode MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Maybe LinkId -> MsgId
forall a. Encoding a => a -> MsgId
e Maybe LinkId
linkId
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
sndAuthKeySMPVersion -> MsgId
ids MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Bool -> MsgId
forall a. Encoding a => a -> MsgId
e (Maybe QueueMode -> Bool
senderCanSecure Maybe QueueMode
queueMode)
      | Bool
otherwise -> MsgId
ids
      where
        ids :: MsgId
ids = (BrokerMsgTag, Char, LinkId, LinkId, RcvNtfPublicDhKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
IDS_, Char
' ', LinkId
rcvId, LinkId
sndId, RcvNtfPublicDhKey
srvDh)
    LNK LinkId
sId QueueLinkData
d -> (BrokerMsgTag, Char, LinkId, QueueLinkData) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
LNK_, Char
' ', LinkId
sId, QueueLinkData
d)
    SOK Maybe LinkId
serviceId_
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
serviceCertsSMPVersion -> (BrokerMsgTag, Char, Maybe LinkId) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
SOK_, Char
' ', Maybe LinkId
serviceId_)
      | Bool
otherwise -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
OK_ -- won't happen, the association with the service requires v >= serviceCertsSMPVersion
    SOKS Int64
n -> (BrokerMsgTag, Char, Int64) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
SOKS_, Char
' ', Int64
n)
    MSG RcvMessage {MsgId
$sel:msgId:RcvMessage :: RcvMessage -> MsgId
msgId :: MsgId
msgId, $sel:msgBody:RcvMessage :: RcvMessage -> EncRcvMsgBody
msgBody = EncRcvMsgBody MsgId
body} ->
      (BrokerMsgTag, Char, MsgId, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
MSG_, Char
' ', MsgId
msgId, MsgId -> Tail
Tail MsgId
body)
    NID LinkId
nId RcvNtfPublicDhKey
srvNtfDh -> (BrokerMsgTag, Char, LinkId, RcvNtfPublicDhKey) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
NID_, Char
' ', LinkId
nId, RcvNtfPublicDhKey
srvNtfDh)
    NMSG CbNonce
nmsgNonce MsgId
encNMsgMeta -> (BrokerMsgTag, Char, CbNonce, MsgId) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
NMSG_, Char
' ', CbNonce
nmsgNonce, MsgId
encNMsgMeta)
    PKEY MsgId
sid VersionRangeSMP
vr CertChainPubKey
certKey -> (BrokerMsgTag, Char, MsgId, VersionRangeSMP, CertChainPubKey)
-> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
PKEY_, Char
' ', MsgId
sid, VersionRangeSMP
vr, CertChainPubKey
certKey)
    RRES (EncFwdResponse MsgId
encBlock) -> (BrokerMsgTag, Char, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
RRES_, Char
' ', MsgId -> Tail
Tail MsgId
encBlock)
    PRES (EncResponse MsgId
encBlock) -> (BrokerMsgTag, Char, Tail) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
PRES_, Char
' ', MsgId -> Tail
Tail MsgId
encBlock)
    BrokerMsg
END -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
END_
    ENDS Int64
n -> (BrokerMsgTag, Char, Int64) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
ENDS_, Char
' ', Int64
n)
    BrokerMsg
DELD
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
deletedEventSMPVersion -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
DELD_
      | Bool
otherwise -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
END_
    INFO QueueInfo
info -> (BrokerMsgTag, Char, QueueInfo) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
INFO_, Char
' ', QueueInfo
info)
    BrokerMsg
OK -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
OK_
    ERR ErrorType
err -> (BrokerMsgTag, Char, ErrorType) -> MsgId
forall a. Encoding a => a -> MsgId
e (BrokerMsgTag
ERR_, Char
' ', ErrorType
err')
      where
        err' :: ErrorType
err' = case ErrorType
err of
          BLOCKED BlockingInfo
info
            | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
< VersionSMP
blockedEntitySMPVersion -> ErrorType
AUTH
            | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
< VersionSMP
clientNoticesSMPVersion -> BlockingInfo -> ErrorType
BLOCKED BlockingInfo
info {notice = Nothing}
          ErrorType
_ -> ErrorType
err
    BrokerMsg
PONG -> BrokerMsgTag -> MsgId
forall a. Encoding a => a -> MsgId
e BrokerMsgTag
PONG_
    where
      e :: Encoding a => a -> ByteString
      e :: forall a. Encoding a => a -> MsgId
e = a -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode

  protocolP :: VersionSMP -> Tag BrokerMsg -> Parser BrokerMsg
protocolP VersionSMP
v = \case
    Tag BrokerMsg
BrokerMsgTag
MSG_ -> do
      MsgId
msgId <- Parser MsgId MsgId
forall a. Encoding a => Parser a
_smpP
      RcvMessage -> BrokerMsg
MSG (RcvMessage -> BrokerMsg)
-> (EncRcvMsgBody -> RcvMessage) -> EncRcvMsgBody -> BrokerMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> EncRcvMsgBody -> RcvMessage
RcvMessage MsgId
msgId (EncRcvMsgBody -> BrokerMsg)
-> Parser MsgId EncRcvMsgBody -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId EncRcvMsgBody
bodyP
      where
        bodyP :: Parser MsgId EncRcvMsgBody
bodyP = MsgId -> EncRcvMsgBody
EncRcvMsgBody (MsgId -> EncRcvMsgBody)
-> (Tail -> MsgId) -> Tail -> EncRcvMsgBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MsgId
unTail (Tail -> EncRcvMsgBody)
-> Parser Tail -> Parser MsgId EncRcvMsgBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
smpP
    Tag BrokerMsg
BrokerMsgTag
IDS_
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
newNtfCredsSMPVersion -> Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids Parser MsgId (Maybe QueueMode)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe ServerNtfCreds)
forall a. Encoding a => Parser a
smpP
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
serviceCertsSMPVersion -> Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids Parser MsgId (Maybe QueueMode)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe ServerNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
shortLinksSMPVersion -> Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids Parser MsgId (Maybe QueueMode)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
smpP Parser MsgId (Maybe LinkId)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe ServerNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
      | VersionSMP
v VersionSMP -> VersionSMP -> Bool
forall a. Ord a => a -> a -> Bool
>= VersionSMP
sndAuthKeySMPVersion -> Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids (Bool -> Maybe QueueMode
qm (Bool -> Maybe QueueMode)
-> Parser Bool -> Parser MsgId (Maybe QueueMode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Bool
forall a. Encoding a => Parser a
smpP) Parser MsgId (Maybe LinkId)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe LinkId)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe ServerNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
      | Bool
otherwise -> Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids Parser MsgId (Maybe QueueMode)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe LinkId)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe LinkId)
forall {a}. Parser MsgId (Maybe a)
nothing Parser MsgId (Maybe ServerNtfCreds)
forall {a}. Parser MsgId (Maybe a)
nothing
      where
        qm :: Bool -> Maybe QueueMode
qm Bool
sndSecure = QueueMode -> Maybe QueueMode
forall a. a -> Maybe a
Just (QueueMode -> Maybe QueueMode) -> QueueMode -> Maybe QueueMode
forall a b. (a -> b) -> a -> b
$ if Bool
sndSecure then QueueMode
QMMessaging else QueueMode
QMContact
        nothing :: Parser MsgId (Maybe a)
nothing = Maybe a -> Parser MsgId (Maybe a)
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
        ids :: Parser MsgId (Maybe QueueMode)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe LinkId)
-> Parser MsgId (Maybe ServerNtfCreds)
-> Parser BrokerMsg
ids Parser MsgId (Maybe QueueMode)
p1 Parser MsgId (Maybe LinkId)
p2 Parser MsgId (Maybe LinkId)
p3 Parser MsgId (Maybe ServerNtfCreds)
p4 = do
          LinkId
rcvId <- Parser MsgId LinkId
forall a. Encoding a => Parser a
_smpP
          LinkId
sndId <- Parser MsgId LinkId
forall a. Encoding a => Parser a
smpP
          RcvNtfPublicDhKey
rcvPublicDhKey <- Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP
          Maybe QueueMode
queueMode <- Parser MsgId (Maybe QueueMode)
p1
          Maybe LinkId
linkId <- Parser MsgId (Maybe LinkId)
p2
          Maybe LinkId
serviceId <- Parser MsgId (Maybe LinkId)
p3
          Maybe ServerNtfCreds
serverNtfCreds <- Parser MsgId (Maybe ServerNtfCreds)
p4
          BrokerMsg -> Parser BrokerMsg
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BrokerMsg -> Parser BrokerMsg) -> BrokerMsg -> Parser BrokerMsg
forall a b. (a -> b) -> a -> b
$ QueueIdsKeys -> BrokerMsg
IDS QIK {LinkId
$sel:rcvId:QIK :: LinkId
rcvId :: LinkId
rcvId, LinkId
$sel:sndId:QIK :: LinkId
sndId :: LinkId
sndId, RcvNtfPublicDhKey
$sel:rcvPublicDhKey:QIK :: RcvNtfPublicDhKey
rcvPublicDhKey :: RcvNtfPublicDhKey
rcvPublicDhKey, Maybe QueueMode
$sel:queueMode:QIK :: Maybe QueueMode
queueMode :: Maybe QueueMode
queueMode, Maybe LinkId
$sel:linkId:QIK :: Maybe LinkId
linkId :: Maybe LinkId
linkId, Maybe LinkId
$sel:serviceId:QIK :: Maybe LinkId
serviceId :: Maybe LinkId
serviceId, Maybe ServerNtfCreds
$sel:serverNtfCreds:QIK :: Maybe ServerNtfCreds
serverNtfCreds :: Maybe ServerNtfCreds
serverNtfCreds}
    Tag BrokerMsg
BrokerMsgTag
LNK_ -> LinkId -> QueueLinkData -> BrokerMsg
LNK (LinkId -> QueueLinkData -> BrokerMsg)
-> Parser MsgId LinkId -> Parser MsgId (QueueLinkData -> BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId LinkId
forall a. Encoding a => Parser a
_smpP Parser MsgId (QueueLinkData -> BrokerMsg)
-> Parser MsgId QueueLinkData -> Parser BrokerMsg
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId QueueLinkData
forall a. Encoding a => Parser a
smpP
    Tag BrokerMsg
BrokerMsgTag
SOK_ -> Maybe LinkId -> BrokerMsg
SOK (Maybe LinkId -> BrokerMsg)
-> Parser MsgId (Maybe LinkId) -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId (Maybe LinkId)
forall a. Encoding a => Parser a
_smpP
    Tag BrokerMsg
BrokerMsgTag
SOKS_ -> Int64 -> BrokerMsg
SOKS (Int64 -> BrokerMsg) -> Parser MsgId Int64 -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId Int64
forall a. Encoding a => Parser a
_smpP
    Tag BrokerMsg
BrokerMsgTag
NID_ -> LinkId -> RcvNtfPublicDhKey -> BrokerMsg
NID (LinkId -> RcvNtfPublicDhKey -> BrokerMsg)
-> Parser MsgId LinkId
-> Parser MsgId (RcvNtfPublicDhKey -> BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId LinkId
forall a. Encoding a => Parser a
_smpP Parser MsgId (RcvNtfPublicDhKey -> BrokerMsg)
-> Parser MsgId RcvNtfPublicDhKey -> Parser BrokerMsg
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId RcvNtfPublicDhKey
forall a. Encoding a => Parser a
smpP
    Tag BrokerMsg
BrokerMsgTag
NMSG_ -> CbNonce -> MsgId -> BrokerMsg
NMSG (CbNonce -> MsgId -> BrokerMsg)
-> Parser MsgId CbNonce -> Parser MsgId (MsgId -> BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId CbNonce
forall a. Encoding a => Parser a
_smpP Parser MsgId (MsgId -> BrokerMsg)
-> Parser MsgId MsgId -> Parser BrokerMsg
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId MsgId
forall a. Encoding a => Parser a
smpP
    Tag BrokerMsg
BrokerMsgTag
PKEY_ -> MsgId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg
PKEY (MsgId -> VersionRangeSMP -> CertChainPubKey -> BrokerMsg)
-> Parser MsgId MsgId
-> Parser MsgId (VersionRangeSMP -> CertChainPubKey -> BrokerMsg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId MsgId
forall a. Encoding a => Parser a
_smpP Parser MsgId (VersionRangeSMP -> CertChainPubKey -> BrokerMsg)
-> Parser MsgId VersionRangeSMP
-> Parser MsgId (CertChainPubKey -> BrokerMsg)
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId VersionRangeSMP
forall a. Encoding a => Parser a
smpP Parser MsgId (CertChainPubKey -> BrokerMsg)
-> Parser MsgId CertChainPubKey -> Parser BrokerMsg
forall a b.
Parser MsgId (a -> b) -> Parser MsgId a -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser MsgId CertChainPubKey
forall a. Encoding a => Parser a
smpP
    Tag BrokerMsg
BrokerMsgTag
RRES_ -> EncFwdResponse -> BrokerMsg
RRES (EncFwdResponse -> BrokerMsg)
-> Parser MsgId EncFwdResponse -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MsgId -> EncFwdResponse
EncFwdResponse (MsgId -> EncFwdResponse)
-> (Tail -> MsgId) -> Tail -> EncFwdResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MsgId
unTail (Tail -> EncFwdResponse)
-> Parser Tail -> Parser MsgId EncFwdResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
_smpP)
    Tag BrokerMsg
BrokerMsgTag
PRES_ -> EncResponse -> BrokerMsg
PRES (EncResponse -> BrokerMsg)
-> Parser MsgId EncResponse -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MsgId -> EncResponse
EncResponse (MsgId -> EncResponse) -> (Tail -> MsgId) -> Tail -> EncResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tail -> MsgId
unTail (Tail -> EncResponse) -> Parser Tail -> Parser MsgId EncResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Tail
forall a. Encoding a => Parser a
_smpP)
    Tag BrokerMsg
BrokerMsgTag
END_ -> BrokerMsg -> Parser BrokerMsg
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerMsg
END
    Tag BrokerMsg
BrokerMsgTag
ENDS_ -> Int64 -> BrokerMsg
ENDS (Int64 -> BrokerMsg) -> Parser MsgId Int64 -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId Int64
forall a. Encoding a => Parser a
_smpP
    Tag BrokerMsg
BrokerMsgTag
DELD_ -> BrokerMsg -> Parser BrokerMsg
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerMsg
DELD
    Tag BrokerMsg
BrokerMsgTag
INFO_ -> QueueInfo -> BrokerMsg
INFO (QueueInfo -> BrokerMsg)
-> Parser MsgId QueueInfo -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId QueueInfo
forall a. Encoding a => Parser a
_smpP
    Tag BrokerMsg
BrokerMsgTag
OK_ -> BrokerMsg -> Parser BrokerMsg
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerMsg
OK
    Tag BrokerMsg
BrokerMsgTag
ERR_ -> ErrorType -> BrokerMsg
ERR (ErrorType -> BrokerMsg) -> Parser ErrorType -> Parser BrokerMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ErrorType
forall a. Encoding a => Parser a
_smpP
    Tag BrokerMsg
BrokerMsgTag
PONG_ -> BrokerMsg -> Parser BrokerMsg
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerMsg
PONG

  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
-> LinkId -> BrokerMsg -> Either ErrorType BrokerMsg
checkCredentials Maybe TAuthorizations
_ (EntityId MsgId
entId) BrokerMsg
cmd = case BrokerMsg
cmd of
    -- IDS response should not have queue ID
    IDS QueueIdsKeys
_ -> BrokerMsg -> Either ErrorType BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
cmd
    -- ERR response does not always have queue ID
    ERR ErrorType
_ -> BrokerMsg -> Either ErrorType BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
cmd
    -- PONG response must not have queue ID
    BrokerMsg
PONG -> Either ErrorType BrokerMsg
noEntityMsg
    PKEY {} -> Either ErrorType BrokerMsg
noEntityMsg
    RRES EncFwdResponse
_ -> Either ErrorType BrokerMsg
noEntityMsg
    -- other broker responses must have queue ID
    BrokerMsg
_
      | MsgId -> Bool
B.null MsgId
entId -> ErrorType -> Either ErrorType BrokerMsg
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType BrokerMsg)
-> ErrorType -> Either ErrorType BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_ENTITY
      | Bool
otherwise -> BrokerMsg -> Either ErrorType BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
cmd
    where
      noEntityMsg :: Either ErrorType BrokerMsg
      noEntityMsg :: Either ErrorType BrokerMsg
noEntityMsg
        | MsgId -> Bool
B.null MsgId
entId = BrokerMsg -> Either ErrorType BrokerMsg
forall a b. b -> Either a b
Right BrokerMsg
cmd
        | Bool
otherwise = ErrorType -> Either ErrorType BrokerMsg
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType BrokerMsg)
-> ErrorType -> Either ErrorType BrokerMsg
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH

-- | Parse SMP protocol commands and broker messages
parseProtocol :: forall v err msg. ProtocolEncoding v err msg => Version v -> ByteString -> Either err msg
parseProtocol :: forall v err msg.
ProtocolEncoding v err msg =>
Version v -> MsgId -> Either err msg
parseProtocol Version v
v MsgId
s =
  let (MsgId
tag, MsgId
params) = (Char -> Bool) -> MsgId -> (MsgId, MsgId)
B.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') MsgId
s
   in case MsgId -> Maybe (Tag msg)
forall t. ProtocolMsgTag t => MsgId -> Maybe t
decodeTag MsgId
tag of
        Just Tag msg
cmd -> Parser msg -> err -> MsgId -> Either err msg
forall a e. Parser a -> e -> MsgId -> Either e a
parse (Version v -> Tag msg -> Parser msg
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> Tag msg -> Parser msg
protocolP Version v
v Tag msg
cmd) (forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @v @err @msg (ProtocolErrorType -> err) -> ProtocolErrorType -> err
forall a b. (a -> b) -> a -> b
$ ProtocolErrorType
PECmdSyntax) MsgId
params
        Maybe (Tag msg)
Nothing -> err -> Either err msg
forall a b. a -> Either a b
Left (err -> Either err msg) -> err -> Either err msg
forall a b. (a -> b) -> a -> b
$ forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @v @err @msg (ProtocolErrorType -> err) -> ProtocolErrorType -> err
forall a b. (a -> b) -> a -> b
$ ProtocolErrorType
PECmdUnknown

checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
checkParty :: forall (t :: Party -> *) (p :: Party) (p' :: Party).
(PartyI p, PartyI p') =>
t p' -> Either String (t p)
checkParty t p'
c = case SParty p -> SParty p' -> Maybe (p :~: p')
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: Party) (b :: Party).
SParty a -> SParty b -> Maybe (a :~: b)
testEquality (forall (p :: Party). PartyI p => SParty p
sParty @p) (forall (p :: Party). PartyI p => SParty p
sParty @p') of
  Just p :~: p'
Refl -> t p -> Either String (t p)
forall a b. b -> Either a b
Right t p
t p'
c
  Maybe (p :~: p')
Nothing -> String -> Either String (t p)
forall a b. a -> Either a b
Left String
"bad command party"

checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)
checkParty' :: forall (t :: Party -> *) (p :: Party) (p' :: Party).
(PartyI p, PartyI p') =>
t p' -> Maybe (t p)
checkParty' = Either String (t p) -> Maybe (t p)
forall a b. Either a b -> Maybe b
eitherToMaybe (Either String (t p) -> Maybe (t p))
-> (t p' -> Either String (t p)) -> t p' -> Maybe (t p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t p' -> Either String (t p)
forall (t :: Party -> *) (p :: Party) (p' :: Party).
(PartyI p, PartyI p') =>
t p' -> Either String (t p)
checkParty

instance Encoding ErrorType where
  smpEncode :: ErrorType -> MsgId
smpEncode = \case
    ErrorType
BLOCK -> MsgId
"BLOCK"
    ErrorType
SESSION -> MsgId
"SESSION"
    CMD CommandError
err -> MsgId
"CMD " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> CommandError -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode CommandError
err
    PROXY ProxyError
err -> MsgId
"PROXY " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> ProxyError -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode ProxyError
err
    ErrorType
AUTH -> MsgId
"AUTH"
    BLOCKED BlockingInfo
info -> MsgId
"BLOCKED " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode BlockingInfo
info
    ErrorType
SERVICE -> MsgId
"SERVICE"
    ErrorType
CRYPTO -> MsgId
"CRYPTO"
    ErrorType
QUOTA -> MsgId
"QUOTA"
    STORE Text
err -> MsgId
"STORE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 Text
err
    ErrorType
EXPIRED -> MsgId
"EXPIRED"
    ErrorType
NO_MSG -> MsgId
"NO_MSG"
    ErrorType
LARGE_MSG -> MsgId
"LARGE_MSG"
    ErrorType
INTERNAL -> MsgId
"INTERNAL"
    ErrorType
DUPLICATE_ -> MsgId
"DUPLICATE_"

  smpP :: Parser ErrorType
smpP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser ErrorType) -> Parser ErrorType
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"BLOCK" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
BLOCK
      MsgId
"SESSION" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
SESSION
      MsgId
"CMD" -> CommandError -> ErrorType
CMD (CommandError -> ErrorType)
-> Parser MsgId CommandError -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId CommandError
forall a. Encoding a => Parser a
_smpP
      MsgId
"PROXY" -> ProxyError -> ErrorType
PROXY (ProxyError -> ErrorType)
-> Parser MsgId ProxyError -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId ProxyError
forall a. Encoding a => Parser a
_smpP
      MsgId
"AUTH" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
AUTH
      MsgId
"BLOCKED" -> BlockingInfo -> ErrorType
BLOCKED (BlockingInfo -> ErrorType)
-> Parser BlockingInfo -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser BlockingInfo
forall a. Encoding a => Parser a
_smpP
      MsgId
"SERVICE" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
SERVICE
      MsgId
"CRYPTO" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
CRYPTO
      MsgId
"QUOTA" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
QUOTA
      MsgId
"STORE" -> Text -> ErrorType
STORE (Text -> ErrorType) -> (MsgId -> Text) -> MsgId -> ErrorType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> Text
safeDecodeUtf8 (MsgId -> ErrorType) -> Parser MsgId MsgId -> Parser ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Char
A.space Parser Char -> Parser MsgId MsgId -> Parser MsgId MsgId
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser MsgId MsgId
A.takeByteString)
      MsgId
"EXPIRED" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
EXPIRED
      MsgId
"NO_MSG" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
NO_MSG
      MsgId
"LARGE_MSG" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
LARGE_MSG
      MsgId
"INTERNAL" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
INTERNAL
      MsgId
"DUPLICATE_" -> ErrorType -> Parser ErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ErrorType
DUPLICATE_
      MsgId
_ -> String -> Parser ErrorType
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ErrorType"

instance Encoding CommandError where
  smpEncode :: CommandError -> MsgId
smpEncode CommandError
e = case CommandError
e of
    CommandError
UNKNOWN -> MsgId
"UNKNOWN"
    CommandError
SYNTAX -> MsgId
"SYNTAX"
    CommandError
PROHIBITED -> MsgId
"PROHIBITED"
    CommandError
NO_AUTH -> MsgId
"NO_AUTH"
    CommandError
HAS_AUTH -> MsgId
"HAS_AUTH"
    CommandError
NO_ENTITY -> MsgId
"NO_ENTITY"
  smpP :: Parser MsgId CommandError
smpP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId CommandError)
-> Parser MsgId CommandError
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"UNKNOWN" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
UNKNOWN
      MsgId
"SYNTAX" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
SYNTAX
      MsgId
"PROHIBITED" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
PROHIBITED
      MsgId
"NO_AUTH" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
NO_AUTH
      MsgId
"HAS_AUTH" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
HAS_AUTH
      MsgId
"NO_ENTITY" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
NO_ENTITY
      MsgId
"NO_QUEUE" -> CommandError -> Parser MsgId CommandError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandError
NO_ENTITY -- for backward compatibility
      MsgId
_ -> String -> Parser MsgId CommandError
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad CommandError"

instance Encoding ProxyError where
  smpEncode :: ProxyError -> MsgId
smpEncode = \case
    PROTOCOL ErrorType
e -> MsgId
"PROTOCOL " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> ErrorType -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode ErrorType
e
    BROKER BrokerErrorType
e -> MsgId
"BROKER " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> BrokerErrorType -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode BrokerErrorType
e
    ProxyError
BASIC_AUTH -> MsgId
"BASIC_AUTH"
    ProxyError
NO_SESSION -> MsgId
"NO_SESSION"
  smpP :: Parser MsgId ProxyError
smpP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId ProxyError) -> Parser MsgId ProxyError
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"PROTOCOL" -> ErrorType -> ProxyError
PROTOCOL (ErrorType -> ProxyError)
-> Parser ErrorType -> Parser MsgId ProxyError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ErrorType
forall a. Encoding a => Parser a
_smpP
      MsgId
"BROKER" -> BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError)
-> Parser MsgId BrokerErrorType -> Parser MsgId ProxyError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId BrokerErrorType
forall a. Encoding a => Parser a
_smpP
      MsgId
"BASIC_AUTH" -> ProxyError -> Parser MsgId ProxyError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyError
BASIC_AUTH
      MsgId
"NO_SESSION" -> ProxyError -> Parser MsgId ProxyError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyError
NO_SESSION
      MsgId
_ -> String -> Parser MsgId ProxyError
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ProxyError"

instance StrEncoding ProxyError where
  strEncode :: ProxyError -> MsgId
strEncode = \case
    PROTOCOL ErrorType
e -> MsgId
"PROTOCOL " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> ErrorType -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode ErrorType
e
    BROKER BrokerErrorType
e -> MsgId
"BROKER " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> BrokerErrorType -> MsgId
forall a. StrEncoding a => a -> MsgId
strEncode BrokerErrorType
e
    ProxyError
BASIC_AUTH -> MsgId
"BASIC_AUTH"
    ProxyError
NO_SESSION -> MsgId
"NO_SESSION"
  strP :: Parser MsgId ProxyError
strP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId ProxyError) -> Parser MsgId ProxyError
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"PROTOCOL" -> ErrorType -> ProxyError
PROTOCOL (ErrorType -> ProxyError)
-> Parser ErrorType -> Parser MsgId ProxyError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ErrorType
forall a. StrEncoding a => Parser a
_strP
      MsgId
"BROKER" -> BrokerErrorType -> ProxyError
BROKER (BrokerErrorType -> ProxyError)
-> Parser MsgId BrokerErrorType -> Parser MsgId ProxyError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId BrokerErrorType
forall a. StrEncoding a => Parser a
_strP
      MsgId
"BASIC_AUTH" -> ProxyError -> Parser MsgId ProxyError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyError
BASIC_AUTH
      MsgId
"NO_SESSION" -> ProxyError -> Parser MsgId ProxyError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProxyError
NO_SESSION
      MsgId
_ -> String -> Parser MsgId ProxyError
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad ProxyError"

instance Encoding BrokerErrorType where
  smpEncode :: BrokerErrorType -> MsgId
smpEncode = \case
    RESPONSE String
e -> MsgId
"RESPONSE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> String -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode String
e
    UNEXPECTED String
e -> MsgId
"UNEXPECTED " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> String -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode String
e
    TRANSPORT TransportError
e -> MsgId
"TRANSPORT " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> TransportError -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode TransportError
e
    NETWORK NetworkError
_e -> MsgId
"NETWORK" -- TODO once all upgrade: "NETWORK " <> smpEncode e
    BrokerErrorType
TIMEOUT -> MsgId
"TIMEOUT"
    BrokerErrorType
HOST -> MsgId
"HOST"
    BrokerErrorType
NO_SERVICE -> MsgId
"NO_SERVICE"
  smpP :: Parser MsgId BrokerErrorType
smpP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId BrokerErrorType)
-> Parser MsgId BrokerErrorType
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"RESPONSE" -> String -> BrokerErrorType
RESPONSE (String -> BrokerErrorType)
-> Parser MsgId String -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
forall a. Encoding a => Parser a
_smpP
      MsgId
"UNEXPECTED" -> String -> BrokerErrorType
UNEXPECTED (String -> BrokerErrorType)
-> Parser MsgId String -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
forall a. Encoding a => Parser a
_smpP
      MsgId
"TRANSPORT" -> TransportError -> BrokerErrorType
TRANSPORT (TransportError -> BrokerErrorType)
-> Parser MsgId TransportError -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId TransportError
forall a. Encoding a => Parser a
_smpP
      MsgId
"NETWORK" -> NetworkError -> BrokerErrorType
NETWORK (NetworkError -> BrokerErrorType)
-> Parser MsgId NetworkError -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser MsgId NetworkError
forall a. Encoding a => Parser a
_smpP Parser MsgId NetworkError
-> Parser MsgId NetworkError -> Parser MsgId NetworkError
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEFailedError)
      MsgId
"TIMEOUT" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
TIMEOUT
      MsgId
"HOST" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
HOST
      MsgId
"NO_SERVICE" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
NO_SERVICE
      MsgId
_ -> String -> Parser MsgId BrokerErrorType
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad BrokerErrorType"

instance StrEncoding BrokerErrorType where
  strEncode :: BrokerErrorType -> MsgId
strEncode = \case
    RESPONSE String
e -> MsgId
"RESPONSE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 (String -> Text
T.pack String
e)
    UNEXPECTED String
e -> MsgId
"UNEXPECTED " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 (String -> Text
T.pack String
e)
    TRANSPORT TransportError
e -> MsgId
"TRANSPORT " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> TransportError -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode TransportError
e
    NETWORK NetworkError
_e -> MsgId
"NETWORK" -- TODO once all upgrade: "NETWORK " <> strEncode e
    BrokerErrorType
TIMEOUT -> MsgId
"TIMEOUT"
    BrokerErrorType
HOST -> MsgId
"HOST"
    BrokerErrorType
NO_SERVICE -> MsgId
"NO_SERVICE"
  strP :: Parser MsgId BrokerErrorType
strP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId BrokerErrorType)
-> Parser MsgId BrokerErrorType
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"RESPONSE" -> String -> BrokerErrorType
RESPONSE (String -> BrokerErrorType)
-> Parser MsgId String -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
_textP
      MsgId
"UNEXPECTED" -> String -> BrokerErrorType
UNEXPECTED (String -> BrokerErrorType)
-> Parser MsgId String -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
_textP
      MsgId
"TRANSPORT" -> TransportError -> BrokerErrorType
TRANSPORT (TransportError -> BrokerErrorType)
-> Parser MsgId TransportError -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId TransportError
forall a. Encoding a => Parser a
_smpP
      MsgId
"NETWORK" -> NetworkError -> BrokerErrorType
NETWORK (NetworkError -> BrokerErrorType)
-> Parser MsgId NetworkError -> Parser MsgId BrokerErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser MsgId NetworkError
forall a. StrEncoding a => Parser a
_strP Parser MsgId NetworkError
-> Parser MsgId NetworkError -> Parser MsgId NetworkError
forall a. Parser MsgId a -> Parser MsgId a -> Parser MsgId a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEFailedError)
      MsgId
"TIMEOUT" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
TIMEOUT
      MsgId
"HOST" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
HOST
      MsgId
"NO_SERVICE" -> BrokerErrorType -> Parser MsgId BrokerErrorType
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BrokerErrorType
NO_SERVICE
      MsgId
_ -> String -> Parser MsgId BrokerErrorType
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad BrokerErrorType"

instance Encoding NetworkError where
  smpEncode :: NetworkError -> MsgId
smpEncode = \case
    NEConnectError String
e -> MsgId
"CONNECT " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> String -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode String
e
    NETLSError String
e -> MsgId
"TLS " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> String -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode String
e
    NetworkError
NEUnknownCAError -> MsgId
"UNKNOWNCA"
    NetworkError
NEFailedError -> MsgId
"FAILED"
    NetworkError
NETimeoutError -> MsgId
"TIMEOUT"
    NESubscribeError String
e -> MsgId
"SUBSCRIBE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> String -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode String
e
  smpP :: Parser MsgId NetworkError
smpP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId NetworkError)
-> Parser MsgId NetworkError
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"CONNECT" -> String -> NetworkError
NEConnectError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
forall a. Encoding a => Parser a
_smpP
      MsgId
"TLS" -> String -> NetworkError
NETLSError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
forall a. Encoding a => Parser a
_smpP
      MsgId
"UNKNOWNCA" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEUnknownCAError
      MsgId
"FAILED" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEFailedError
      MsgId
"TIMEOUT" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NETimeoutError
      MsgId
"SUBSCRIBE" -> String -> NetworkError
NESubscribeError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
forall a. Encoding a => Parser a
_smpP
      MsgId
_ -> String -> Parser MsgId NetworkError
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad NetworkError"

instance StrEncoding NetworkError where
  strEncode :: NetworkError -> MsgId
strEncode = \case
    NEConnectError String
e -> MsgId
"CONNECT " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 (String -> Text
T.pack String
e)
    NETLSError String
e -> MsgId
"TLS " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 (String -> Text
T.pack String
e)
    NetworkError
NEUnknownCAError -> MsgId
"UNKNOWNCA"
    NetworkError
NEFailedError -> MsgId
"FAILED"
    NetworkError
NETimeoutError -> MsgId
"TIMEOUT"
    NESubscribeError String
e -> MsgId
"SUBSCRIBE " MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Text -> MsgId
encodeUtf8 (String -> Text
T.pack String
e)
  strP :: Parser MsgId NetworkError
strP =
    (Char -> Bool) -> Parser MsgId MsgId
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser MsgId MsgId
-> (MsgId -> Parser MsgId NetworkError)
-> Parser MsgId NetworkError
forall a b.
Parser MsgId a -> (a -> Parser MsgId b) -> Parser MsgId b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      MsgId
"CONNECT" -> String -> NetworkError
NEConnectError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
_textP
      MsgId
"TLS" -> String -> NetworkError
NETLSError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
_textP
      MsgId
"UNKNOWNCA" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEUnknownCAError
      MsgId
"FAILED" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NEFailedError
      MsgId
"TIMEOUT" -> NetworkError -> Parser MsgId NetworkError
forall a. a -> Parser MsgId a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NetworkError
NETimeoutError
      MsgId
"SUBSCRIBE" -> String -> NetworkError
NESubscribeError (String -> NetworkError)
-> Parser MsgId String -> Parser MsgId NetworkError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId String
_textP
      MsgId
_ -> String -> Parser MsgId NetworkError
forall a. String -> Parser MsgId a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"bad NetworkError"

_textP :: Parser String
_textP :: Parser MsgId String
_textP = Parser Char
A.space Parser Char -> Parser MsgId String -> Parser MsgId String
forall a b. Parser MsgId a -> Parser MsgId b -> Parser MsgId b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> String
T.unpack (Text -> String) -> (MsgId -> Text) -> MsgId -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> Text
safeDecodeUtf8 (MsgId -> String) -> Parser MsgId MsgId -> Parser MsgId String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser MsgId MsgId
A.takeByteString)

-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
tPut :: forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO [Either TransportError ()]
tPut th :: THandle v c p
th@THandle {THandleParams v p
params :: THandleParams v p
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params} = ([[Either TransportError ()]] -> [Either TransportError ()])
-> IO [[Either TransportError ()]] -> IO [Either TransportError ()]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Either TransportError ()]] -> [Either TransportError ()]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[Either TransportError ()]] -> IO [Either TransportError ()])
-> (NonEmpty (Either TransportError SentRawTransmission)
    -> IO [[Either TransportError ()]])
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO [Either TransportError ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TransportBatch () -> IO [Either TransportError ()])
-> [TransportBatch ()] -> IO [[Either TransportError ()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TransportBatch () -> IO [Either TransportError ()]
tPutBatch ([TransportBatch ()] -> IO [[Either TransportError ()]])
-> (NonEmpty (Either TransportError SentRawTransmission)
    -> [TransportBatch ()])
-> NonEmpty (Either TransportError SentRawTransmission)
-> IO [[Either TransportError ()]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
forall v (p :: TransportPeer).
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
batchTransmissions THandleParams v p
params
  where
    tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
    tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
tPutBatch = \case
      TBError TransportError
e ()
_ -> [TransportError -> Either TransportError ()
forall a b. a -> Either a b
Left TransportError
e] [Either TransportError ()]
-> IO () -> IO [Either TransportError ()]
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> IO ()
putStrLn String
"tPut error: large message"
      TBTransmissions MsgId
s Int
n [()]
_ -> Int -> Either TransportError () -> [Either TransportError ()]
forall a. Int -> a -> [a]
replicate Int
n (Either TransportError () -> [Either TransportError ()])
-> IO (Either TransportError ()) -> IO [Either TransportError ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle v c p -> MsgId -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> MsgId -> IO (Either TransportError ())
tPutLog THandle v c p
th MsgId
s
      TBTransmission MsgId
s ()
_ -> (Either TransportError ()
-> [Either TransportError ()] -> [Either TransportError ()]
forall a. a -> [a] -> [a]
: []) (Either TransportError () -> [Either TransportError ()])
-> IO (Either TransportError ()) -> IO [Either TransportError ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle v c p -> MsgId -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> MsgId -> IO (Either TransportError ())
tPutLog THandle v c p
th MsgId
s

tPutLog :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
tPutLog :: forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> MsgId -> IO (Either TransportError ())
tPutLog THandle v c p
th MsgId
s = do
  Either TransportError ()
r <- THandle v c p -> MsgId -> IO (Either TransportError ())
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> MsgId -> IO (Either TransportError ())
tPutBlock THandle v c p
th MsgId
s
  case Either TransportError ()
r of
    Left TransportError
e -> String -> IO ()
putStrLn (String
"tPut error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TransportError -> String
forall a. Show a => a -> String
show TransportError
e)
    Either TransportError ()
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Either TransportError () -> IO (Either TransportError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either TransportError ()
r

-- ByteString in TBTransmissions includes byte with transmissions count
data TransportBatch r = TBTransmissions ByteString Int [r] | TBTransmission ByteString r | TBError TransportError r

batchTransmissions :: THandleParams v p -> NonEmpty (Either TransportError SentRawTransmission) -> [TransportBatch ()]
batchTransmissions :: forall v (p :: TransportPeer).
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
batchTransmissions THandleParams v p
params = THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission, ())
-> [TransportBatch ()]
forall v (p :: TransportPeer) r.
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission, r)
-> [TransportBatch r]
batchTransmissions' THandleParams v p
params (NonEmpty (Either TransportError SentRawTransmission, ())
 -> [TransportBatch ()])
-> (NonEmpty (Either TransportError SentRawTransmission)
    -> NonEmpty (Either TransportError SentRawTransmission, ()))
-> NonEmpty (Either TransportError SentRawTransmission)
-> [TransportBatch ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either TransportError SentRawTransmission
 -> (Either TransportError SentRawTransmission, ()))
-> NonEmpty (Either TransportError SentRawTransmission)
-> NonEmpty (Either TransportError SentRawTransmission, ())
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (,())

-- | encodes and batches transmissions into blocks
batchTransmissions' :: forall v p r. THandleParams v p -> NonEmpty (Either TransportError SentRawTransmission, r) -> [TransportBatch r]
batchTransmissions' :: forall v (p :: TransportPeer) r.
THandleParams v p
-> NonEmpty (Either TransportError SentRawTransmission, r)
-> [TransportBatch r]
batchTransmissions' THandleParams {Bool
batch :: Bool
$sel:batch:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
batch, $sel:blockSize:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Int
blockSize = Int
bSize, Bool
$sel:serviceAuth:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
serviceAuth :: Bool
serviceAuth} NonEmpty (Either TransportError SentRawTransmission, r)
ts
  | Bool
batch = Int
-> NonEmpty (Either TransportError MsgId, r) -> [TransportBatch r]
forall r.
Int
-> NonEmpty (Either TransportError MsgId, r) -> [TransportBatch r]
batchTransmissions_ Int
bSize (NonEmpty (Either TransportError MsgId, r) -> [TransportBatch r])
-> NonEmpty (Either TransportError MsgId, r) -> [TransportBatch r]
forall a b. (a -> b) -> a -> b
$ ((Either TransportError SentRawTransmission, r)
 -> (Either TransportError MsgId, r))
-> NonEmpty (Either TransportError SentRawTransmission, r)
-> NonEmpty (Either TransportError MsgId, r)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map ((Either TransportError SentRawTransmission
 -> Either TransportError MsgId)
-> (Either TransportError SentRawTransmission, r)
-> (Either TransportError MsgId, r)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Either TransportError SentRawTransmission
  -> Either TransportError MsgId)
 -> (Either TransportError SentRawTransmission, r)
 -> (Either TransportError MsgId, r))
-> (Either TransportError SentRawTransmission
    -> Either TransportError MsgId)
-> (Either TransportError SentRawTransmission, r)
-> (Either TransportError MsgId, r)
forall a b. (a -> b) -> a -> b
$ (SentRawTransmission -> MsgId)
-> Either TransportError SentRawTransmission
-> Either TransportError MsgId
forall a b.
(a -> b) -> Either TransportError a -> Either TransportError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SentRawTransmission -> MsgId)
 -> Either TransportError SentRawTransmission
 -> Either TransportError MsgId)
-> (SentRawTransmission -> MsgId)
-> Either TransportError SentRawTransmission
-> Either TransportError MsgId
forall a b. (a -> b) -> a -> b
$ Bool -> SentRawTransmission -> MsgId
tEncodeForBatch Bool
serviceAuth) NonEmpty (Either TransportError SentRawTransmission, r)
ts
  | Bool
otherwise = ((Either TransportError SentRawTransmission, r)
 -> TransportBatch r)
-> [(Either TransportError SentRawTransmission, r)]
-> [TransportBatch r]
forall a b. (a -> b) -> [a] -> [b]
map (Either TransportError SentRawTransmission, r) -> TransportBatch r
mkBatch1 ([(Either TransportError SentRawTransmission, r)]
 -> [TransportBatch r])
-> [(Either TransportError SentRawTransmission, r)]
-> [TransportBatch r]
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either TransportError SentRawTransmission, r)
-> [(Either TransportError SentRawTransmission, r)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty (Either TransportError SentRawTransmission, r)
ts
  where
    mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r
    mkBatch1 :: (Either TransportError SentRawTransmission, r) -> TransportBatch r
mkBatch1 (Either TransportError SentRawTransmission
t_, r
r) = case Either TransportError SentRawTransmission
t_ of
      Left TransportError
e -> TransportError -> r -> TransportBatch r
forall r. TransportError -> r -> TransportBatch r
TBError TransportError
e r
r
      Right SentRawTransmission
t
        -- 2 bytes are reserved for pad size
        | MsgId -> Int
B.length MsgId
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 -> MsgId -> r -> TransportBatch r
forall r. MsgId -> r -> TransportBatch r
TBTransmission MsgId
s r
r
        | Bool
otherwise -> TransportError -> r -> TransportBatch r
forall r. TransportError -> r -> TransportBatch r
TBError TransportError
TELargeMsg r
r
        where
          s :: MsgId
s = Bool -> SentRawTransmission -> MsgId
tEncode Bool
serviceAuth SentRawTransmission
t

-- | Pack encoded transmissions into batches
batchTransmissions_ :: Int -> NonEmpty (Either TransportError ByteString, r) -> [TransportBatch r]
batchTransmissions_ :: forall r.
Int
-> NonEmpty (Either TransportError MsgId, r) -> [TransportBatch r]
batchTransmissions_ Int
bSize = ([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
forall r.
([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
addBatch (([TransportBatch r], Int, Int, [MsgId], [r])
 -> [TransportBatch r])
-> (NonEmpty (Either TransportError MsgId, r)
    -> ([TransportBatch r], Int, Int, [MsgId], [r]))
-> NonEmpty (Either TransportError MsgId, r)
-> [TransportBatch r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Either TransportError MsgId, r)
 -> ([TransportBatch r], Int, Int, [MsgId], [r])
 -> ([TransportBatch r], Int, Int, [MsgId], [r]))
-> ([TransportBatch r], Int, Int, [MsgId], [r])
-> NonEmpty (Either TransportError MsgId, r)
-> ([TransportBatch r], Int, Int, [MsgId], [r])
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Either TransportError MsgId, r)
-> ([TransportBatch r], Int, Int, [MsgId], [r])
-> ([TransportBatch r], Int, Int, [MsgId], [r])
forall r.
(Either TransportError MsgId, r)
-> ([TransportBatch r], Int, Int, [MsgId], [r])
-> ([TransportBatch r], Int, Int, [MsgId], [r])
addTransmission ([], Int
0, Int
0, [], [])
  where
    -- 19 = 2 bytes reserved for pad size + 1 for transmission count + 16 auth tag from block encryption
    bSize' :: Int
bSize' = Int
bSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
19
    addTransmission :: (Either TransportError ByteString, r) -> ([TransportBatch r], Int, Int, [ByteString], [r]) -> ([TransportBatch r], Int, Int, [ByteString], [r])
    addTransmission :: forall r.
(Either TransportError MsgId, r)
-> ([TransportBatch r], Int, Int, [MsgId], [r])
-> ([TransportBatch r], Int, Int, [MsgId], [r])
addTransmission (Either TransportError MsgId
t_, r
r) acc :: ([TransportBatch r], Int, Int, [MsgId], [r])
acc@([TransportBatch r]
bs, !Int
len, !Int
n, [MsgId]
ss, [r]
rs) = case Either TransportError MsgId
t_ of
      Left TransportError
e -> (TransportError -> r -> TransportBatch r
forall r. TransportError -> r -> TransportBatch r
TBError TransportError
e r
r TransportBatch r -> [TransportBatch r] -> [TransportBatch r]
forall a. a -> [a] -> [a]
: ([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
forall r.
([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
addBatch ([TransportBatch r], Int, Int, [MsgId], [r])
acc, Int
0, Int
0, [], [])
      Right MsgId
s
        | Int
len' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bSize' Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
255 -> ([TransportBatch r]
bs, Int
len', Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, MsgId
s MsgId -> [MsgId] -> [MsgId]
forall a. a -> [a] -> [a]
: [MsgId]
ss, r
r r -> [r] -> [r]
forall a. a -> [a] -> [a]
: [r]
rs)
        | Int
sLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
bSize' -> (([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
forall r.
([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
addBatch ([TransportBatch r], Int, Int, [MsgId], [r])
acc, Int
sLen, Int
1, [MsgId
Item [MsgId]
s], [r
Item [r]
r])
        | Bool
otherwise -> (TransportError -> r -> TransportBatch r
forall r. TransportError -> r -> TransportBatch r
TBError TransportError
TELargeMsg r
r TransportBatch r -> [TransportBatch r] -> [TransportBatch r]
forall a. a -> [a] -> [a]
: ([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
forall r.
([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
addBatch ([TransportBatch r], Int, Int, [MsgId], [r])
acc, Int
0, Int
0, [], [])
        where
          sLen :: Int
sLen = MsgId -> Int
B.length MsgId
s
          len' :: Int
len' = Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sLen
    addBatch :: ([TransportBatch r], Int, Int, [ByteString], [r]) -> [TransportBatch r]
    addBatch :: forall r.
([TransportBatch r], Int, Int, [MsgId], [r]) -> [TransportBatch r]
addBatch ([TransportBatch r]
bs, Int
_len, Int
n, [MsgId]
ss, [r]
rs) = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [TransportBatch r]
bs else MsgId -> Int -> [r] -> TransportBatch r
forall r. MsgId -> Int -> [r] -> TransportBatch r
TBTransmissions MsgId
b Int
n [r]
rs TransportBatch r -> [TransportBatch r] -> [TransportBatch r]
forall a. a -> [a] -> [a]
: [TransportBatch r]
bs
      where
        b :: MsgId
b = [MsgId] -> MsgId
B.concat ([MsgId] -> MsgId) -> [MsgId] -> MsgId
forall a b. (a -> b) -> a -> b
$ Char -> MsgId
B.singleton (Int -> Char
lenEncode Int
n) MsgId -> [MsgId] -> [MsgId]
forall a. a -> [a] -> [a]
: [MsgId]
ss

tEncode :: Bool -> SentRawTransmission -> ByteString
tEncode :: Bool -> SentRawTransmission -> MsgId
tEncode Bool
serviceAuth (Maybe TAuthorizations
auth, MsgId
t) = Bool -> Maybe TAuthorizations -> MsgId
tEncodeAuth Bool
serviceAuth Maybe TAuthorizations
auth MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
t
{-# INLINE tEncode #-}

tEncodeForBatch :: Bool -> SentRawTransmission -> ByteString
tEncodeForBatch :: Bool -> SentRawTransmission -> MsgId
tEncodeForBatch Bool
serviceAuth = Large -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (Large -> MsgId)
-> (SentRawTransmission -> Large) -> SentRawTransmission -> MsgId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgId -> Large
Large (MsgId -> Large)
-> (SentRawTransmission -> MsgId) -> SentRawTransmission -> Large
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> SentRawTransmission -> MsgId
tEncode Bool
serviceAuth
{-# INLINE tEncodeForBatch #-}

tEncodeBatch1 :: Bool -> SentRawTransmission -> ByteString
tEncodeBatch1 :: Bool -> SentRawTransmission -> MsgId
tEncodeBatch1 Bool
serviceAuth SentRawTransmission
t = Int -> Char
lenEncode Int
1 Char -> MsgId -> MsgId
`B.cons` Bool -> SentRawTransmission -> MsgId
tEncodeForBatch Bool
serviceAuth SentRawTransmission
t
{-# INLINE tEncodeBatch1 #-}

-- tForAuth is lazy to avoid computing it when there is no key to sign
data TransmissionForAuth = TransmissionForAuth {TransmissionForAuth -> MsgId
tForAuth :: ~ByteString, TransmissionForAuth -> MsgId
tToSend :: ByteString}

encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth :: forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams {$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion = Version v
v, MsgId
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> MsgId
sessionId :: MsgId
sessionId, Bool
$sel:implySessId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId :: Bool
implySessId} Transmission c
t =
  TransmissionForAuth {MsgId
$sel:tForAuth:TransmissionForAuth :: MsgId
tForAuth :: MsgId
tForAuth, $sel:tToSend:TransmissionForAuth :: MsgId
tToSend = if Bool
implySessId then MsgId
t' else MsgId
tForAuth}
  where
    tForAuth :: MsgId
tForAuth = MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode MsgId
sessionId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
t'
    t' :: MsgId
t' = Version v -> Transmission c -> MsgId
forall v e c.
ProtocolEncoding v e c =>
Version v -> Transmission c -> MsgId
encodeTransmission_ Version v
v Transmission c
t
{-# INLINE encodeTransmissionForAuth #-}

encodeTransmission :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> ByteString
encodeTransmission :: forall v e c (p :: TransportPeer).
ProtocolEncoding v e c =>
THandleParams v p -> Transmission c -> MsgId
encodeTransmission THandleParams {$sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion = Version v
v, MsgId
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> MsgId
sessionId :: MsgId
sessionId, Bool
$sel:implySessId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId :: Bool
implySessId} Transmission c
t =
  if Bool
implySessId then MsgId
t' else MsgId -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode MsgId
sessionId MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> MsgId
t'
  where
    t' :: MsgId
t' = Version v -> Transmission c -> MsgId
forall v e c.
ProtocolEncoding v e c =>
Version v -> Transmission c -> MsgId
encodeTransmission_ Version v
v Transmission c
t
{-# INLINE encodeTransmission #-}

encodeTransmission_ :: ProtocolEncoding v e c => Version v -> Transmission c -> ByteString
encodeTransmission_ :: forall v e c.
ProtocolEncoding v e c =>
Version v -> Transmission c -> MsgId
encodeTransmission_ Version v
v (CorrId MsgId
corrId, LinkId
queueId, c
command) =
  (MsgId, LinkId) -> MsgId
forall a. Encoding a => a -> MsgId
smpEncode (MsgId
corrId, LinkId
queueId) MsgId -> MsgId -> MsgId
forall a. Semigroup a => a -> a -> a
<> Version v -> c -> MsgId
forall v err msg.
ProtocolEncoding v err msg =>
Version v -> msg -> MsgId
encodeProtocol Version v
v c
command
{-# INLINE encodeTransmission_ #-}

-- | Receive and parse transmission from the TCP transport (ignoring any trailing padding).
tGetParse :: Transport c => THandle v c p -> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse :: forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p
-> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse th :: THandle v c p
th@THandle {THandleParams v p
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params :: THandleParams v p
params} = (MsgId -> NonEmpty (Either TransportError RawTransmission))
-> Either TransportError MsgId
-> NonEmpty (Either TransportError RawTransmission)
forall a e b.
(a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
eitherList (THandleParams v p
-> MsgId -> NonEmpty (Either TransportError RawTransmission)
forall v (p :: TransportPeer).
THandleParams v p
-> MsgId -> NonEmpty (Either TransportError RawTransmission)
tParse THandleParams v p
params) (Either TransportError MsgId
 -> NonEmpty (Either TransportError RawTransmission))
-> IO (Either TransportError MsgId)
-> IO (NonEmpty (Either TransportError RawTransmission))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle v c p -> IO (Either TransportError MsgId)
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p -> IO (Either TransportError MsgId)
tGetBlock THandle v c p
th
{-# INLINE tGetParse #-}

tParse :: THandleParams v p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse :: forall v (p :: TransportPeer).
THandleParams v p
-> MsgId -> NonEmpty (Either TransportError RawTransmission)
tParse thParams :: THandleParams v p
thParams@THandleParams {Bool
$sel:batch:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
batch :: Bool
batch} MsgId
s
  | Bool
batch = (NonEmpty Large
 -> NonEmpty (Either TransportError RawTransmission))
-> Either TransportError (NonEmpty Large)
-> NonEmpty (Either TransportError RawTransmission)
forall a e b.
(a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
eitherList ((Large -> Either TransportError RawTransmission)
-> NonEmpty Large
-> NonEmpty (Either TransportError RawTransmission)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (\(Large MsgId
t) -> MsgId -> Either TransportError RawTransmission
tParse1 MsgId
t)) Either TransportError (NonEmpty Large)
ts
  | Bool
otherwise = [MsgId -> Either TransportError RawTransmission
tParse1 MsgId
s]
  where
    tParse1 :: MsgId -> Either TransportError RawTransmission
tParse1 = Parser RawTransmission
-> TransportError -> MsgId -> Either TransportError RawTransmission
forall a e. Parser a -> e -> MsgId -> Either e a
parse (THandleParams v p -> Parser RawTransmission
forall v (p :: TransportPeer).
THandleParams v p -> Parser RawTransmission
transmissionP THandleParams v p
thParams) TransportError
TEBadBlock
    ts :: Either TransportError (NonEmpty Large)
ts = Parser (NonEmpty Large)
-> TransportError
-> MsgId
-> Either TransportError (NonEmpty Large)
forall a e. Parser a -> e -> MsgId -> Either e a
parse Parser (NonEmpty Large)
forall a. Encoding a => Parser a
smpP TransportError
TEBadBlock MsgId
s

eitherList :: (a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
eitherList :: forall a e b.
(a -> NonEmpty (Either e b)) -> Either e a -> NonEmpty (Either e b)
eitherList = (e -> NonEmpty (Either e b))
-> (a -> NonEmpty (Either e b))
-> Either e a
-> NonEmpty (Either e b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\e
e -> [e -> Either e b
forall a b. a -> Either a b
Left e
e])

-- | Receive server transmissions
tGetServer :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TServer -> IO (NonEmpty (SignedTransmissionOrError err cmd))
tGetServer :: forall v err cmd (c :: TransportPeer -> *).
(ProtocolEncoding v err cmd, Transport c) =>
THandle v c 'TServer
-> IO (NonEmpty (SignedTransmissionOrError err cmd))
tGetServer = (THandleParams v 'TServer
 -> Either TransportError RawTransmission
 -> SignedTransmissionOrError err cmd)
-> THandle v c 'TServer
-> IO (NonEmpty (SignedTransmissionOrError err cmd))
forall (c :: TransportPeer -> *) v (p :: TransportPeer) r.
Transport c =>
(THandleParams v p -> Either TransportError RawTransmission -> r)
-> THandle v c p -> IO (NonEmpty r)
tGet THandleParams v 'TServer
-> Either TransportError RawTransmission
-> SignedTransmissionOrError err cmd
forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TServer
-> Either TransportError RawTransmission
-> SignedTransmissionOrError err cmd
tDecodeServer
{-# INLINE tGetServer #-}

-- | Receive client transmissions
tGetClient :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TClient -> IO (NonEmpty (Transmission (Either err cmd)))
tGetClient :: forall v err cmd (c :: TransportPeer -> *).
(ProtocolEncoding v err cmd, Transport c) =>
THandle v c 'TClient
-> IO (NonEmpty (Transmission (Either err cmd)))
tGetClient = (THandleParams v 'TClient
 -> Either TransportError RawTransmission
 -> Transmission (Either err cmd))
-> THandle v c 'TClient
-> IO (NonEmpty (Transmission (Either err cmd)))
forall (c :: TransportPeer -> *) v (p :: TransportPeer) r.
Transport c =>
(THandleParams v p -> Either TransportError RawTransmission -> r)
-> THandle v c p -> IO (NonEmpty r)
tGet THandleParams v 'TClient
-> Either TransportError RawTransmission
-> Transmission (Either err cmd)
forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TClient
-> Either TransportError RawTransmission
-> Transmission (Either err cmd)
tDecodeClient
{-# INLINE tGetClient #-}

tGet ::
  Transport c =>
  (THandleParams v p -> Either TransportError RawTransmission -> r) ->
  THandle v c p ->
  IO (NonEmpty r)
tGet :: forall (c :: TransportPeer -> *) v (p :: TransportPeer) r.
Transport c =>
(THandleParams v p -> Either TransportError RawTransmission -> r)
-> THandle v c p -> IO (NonEmpty r)
tGet THandleParams v p -> Either TransportError RawTransmission -> r
tDecode th :: THandle v c p
th@THandle {THandleParams v p
$sel:params:THandle :: forall v (c :: TransportPeer -> *) (p :: TransportPeer).
THandle v c p -> THandleParams v p
params :: THandleParams v p
params} = (Either TransportError RawTransmission -> r)
-> NonEmpty (Either TransportError RawTransmission) -> NonEmpty r
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
L.map (THandleParams v p -> Either TransportError RawTransmission -> r
tDecode THandleParams v p
params) (NonEmpty (Either TransportError RawTransmission) -> NonEmpty r)
-> IO (NonEmpty (Either TransportError RawTransmission))
-> IO (NonEmpty r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle v c p
-> IO (NonEmpty (Either TransportError RawTransmission))
forall (c :: TransportPeer -> *) v (p :: TransportPeer).
Transport c =>
THandle v c p
-> IO (NonEmpty (Either TransportError RawTransmission))
tGetParse THandle v c p
th
{-# INLINE tGet #-}

tDecodeServer :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TServer -> Either TransportError RawTransmission -> SignedTransmissionOrError err cmd
tDecodeServer :: forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TServer
-> Either TransportError RawTransmission
-> SignedTransmissionOrError err cmd
tDecodeServer THandleParams {MsgId
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> MsgId
sessionId :: MsgId
sessionId, $sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion = Version v
v, Bool
$sel:implySessId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId :: Bool
implySessId} = \case
  Right RawTransmission {MsgId
$sel:authenticator:RawTransmission :: RawTransmission -> MsgId
authenticator :: MsgId
authenticator, Maybe (Signature 'Ed25519)
$sel:serviceSig:RawTransmission :: RawTransmission -> Maybe (Signature 'Ed25519)
serviceSig :: Maybe (Signature 'Ed25519)
serviceSig, MsgId
$sel:authorized:RawTransmission :: RawTransmission -> MsgId
authorized :: MsgId
authorized, MsgId
$sel:sessId:RawTransmission :: RawTransmission -> MsgId
sessId :: MsgId
sessId, CorrId
$sel:corrId:RawTransmission :: RawTransmission -> CorrId
corrId :: CorrId
corrId, LinkId
$sel:entityId:RawTransmission :: RawTransmission -> LinkId
entityId :: LinkId
entityId, MsgId
$sel:command:RawTransmission :: RawTransmission -> MsgId
command :: MsgId
command}
    | Bool
implySessId Bool -> Bool -> Bool
|| MsgId
sessId MsgId -> MsgId -> Bool
forall a. Eq a => a -> a -> Bool
== MsgId
sessionId -> case MsgId
-> Maybe (Signature 'Ed25519)
-> Either String (Maybe TAuthorizations)
decodeTAuthBytes MsgId
authenticator Maybe (Signature 'Ed25519)
serviceSig of
        Right Maybe TAuthorizations
tAuth -> (err -> Transmission err)
-> (cmd -> SignedTransmission cmd)
-> Either err cmd
-> SignedTransmissionOrError err cmd
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap err -> Transmission err
forall a. a -> (CorrId, LinkId, a)
t ((Maybe TAuthorizations
tAuth,MsgId
authorized,) (Transmission cmd -> SignedTransmission cmd)
-> (cmd -> Transmission cmd) -> cmd -> SignedTransmission cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. cmd -> Transmission cmd
forall a. a -> (CorrId, LinkId, a)
t) Either err cmd
cmdOrErr
          where
            cmdOrErr :: Either err cmd
cmdOrErr = forall v err msg.
ProtocolEncoding v err msg =>
Version v -> MsgId -> Either err msg
parseProtocol @v @err @cmd Version v
v MsgId
command Either err cmd -> (cmd -> Either err cmd) -> Either err cmd
forall a b. Either err a -> (a -> Either err b) -> Either err b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TAuthorizations -> LinkId -> cmd -> Either err cmd
forall v err msg.
ProtocolEncoding v err msg =>
Maybe TAuthorizations -> LinkId -> msg -> Either err msg
checkCredentials Maybe TAuthorizations
tAuth LinkId
entityId
            t :: a -> (CorrId, EntityId, a)
            t :: forall a. a -> (CorrId, LinkId, a)
t = (CorrId
corrId,LinkId
entityId,)
        Left String
_ -> CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
tError CorrId
corrId ProtocolErrorType
PEBlock
    | Bool
otherwise -> CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
tError CorrId
corrId ProtocolErrorType
PESession
  Left TransportError
_ -> CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
tError CorrId
"" ProtocolErrorType
PEBlock
  where
    tError :: CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
    tError :: CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
tError CorrId
corrId ProtocolErrorType
err = Transmission err -> SignedTransmissionOrError err cmd
forall a b. a -> Either a b
Left (CorrId
corrId, LinkId
NoEntity, forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @v @err @cmd ProtocolErrorType
err)

tDecodeClient :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TClient -> Either TransportError RawTransmission -> Transmission (Either err cmd)
tDecodeClient :: forall v err cmd.
ProtocolEncoding v err cmd =>
THandleParams v 'TClient
-> Either TransportError RawTransmission
-> Transmission (Either err cmd)
tDecodeClient THandleParams {MsgId
$sel:sessionId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> MsgId
sessionId :: MsgId
sessionId, $sel:thVersion:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Version v
thVersion = Version v
v, Bool
$sel:implySessId:THandleParams :: forall v (p :: TransportPeer). THandleParams v p -> Bool
implySessId :: Bool
implySessId} = \case
  Right RawTransmission {MsgId
$sel:sessId:RawTransmission :: RawTransmission -> MsgId
sessId :: MsgId
sessId, CorrId
$sel:corrId:RawTransmission :: RawTransmission -> CorrId
corrId :: CorrId
corrId, LinkId
$sel:entityId:RawTransmission :: RawTransmission -> LinkId
entityId :: LinkId
entityId, MsgId
$sel:command:RawTransmission :: RawTransmission -> MsgId
command :: MsgId
command}
    | Bool
implySessId Bool -> Bool -> Bool
|| MsgId
sessId MsgId -> MsgId -> Bool
forall a. Eq a => a -> a -> Bool
== MsgId
sessionId -> (CorrId
corrId, LinkId
entityId, Either err cmd
cmdOrErr)
    | Bool
otherwise -> CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
tError CorrId
corrId ProtocolErrorType
PESession
    where
      cmdOrErr :: Either err cmd
cmdOrErr = forall v err msg.
ProtocolEncoding v err msg =>
Version v -> MsgId -> Either err msg
parseProtocol @v @err @cmd Version v
v MsgId
command Either err cmd -> (cmd -> Either err cmd) -> Either err cmd
forall a b. Either err a -> (a -> Either err b) -> Either err b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe TAuthorizations -> LinkId -> cmd -> Either err cmd
forall v err msg.
ProtocolEncoding v err msg =>
Maybe TAuthorizations -> LinkId -> msg -> Either err msg
checkCredentials Maybe TAuthorizations
forall a. Maybe a
Nothing LinkId
entityId
  Left TransportError
_ -> CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
tError CorrId
"" ProtocolErrorType
PEBlock
  where
    tError :: CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
    tError :: CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
tError CorrId
corrId ProtocolErrorType
err = (CorrId
corrId, LinkId
NoEntity, err -> Either err cmd
forall a b. a -> Either a b
Left (err -> Either err cmd) -> err -> Either err cmd
forall a b. (a -> b) -> a -> b
$ forall v err msg.
ProtocolEncoding v err msg =>
ProtocolErrorType -> err
fromProtocolError @v @err @cmd ProtocolErrorType
err)

$(J.deriveJSON defaultJSON ''MsgFlags)

$(J.deriveJSON (sumTypeJSON id) ''CommandError)

$(J.deriveToJSON (sumTypeJSON $ dropPrefix "NE") ''NetworkError)

instance FromJSON NetworkError where
  parseJSON :: Value -> Parser NetworkError
parseJSON = $(J.mkParseJSON (sumTypeJSON $ dropPrefix "NE") ''NetworkError)
  omittedField :: Maybe NetworkError
omittedField = NetworkError -> Maybe NetworkError
forall a. a -> Maybe a
Just NetworkError
NEFailedError

$(J.deriveJSON (sumTypeJSON id) ''BrokerErrorType)

$(J.deriveJSON defaultJSON ''BlockingInfo)

-- run deriveJSON in one TH splice to allow mutual instance
$(concat <$> mapM @[] (J.deriveJSON (sumTypeJSON id)) [''ProxyError, ''ErrorType])