simplexmq/src/Simplex/Messaging/Protocol.hs

{-# 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 (..),
    NameErrorType (..),
    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,
    IdsHash (..),
    ServiceSub (..),
    ServiceSubResult (..),
    ServiceSubError (..),
    serviceSubResult,
    queueIdsHash,
    queueIdHash,
    addServiceSubs,
    subtractServiceSubs,
    MaxMessageLen,
    MaxRcvMessageLen,
    EncRcvMsgBody (..),
    RcvMsgBody (..),
    ClientRcvMsgBody (..),
    EncNMsgMeta,
    SMPMsgMeta (..),
    NMsgMeta (..),
    EncFwdResponse (..),
    EncFwdTransmission (..),
    EncResponse (..),
    EncTransmission (..),
    FwdResponse (..),
    FwdTransmission (..),
    NameRecord (..),
    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 Data.Bits (xor)
import qualified Data.ByteString as BS
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 (foldl')
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 (Word8, 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.Names.Record (NameRecord (..))
import Simplex.Messaging.Parsers
import Simplex.Messaging.Protocol.Types
import Simplex.Messaging.Server.QueueStore.QueueInfo
import Simplex.Messaging.ServiceScheme
import Simplex.Messaging.SimplexName (SimplexNameDomain)
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 VersionSMPC v = Version v

initialSMPClientVersion :: VersionSMPC
initialSMPClientVersion = VersionSMPC 1

srvHostnamesSMPClientVersion :: VersionSMPC
srvHostnamesSMPClientVersion = VersionSMPC 2

sndAuthKeySMPClientVersion :: VersionSMPC
sndAuthKeySMPClientVersion = VersionSMPC 3

shortLinksSMPClientVersion :: VersionSMPC
shortLinksSMPClientVersion = VersionSMPC 4

currentSMPClientVersion :: VersionSMPC
currentSMPClientVersion = VersionSMPC 4

supportedSMPClientVRange :: VersionRangeSMPC
supportedSMPClientVRange = mkVersionRange initialSMPClientVersion currentSMPClientVersion

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

paddedProxiedTLength :: Int
paddedProxiedTLength = 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 = 15904 -- 15865 .. 15960

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

-- | SMP protocol clients
data Party
  = Creator
  | Recipient
  | RecipientService
  | Sender
  | IdleClient
  | Notifier
  | NotifierService
  | LinkClient
  | ProxiedClient
  | ProxyService
  | Resolver
  deriving (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
  SResolver :: SParty Resolver

instance TestEquality SParty where
  testEquality SCreator SCreator = Just Refl
  testEquality SRecipient SRecipient = Just Refl
  testEquality SRecipientService SRecipientService = Just Refl
  testEquality SSender SSender = Just Refl
  testEquality SIdleClient SIdleClient = Just Refl
  testEquality SNotifier SNotifier = Just Refl
  testEquality SNotifierService SNotifierService = Just Refl
  testEquality SSenderLink SSenderLink = Just Refl
  testEquality SProxiedClient SProxiedClient = Just Refl
  testEquality SProxyService SProxyService = Just Refl
  testEquality SResolver SResolver = Just Refl
  testEquality _ _ = Nothing

deriving instance Show (SParty p)

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

instance PartyI Creator where sParty = SCreator

instance PartyI Recipient where sParty = SRecipient

instance PartyI RecipientService where sParty = SRecipientService

instance PartyI Sender where sParty = SSender

instance PartyI IdleClient where sParty = SIdleClient

instance PartyI Notifier where sParty = SNotifier

instance PartyI NotifierService where sParty = SNotifierService

instance PartyI LinkClient where sParty = SSenderLink

instance PartyI ProxiedClient where sParty = SProxiedClient

instance PartyI ProxyService where sParty = SProxyService

instance PartyI Resolver where sParty = SResolver

-- 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 = \case
  SRecipient -> Just Dict
  SSender -> Just Dict
  SSenderLink -> Just Dict
  SNotifier -> Just Dict
  _ -> 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 = \case
  SRecipient -> Just Dict
  SNotifier -> Just Dict
  _ -> 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 = \case
  SRecipientService -> Just Dict
  SNotifierService -> Just Dict
  _ -> Nothing
{-# INLINE serviceParty #-}

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

deriving instance Show ASubscriberParty

instance Eq ASubscriberParty where
  ASP p == ASP p' = isJust $ testEquality p p'

instance Encoding ASubscriberParty where
  smpEncode = \case
    ASP SRecipientService -> "R"
    ASP SNotifierService -> "N"
  smpP =
    A.anyChar >>= \case
      'R' -> pure $ ASP SRecipientService
      'N' -> pure $ ASP SNotifierService
      _ -> fail "bad ASubscriberParty"

instance StrEncoding ASubscriberParty where
  strEncode = smpEncode
  strP = smpP

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

partyServiceRole :: ServiceParty p => SParty p -> SMPServiceRole
partyServiceRole = \case
  SRecipientService -> SRMessaging
  SNotifierService -> 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
  { authenticator :: ByteString, -- signature or encrypted transmission hash
    serviceSig :: Maybe (C.Signature 'C.Ed25519), -- optional second signature with the key of the client service
    authorized :: ByteString, -- authorized transmission
    sessId :: SessionId,
    corrId :: CorrId,
    entityId :: EntityId,
    command :: ByteString
  }
  deriving (Show)

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

data TransmissionAuth
  = TASignature C.ASignature
  | TAAuthenticator C.CbAuthenticator
  deriving (Show)

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

decodeTAuthBytes :: ByteString -> Maybe (C.Signature 'C.Ed25519) -> Either String (Maybe TAuthorizations)
decodeTAuthBytes s serviceSig
  | B.null s = Right Nothing
  | B.length s == C.cbAuthenticatorSize = Right $ Just (TAAuthenticator (C.CbAuthenticator s), serviceSig)
  | otherwise = (\sig -> Just (TASignature sig, serviceSig)) <$> C.decodeSignature 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.
  -- Parameters are expected queue count and hash of all subscribed queues, it allows to monitor "state drift" on the server
  SUBS :: Int64 -> IdsHash -> 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 :: Int64 -> IdsHash -> 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
  -- Resolve SimpleX name.
  RSLV :: SimplexNameDomain -> Command Resolver

deriving instance Show (Command p)

data NewQueueReq = NewQueueReq
  { rcvAuthKey :: RcvPublicAuthKey,
    rcvDhKey :: RcvPublicDhKey,
    auth_ :: Maybe BasicAuth,
    subMode :: SubscriptionMode,
    queueReqData :: Maybe QueueReqData,
    ntfCreds :: Maybe NewNtfCreds
  }
  deriving (Show)

data SubscriptionMode = SMSubscribe | SMOnlyCreate
  deriving (Eq, Show)

-- SenderId must be computed client-side as the first 24 bytes of `sha3-384(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 (Show)

queueReqMode :: QueueReqData -> QueueMode
queueReqMode = \case
  QRMessaging _ -> QMMessaging
  QRContact _ -> QMContact

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

type QueueLinkData = (EncFixedDataBytes, EncUserDataBytes)

type EncFixedDataBytes = EncDataBytes

type EncUserDataBytes = EncDataBytes

newtype EncDataBytes = EncDataBytes ByteString
  deriving (Eq, Show)
  deriving newtype (FromField, StrEncoding)

instance Encoding EncDataBytes where
  smpEncode (EncDataBytes s) = smpEncode (Large s)
  {-# INLINE smpEncode #-}
  smpP = EncDataBytes . unLarge <$> smpP
  {-# INLINE smpP #-}

instance ToField EncDataBytes where
  toField (EncDataBytes s) = toField (Binary s)
  {-# INLINE toField #-}

data NewNtfCreds = NewNtfCreds NtfPublicAuthKey RcvNtfPublicDhKey deriving (Show)

instance StrEncoding SubscriptionMode where
  strEncode = \case
    SMSubscribe -> "subscribe"
    SMOnlyCreate -> "only-create"
  strP =
    (A.string "subscribe" $> SMSubscribe)
      <|> (A.string "only-create" $> SMOnlyCreate)
        <?> "SubscriptionMode"

instance Encoding SubscriptionMode where
  smpEncode = \case
    SMSubscribe -> "S"
    SMOnlyCreate -> "C"
  smpP =
    A.anyChar >>= \case
      'S' -> pure SMSubscribe
      'C' -> pure SMOnlyCreate
      _ -> fail "bad SubscriptionMode"

instance Encoding QueueReqData where
  smpEncode = \case
    QRMessaging d -> smpEncode ('M', d)
    QRContact d -> smpEncode ('C', d)
  smpP =
    A.anyChar >>= \case
      'M' -> QRMessaging <$> smpP
      'C' -> QRContact <$> smpP
      _ -> fail "bad QueueReqData"

instance Encoding NewNtfCreds where
  smpEncode (NewNtfCreds authKey dhKey) = smpEncode (authKey, dhKey)
  smpP = NewNtfCreds <$> smpP <*> smpP

newtype EncTransmission = EncTransmission ByteString
  deriving (Show)

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

instance Encoding FwdTransmission where
  smpEncode FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t} =
    smpEncode (corrId, fwdVersion, fwdKey, Tail t)
  smpP = do
    (corrId, fwdVersion, fwdKey, Tail t) <- smpP
    pure FwdTransmission {fwdCorrId = CorrId corrId, fwdVersion, fwdKey, fwdTransmission = EncTransmission t}

newtype EncFwdTransmission = EncFwdTransmission ByteString
  deriving (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 and XOR-hash of their IDs subscribed with SUBS command
  SOKS :: Int64 -> IdsHash -> 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
  -- sent once delivering messages to SUBS command is complete
  ALLS :: 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 -> IdsHash -> BrokerMsg
  DELD :: BrokerMsg
  INFO :: QueueInfo -> BrokerMsg
  OK :: BrokerMsg
  ERR :: ErrorType -> BrokerMsg
  PONG :: BrokerMsg
  -- Resolved SimpleX name.
  RNAME :: NameRecord -> BrokerMsg
  deriving (Eq, Show)

data RcvMessage = RcvMessage
  { msgId :: MsgId,
    msgBody :: EncRcvMsgBody -- e2e encrypted, with extra encryption for recipient
  }
  deriving (Eq, Show)

newtype EncFwdResponse = EncFwdResponse ByteString
  deriving (Eq, Show)

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

instance Encoding FwdResponse where
  smpEncode FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t} =
    smpEncode (corrId, Tail t)
  smpP = do
    (corrId, Tail t) <- smpP
    pure FwdResponse {fwdCorrId = CorrId corrId, fwdResponse = EncResponse t}

newtype EncResponse = EncResponse ByteString
  deriving (Eq, Show)

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

toMsgInfo :: Message -> MsgInfo
toMsgInfo = \case
  Message {msgId, msgTs} -> msgInfo msgId msgTs MTMessage
  MessageQuota {msgId, msgTs} -> msgInfo msgId msgTs MTQuota
  where
    msgInfo msgId msgTs msgType = MsgInfo {msgId = decodeLatin1 $ B64.encode msgId, msgTs = systemToUTCTime msgTs, msgType}

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

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

newtype EncRcvMsgBody = EncRcvMsgBody ByteString
  deriving (Eq, Show)

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

msgQuotaTag :: ByteString
msgQuotaTag = "QUOTA"

encodeRcvMsgBody :: RcvMsgBody -> C.MaxLenBS MaxRcvMessageLen
encodeRcvMsgBody = \case
  RcvMsgBody {msgTs, msgFlags, msgBody} ->
    let rcvMeta :: C.MaxLenBS 16 = C.unsafeMaxLenBS $ smpEncode (msgTs, msgFlags, ' ')
     in C.appendMaxLenBS rcvMeta msgBody
  RcvMsgQuota {msgTs} ->
    C.unsafeMaxLenBS $ msgQuotaTag <> " " <> smpEncode msgTs

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

clientRcvMsgBodyP :: Parser ClientRcvMsgBody
clientRcvMsgBodyP = msgQuotaP <|> msgBodyP
  where
    msgQuotaP = A.string msgQuotaTag *> (ClientRcvMsgQuota <$> _smpP)
    msgBodyP = do
      msgTs <- smpP
      msgFlags <- smpP
      Tail msgBody <- _smpP
      pure ClientRcvMsgBody {msgTs, msgFlags, msgBody}

instance StrEncoding Message where
  strEncode = \case
    Message {msgId, msgTs, msgFlags, msgBody} ->
      B.unwords
        [ strEncode msgId,
          strEncode msgTs,
          "flags=" <> strEncode msgFlags,
          strEncode msgBody
        ]
    MessageQuota {msgId, msgTs} ->
      B.unwords
        [ strEncode msgId,
          strEncode msgTs,
          "quota"
        ]
  strP = do
    msgId <- strP_
    msgTs <- strP_
    msgQuotaP msgId msgTs <|> msgP msgId msgTs
    where
      msgQuotaP msgId msgTs = "quota" $> MessageQuota {msgId, msgTs}
      msgP msgId msgTs = do
        msgFlags <- ("flags=" *> strP_) <|> pure noMsgFlags
        msgBody <- strP
        pure Message {msgId, msgTs, msgFlags, msgBody}

type EncNMsgMeta = ByteString

data SMPMsgMeta = SMPMsgMeta
  { msgId :: MsgId,
    msgTs :: SystemTime,
    msgFlags :: MsgFlags
  }
  deriving (Eq, Show)

instance StrEncoding SMPMsgMeta where
  strEncode SMPMsgMeta {msgId, msgTs, msgFlags} =
    strEncode (msgId, msgTs, msgFlags)
  strP = do
    (msgId, msgTs, msgFlags) <- strP
    pure SMPMsgMeta {msgId, msgTs, msgFlags}

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

data NMsgMeta = NMsgMeta
  { msgId :: MsgId,
    msgTs :: SystemTime
  }
  deriving (Show)

instance Encoding NMsgMeta where
  smpEncode NMsgMeta {msgId, msgTs} =
    smpEncode (msgId, msgTs)
  smpP = do
    -- Tail here is to allow extension in the future clients/servers
    (msgId, msgTs, Tail _) <- smpP
    pure NMsgMeta {msgId, msgTs}

-- it must be data for correct JSON encoding
data MsgFlags = MsgFlags {notification :: Bool}
  deriving (Eq, Show)

-- this encoding should not become bigger than 7 bytes (currently it is 1 byte)
instance Encoding MsgFlags where
  smpEncode MsgFlags {notification} = smpEncode notification
  smpP = do
    notification <- smpP <* A.takeTill (== ' ')
    pure MsgFlags {notification}

instance StrEncoding MsgFlags where
  strEncode = smpEncode
  {-# INLINE strEncode #-}
  strP = smpP
  {-# INLINE strP #-}

noMsgFlags :: MsgFlags
noMsgFlags = MsgFlags {notification = 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
  RSLV_ :: CommandTag Resolver

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_
  | ALLS_
  | NID_
  | NMSG_
  | PKEY_
  | RRES_
  | PRES_
  | END_
  | ENDS_
  | DELD_
  | INFO_
  | OK_
  | ERR_
  | PONG_
  | RNAME_
  deriving (Show)

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

messageTagP :: ProtocolMsgTag t => Parser t
messageTagP =
  maybe (fail "bad message") pure . decodeTag
    =<< (A.takeTill (== ' ') <* optional A.space)

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

instance ProtocolMsgTag CmdTag where
  decodeTag = \case
    "NEW" -> Just $ CT SCreator NEW_
    "SUB" -> Just $ CT SRecipient SUB_
    "SUBS" -> Just $ CT SRecipientService SUBS_
    "KEY" -> Just $ CT SRecipient KEY_
    "RKEY" -> Just $ CT SRecipient RKEY_
    "LSET" -> Just $ CT SRecipient LSET_
    "LDEL" -> Just $ CT SRecipient LDEL_
    "NKEY" -> Just $ CT SRecipient NKEY_
    "NDEL" -> Just $ CT SRecipient NDEL_
    "GET" -> Just $ CT SRecipient GET_
    "ACK" -> Just $ CT SRecipient ACK_
    "OFF" -> Just $ CT SRecipient OFF_
    "DEL" -> Just $ CT SRecipient DEL_
    "QUE" -> Just $ CT SRecipient QUE_
    "SKEY" -> Just $ CT SSender SKEY_
    "SEND" -> Just $ CT SSender SEND_
    "PING" -> Just $ CT SIdleClient PING_
    "LKEY" -> Just $ CT SSenderLink LKEY_
    "LGET" -> Just $ CT SSenderLink LGET_
    "PRXY" -> Just $ CT SProxiedClient PRXY_
    "PFWD" -> Just $ CT SProxiedClient PFWD_
    "RFWD" -> Just $ CT SProxyService RFWD_
    "NSUB" -> Just $ CT SNotifier NSUB_
    "NSUBS" -> Just $ CT SNotifierService NSUBS_
    "RSLV" -> Just $ CT SResolver RSLV_
    _ -> Nothing

instance Encoding CmdTag where
  smpEncode (CT _ t) = smpEncode t
  smpP = messageTagP

instance PartyI p => ProtocolMsgTag (CommandTag p) where
  decodeTag s = decodeTag s >>= (\(CT _ t) -> checkParty' t)

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

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

-- | SMP message body format
data ClientMsgEnvelope = ClientMsgEnvelope
  { cmHeader :: PubHeader,
    cmNonce :: C.CbNonce,
    cmEncBody :: ByteString
  }
  deriving (Show)

data PubHeader = PubHeader
  { phVersion :: VersionSMPC,
    phE2ePubDhKey :: Maybe C.PublicKeyX25519
  }
  deriving (Show)

instance Encoding PubHeader where
  smpEncode (PubHeader v k) = smpEncode (v, k)
  smpP = PubHeader <$> smpP <*> smpP

instance Encoding ClientMsgEnvelope where
  smpEncode ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody} =
    smpEncode (cmHeader, cmNonce, Tail cmEncBody)
  smpP = do
    (cmHeader, cmNonce, Tail cmEncBody) <- smpP
    pure ClientMsgEnvelope {cmHeader, cmNonce, cmEncBody}

data ClientMessage = ClientMessage PrivHeader ByteString

data PrivHeader
  = PHConfirmation C.APublicAuthKey
  | PHEmpty
  deriving (Show)

instance Encoding PrivHeader where
  smpEncode = \case
    PHConfirmation k -> "K" <> smpEncode k
    PHEmpty -> "_"
  smpP =
    A.anyChar >>= \case
      'K' -> PHConfirmation <$> smpP
      '_' -> pure PHEmpty
      _ -> fail "invalid PrivHeader"

instance Encoding ClientMessage where
  smpEncode (ClientMessage h msg) = smpEncode h <> msg
  smpP = ClientMessage <$> smpP <*> A.takeByteString

type SMPServer = ProtocolServer 'PSMP

pattern SMPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PSMP
pattern 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 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 XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash

{-# COMPLETE XFTPServer #-}

type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP

sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
{-# INLINE sameSrvAddr' #-}

sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool
sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p'
{-# INLINE sameSrvAddr #-}

data ProtocolType = PSMP | PNTF | PXFTP
  deriving (Eq, Ord, Show)

instance StrEncoding ProtocolType where
  strEncode = \case
    PSMP -> "smp"
    PNTF -> "ntf"
    PXFTP -> "xftp"
  strP =
    A.takeTill (\c -> c == ':' || c == ' ') >>= \case
      "smp" -> pure PSMP
      "ntf" -> pure PNTF
      "xftp" -> pure PXFTP
      _ -> fail "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 p == AProtocolType p' = isJust $ testEquality p p'

deriving instance Show AProtocolType

instance TestEquality SProtocolType where
  testEquality SPSMP SPSMP = Just Refl
  testEquality SPNTF SPNTF = Just Refl
  testEquality SPXFTP SPXFTP = Just Refl
  testEquality _ _ = Nothing

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

aProtocolType :: ProtocolType -> AProtocolType
aProtocolType = \case
  PSMP -> AProtocolType SPSMP
  PNTF -> AProtocolType SPNTF
  PXFTP -> AProtocolType SPXFTP

instance ProtocolTypeI p => StrEncoding (SProtocolType p) where
  strEncode = strEncode . protocolType
  strP = (\(AProtocolType p) -> checkProtocolType p) <$?> strP

instance StrEncoding AProtocolType where
  strEncode (AProtocolType p) = strEncode p
  strP = aProtocolType <$> strP

instance ProtocolTypeI p => ToJSON (SProtocolType p) where
  toEncoding = strToJEncoding
  toJSON = strToJSON

instance ProtocolTypeI p => FromJSON (SProtocolType p) where
  parseJSON = strParseJSON "SProtocolType"

instance ToJSON AProtocolType where
  toEncoding = strToJEncoding
  toJSON = strToJSON

instance FromJSON AProtocolType where
  parseJSON = strParseJSON "AProtocolType"

checkProtocolType :: forall t p p'. (ProtocolTypeI p, ProtocolTypeI p') => t p' -> Either String (t p)
checkProtocolType p = case testEquality (protocolTypeI @p) (protocolTypeI @p') of
  Just Refl -> Right p
  Nothing -> Left "bad ProtocolType"

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

instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP

instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF

instance ProtocolTypeI 'PXFTP where protocolTypeI = 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 = \case
  SPSMP -> Just Dict
  SPXFTP -> Just Dict
  _ -> Nothing

-- | server location and transport key digest (hash).
data ProtocolServer p = ProtocolServer
  { scheme :: SProtocolType p,
    host :: NonEmpty TransportHost,
    port :: ServiceName,
    keyHash :: C.KeyHash
  }
  deriving (Eq, Ord, Show)

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

instance ProtocolTypeI p => IsString (ProtocolServer p) where
  fromString = parseString strDecode

instance ProtocolTypeI p => Encoding (ProtocolServer p) where
  smpEncode ProtocolServer {host, port, keyHash} =
    smpEncode (host, port, keyHash)
  smpP = do
    (host, port, keyHash) <- smpP
    pure ProtocolServer {scheme = protocolTypeI @p, host, port, keyHash}

instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where
  strEncode ProtocolServer {scheme, host, port, keyHash} =
    strEncodeServer scheme (strEncode host) port keyHash Nothing
  strP =
    serverStrP >>= \case
      (AProtocolServer _ srv, Nothing) -> either fail pure $ checkProtocolType srv
      _ -> fail "ProtocolServer with basic auth not allowed"

instance ProtocolTypeI p => ToJSON (ProtocolServer p) where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance ProtocolTypeI p => FromJSON (ProtocolServer p) where
  parseJSON = strParseJSON "ProtocolServer"

newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString}
  deriving (Eq, Ord, Show)

instance IsString BasicAuth where fromString = BasicAuth . B.pack

instance Encoding BasicAuth where
  smpEncode (BasicAuth s) = smpEncode s
  smpP = basicAuth <$?> smpP

instance StrEncoding BasicAuth where
  strEncode (BasicAuth s) = s
  strP = basicAuth <$?> A.takeWhile1 (/= '@')

basicAuth :: ByteString -> Either String BasicAuth
basicAuth s
  | B.all valid s = Right $ BasicAuth s
  | otherwise = Left "invalid character in BasicAuth"
  where
    valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/'

data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer p, serverBasicAuth :: Maybe BasicAuth}
  deriving (Eq, Ord, Show)

instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where
  fromString = parseString 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 ProtocolServer {scheme, host, port, keyHash} auth_) =
    strEncodeServer scheme (strEncode host) port keyHash auth_
  strP = (\(AProtoServerWithAuth _ srv) -> checkProtocolType srv) <$?> strP

instance StrEncoding AProtoServerWithAuth where
  strEncode (AProtoServerWithAuth _ srv) = strEncode srv
  strP =
    serverStrP >>= \(AProtocolServer p srv, auth) ->
      pure $ AProtoServerWithAuth p (ProtoServerWithAuth srv auth)

instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where
  parseJSON = strParseJSON "ProtoServerWithAuth"

instance ToJSON AProtoServerWithAuth where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance FromJSON AProtoServerWithAuth where
  parseJSON = strParseJSON "AProtoServerWithAuth"

noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p
noAuthSrv srv = ProtoServerWithAuth srv Nothing

legacyEncodeServer :: ProtocolServer p -> ByteString
legacyEncodeServer ProtocolServer {host, port, keyHash} =
  smpEncode (L.head host, port, keyHash)

legacyServerP :: forall p. ProtocolTypeI p => Parser (ProtocolServer p)
legacyServerP = do
  (h, port, keyHash) <- smpP
  pure ProtocolServer {scheme = protocolTypeI @p, host = [h], port, keyHash}

legacyStrEncodeServer :: ProtocolTypeI p => ProtocolServer p -> ByteString
legacyStrEncodeServer ProtocolServer {scheme, host, port, keyHash} =
  strEncodeServer scheme (strEncode $ L.head host) port keyHash Nothing

strEncodeServer :: ProtocolTypeI p => SProtocolType p -> ByteString -> ServiceName -> C.KeyHash -> Maybe BasicAuth -> ByteString
strEncodeServer scheme host port keyHash auth_ =
  strEncode scheme <> "://" <> strEncode keyHash <> maybe "" ((":" <>) . strEncode) auth_ <> "@" <> host <> portStr
  where
    portStr = B.pack $ if null port then "" else ':' : port

serverStrP :: Parser (AProtocolServer, Maybe BasicAuth)
serverStrP = do
  scheme <- strP <* "://"
  keyHash <- strP
  auth_ <- optional $ A.char ':' *> strP
  TransportHosts host <- A.char '@' *> strP
  port <- portP <|> pure ""
  pure $ case scheme of
    AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash}, auth_)
  where
    portP = show <$> (A.char ':' *> (A.decimal :: Parser Int))

-- | Transmission correlation ID.
newtype CorrId = CorrId {bs :: ByteString}
  deriving (Eq, Ord, Show)
  deriving newtype (Encoding)

pattern NoCorrId :: CorrId
pattern NoCorrId = CorrId ""

instance IsString CorrId where
  fromString = CorrId . fromString
  {-# INLINE fromString #-}

instance StrEncoding CorrId where
  strEncode (CorrId cId) = strEncode cId
  strDecode s = CorrId <$> strDecode s
  strP = CorrId <$> strP

instance ToJSON CorrId where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance FromJSON CorrId where
  parseJSON = strParseJSON "CorrId"

-- | Queue IDs and keys
data QueueIdsKeys = QIK
  { rcvId :: RecipientId,
    sndId :: SenderId,
    rcvPublicDhKey :: RcvPublicDhKey,
    queueMode :: Maybe QueueMode, -- TODO remove Maybe when min version is 9 (sndAuthKeySMPVersion)
    linkId :: Maybe LinkId,
    serviceId :: Maybe ServiceId,
    serverNtfCreds :: Maybe ServerNtfCreds
  }
  deriving (Eq, Show)

data ServerNtfCreds = ServerNtfCreds NotifierId RcvNtfPublicDhKey
  deriving (Eq, Show)

instance Encoding ServerNtfCreds where
  smpEncode (ServerNtfCreds nId dhKey) = smpEncode (nId, dhKey)
  smpP = ServerNtfCreds <$> smpP <*> 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 ServiceSub = ServiceSub
  { smpServiceId :: ServiceId,
    smpQueueCount :: Int64,
    smpQueueIdsHash :: IdsHash
  }
  deriving (Eq, Show)

data ServiceSubResult = ServiceSubResult (Maybe ServiceSubError) ServiceSub
  deriving (Eq, Show)

data ServiceSubError
  = SSErrorServiceId {expectedServiceId :: ServiceId, subscribedServiceId :: ServiceId}
  | SSErrorQueueCount {expectedQueueCount :: Int64, subscribedQueueCount :: Int64}
  | SSErrorQueueIdsHash {expectedQueueIdsHash :: IdsHash, subscribedQueueIdsHash :: IdsHash}
  deriving (Eq, Show)

serviceSubResult :: ServiceSub -> ServiceSub -> ServiceSubResult
serviceSubResult s s' = ServiceSubResult subError_ s'
  where
    subError_
      | smpServiceId s /= smpServiceId s' = Just $ SSErrorServiceId (smpServiceId s) (smpServiceId s')
      | smpQueueCount s /= smpQueueCount s' = Just $ SSErrorQueueCount (smpQueueCount s) (smpQueueCount s')
      | smpQueueIdsHash s /= smpQueueIdsHash s' = Just $ SSErrorQueueIdsHash (smpQueueIdsHash s) (smpQueueIdsHash s')
      | otherwise = Nothing

newtype IdsHash = IdsHash {unIdsHash :: BS.ByteString}
  deriving (Eq, Show)
  deriving newtype (Encoding, FromField)

instance ToField IdsHash where
  toField (IdsHash s) = toField (Binary s)
  {-# INLINE toField #-}

instance Semigroup IdsHash where
  (IdsHash s1) <> (IdsHash s2) = IdsHash $! BS.pack $ BS.zipWith xor s1 s2

instance Monoid IdsHash where
  mempty = IdsHash $ BS.replicate 16 0
  mconcat ss =
    let !s' = BS.pack $ foldl' (\ !r (IdsHash s) -> zipWith xor' r (BS.unpack s)) (replicate 16 0) ss -- to prevent packing/unpacking in <> on each step with default mappend
     in IdsHash s'

xor' :: Word8 -> Word8 -> Word8
xor' x y = let !r = xor x y in r

queueIdsHash :: [QueueId] -> IdsHash
queueIdsHash = mconcat . map queueIdHash

queueIdHash :: QueueId -> IdsHash
queueIdHash = IdsHash . C.md5Hash . unEntityId
{-# INLINE queueIdHash #-}

addServiceSubs :: (Int64, IdsHash) -> (Int64, IdsHash) -> (Int64, IdsHash)
addServiceSubs (n', idsHash') (n, idsHash) = (n + n', idsHash <> idsHash')

subtractServiceSubs :: (Int64, IdsHash) -> (Int64, IdsHash) -> (Int64, IdsHash)
subtractServiceSubs (n', idsHash') (n, idsHash)
  | n > n' = (n - n', idsHash <> idsHash') -- concat is a reversible xor: (x `xor` y) `xor` y == x
  | otherwise = (0, mempty)

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 {cmdErr :: CommandError}
  | -- | error from proxied relay
    PROXY {proxyErr :: ProxyError}
  | -- | command authorization error - bad signature or non-existing SMP queue
    AUTH
  | -- | command with the entity that was blocked
    BLOCKED {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 {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
  | -- | name resolution error
    NAME {nameErr :: NameErrorType}
  | -- | used internally, never returned by the server (to be removed)
    DUPLICATE_ -- not part of SMP protocol, used internally
  deriving (Eq, Show)

-- | Name resolution error
data NameErrorType
  = -- | the names role / resolver is not configured on this server
    NO_RESOLVER
  | -- | the name is not registered (resolver returned not-found)
    NOT_FOUND
  | -- | backing resolver/RPC failure - contains the diagnostic detail
    RESOLVER {resolverErr :: Text}
  deriving (Eq, Show)

instance StrEncoding ErrorType where
  strEncode = \case
    BLOCK -> "BLOCK"
    SESSION -> "SESSION"
    CMD e -> "CMD " <> bshow e
    PROXY e -> "PROXY " <> strEncode e
    AUTH -> "AUTH"
    BLOCKED info -> "BLOCKED " <> strEncode info
    SERVICE -> "SERVICE"
    CRYPTO -> "CRYPTO"
    QUOTA -> "QUOTA"
    STORE e -> "STORE " <> encodeUtf8 e
    NO_MSG -> "NO_MSG"
    LARGE_MSG -> "LARGE_MSG"
    EXPIRED -> "EXPIRED"
    INTERNAL -> "INTERNAL"
    NAME e -> "NAME " <> strEncode e
    DUPLICATE_ -> "DUPLICATE_"
  strP =
    A.choice
      [ "BLOCK" $> BLOCK,
        "SESSION" $> SESSION,
        "CMD " *> (CMD <$> parseRead1),
        "PROXY " *> (PROXY <$> strP),
        "NAME " *> (NAME <$> strP),
        "AUTH" $> AUTH,
        "BLOCKED " *> strP,
        "SERVICE" $> SERVICE,
        "CRYPTO" $> CRYPTO,
        "QUOTA" $> QUOTA,
        "STORE " *> (STORE . safeDecodeUtf8 <$> A.takeByteString),
        "NO_MSG" $> NO_MSG,
        "LARGE_MSG" $> LARGE_MSG,
        "EXPIRED" $> EXPIRED,
        "INTERNAL" $> INTERNAL,
        "DUPLICATE_" $> 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 (Eq, Read, Show)

data ProxyError
  = -- | Correctly parsed SMP server ERR response.
    -- This error is forwarded to the agent client as AgentErrorType `ERR PROXY PROTOCOL err`.
    PROTOCOL {protocolErr :: ErrorType}
  | -- | destination server error
    BROKER {brokerErr :: BrokerErrorType}
  | -- | basic auth provided to proxy is invalid
    BASIC_AUTH
  | -- no destination server error
    NO_SESSION
  deriving (Eq, Show)

-- | SMP server errors.
data BrokerErrorType
  = -- | invalid server response (failed to parse)
    RESPONSE {respErr :: String}
  | -- | unexpected response
    UNEXPECTED {respErr :: String}
  | -- | network error
    NETWORK {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 {transportErr :: TransportError}
  | -- | command response timeout
    TIMEOUT
  deriving (Eq, Read, Show, Exception)

data NetworkError
  = NEConnectError {connectError :: String}
  | NETLSError {tlsError :: String}
  | NEUnknownCAError
  | NEFailedError
  | NETimeoutError
  | NESubscribeError {subscribeError :: String}
  deriving (Eq, Read, Show)

toNetworkError :: SomeException -> NetworkError
toNetworkError e = maybe (NEConnectError err) fromTLSError (fromException e)
  where
    err = displayException e
    fromTLSError :: TLS.TLSException -> NetworkError
    fromTLSError = \case
      TLS.HandshakeFailed (TLS.Error_Protocol _ TLS.UnknownCa) -> NEUnknownCAError
      _ -> NETLSError err

data BlockingInfo = BlockingInfo
  { reason :: BlockingReason,
    notice :: Maybe ClientNotice
  }
  deriving (Eq, Show)

data BlockingReason = BRSpam | BRContent
  deriving (Eq, Show)

instance StrEncoding BlockingInfo where
  strEncode BlockingInfo {reason, notice} =
    "reason=" <> strEncode reason <> maybe "" ((",notice=" <>) . LB.toStrict . J.encode) notice
  strP = do
    reason <- "reason=" *> strP
    notice <- optional $ ",notice=" *> (J.eitherDecodeStrict <$?> A.takeByteString)
    pure BlockingInfo {reason, notice}

instance Encoding BlockingInfo where
  smpEncode = strEncode
  smpP = strP

instance StrEncoding BlockingReason where
  strEncode = \case
    BRSpam -> "spam"
    BRContent -> "content"
  strP = "spam" $> BRSpam <|> "content" $> BRContent

instance ToJSON BlockingReason where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance FromJSON BlockingReason where
  parseJSON = strParseJSON "BlockingReason"

-- | SMP transmission parser.
transmissionP :: THandleParams v p -> Parser RawTransmission
transmissionP THandleParams {sessionId, implySessId, serviceAuth} = do
  authenticator <- smpP
  serviceSig <- if serviceAuth && not (B.null authenticator) then smpP else pure Nothing
  authorized <- A.takeByteString
  either fail pure $ parseAll (trn authenticator serviceSig authorized) authorized
  where
    trn authenticator serviceSig authorized = do
      sessId <- if implySessId then pure "" else smpP
      let authorized' = if implySessId then smpEncode sessionId <> authorized else authorized
      corrId <- smpP
      entityId <- smpP
      command <- A.takeByteString
      pure RawTransmission {authenticator, serviceSig, authorized = authorized', sessId, corrId, entityId, 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 = smpClientHandshake
  {-# INLINE protocolClientHandshake #-}
  useServiceAuth = \case
    Cmd _ (NEW _) -> True
    Cmd _ SUB -> True
    Cmd _ NSUB -> True
    _ -> False
  {-# INLINE useServiceAuth #-}
  protocolPing = Cmd SIdleClient PING
  {-# INLINE protocolPing #-}
  protocolError = \case
    ERR e -> Just e
    _ -> 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 v = \case
    NEW NewQueueReq {rcvAuthKey = rKey, rcvDhKey = dhKey, auth_, subMode, queueReqData, ntfCreds}
      | v >= newNtfCredsSMPVersion -> new <> e (auth_, subMode, queueReqData, ntfCreds)
      | v >= shortLinksSMPVersion -> new <> e (auth_, subMode, queueReqData)
      | v >= sndAuthKeySMPVersion -> new <> e (auth_, subMode, senderCanSecure (queueReqMode <$> queueReqData))
      | otherwise -> new <> auth <> e subMode
      where
        new = e (NEW_, ' ', rKey, dhKey)
        auth = maybe "" (e . ('A',)) auth_
    SUB -> e SUB_
    SUBS n idsHash
      | v >= rcvServiceSMPVersion -> e (SUBS_, ' ', n, idsHash)
      | otherwise -> e SUBS_
    KEY k -> e (KEY_, ' ', k)
    RKEY ks -> e (RKEY_, ' ', ks)
    LSET lnkId d -> e (LSET_, ' ', lnkId, d)
    LDEL -> e LDEL_
    NKEY k dhKey -> e (NKEY_, ' ', k, dhKey)
    NDEL -> e NDEL_
    GET -> e GET_
    ACK msgId -> e (ACK_, ' ', msgId)
    OFF -> e OFF_
    DEL -> e DEL_
    QUE -> e QUE_
    SKEY k -> e (SKEY_, ' ', k)
    SEND flags msg -> e (SEND_, ' ', flags, ' ', Tail msg)
    PING -> e PING_
    NSUB -> e NSUB_
    NSUBS n idsHash
      | v >= rcvServiceSMPVersion -> e (NSUBS_, ' ', n, idsHash)
      | otherwise -> e NSUBS_
    LKEY k -> e (LKEY_, ' ', k)
    LGET -> e LGET_
    PRXY host auth_ -> e (PRXY_, ' ', host, auth_)
    PFWD fwdV pubKey (EncTransmission s) -> e (PFWD_, ' ', fwdV, pubKey, Tail s)
    RFWD (EncFwdTransmission s) -> e (RFWD_, ' ', Tail s)
    RSLV d -> e (RSLV_, ' ', d)
    where
      e :: Encoding a => a -> ByteString
      e = smpEncode

  protocolP v tag = (\(Cmd _ c) -> checkParty c) <$?> protocolP v (CT (sParty @p) tag)

  fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
  {-# INLINE fromProtocolError #-}

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

instance ProtocolEncoding SMPVersion ErrorType Cmd where
  type Tag Cmd = CmdTag
  encodeProtocol v (Cmd _ c) = encodeProtocol v c
  {-# INLINE encodeProtocol #-}

  protocolP v = \case
    CT SCreator NEW_ -> Cmd SCreator <$> newCmd
      where
        newCmd
          | v >= newNtfCredsSMPVersion = new smpP smpP smpP
          | v >= shortLinksSMPVersion = new smpP smpP nothing
          | v >= sndAuthKeySMPVersion = new smpP (qReq <$> smpP) nothing
          | otherwise = new auth nothing nothing
          where
            nothing = pure Nothing
            new p1 p2 p3 = NEW <$> do
              rcvAuthKey <- _smpP
              rcvDhKey <- smpP
              auth_ <- p1
              subMode <- smpP
              queueReqData <- p2
              ntfCreds <- p3
              pure NewQueueReq {rcvAuthKey, rcvDhKey, auth_, subMode, queueReqData, ntfCreds}
            auth = optional (A.char 'A' *> smpP)
            qReq sndSecure = Just $ if sndSecure then QRMessaging Nothing else QRContact Nothing
    CT SRecipient tag ->
      Cmd SRecipient <$> case tag of
        SUB_ -> pure SUB
        KEY_ -> KEY <$> _smpP
        RKEY_ -> RKEY <$> _smpP
        LSET_ -> LSET <$> _smpP <*> smpP
        LDEL_ -> pure LDEL
        NKEY_ -> NKEY <$> _smpP <*> smpP
        NDEL_ -> pure NDEL
        GET_ -> pure GET
        ACK_ -> ACK <$> _smpP
        OFF_ -> pure OFF
        DEL_ -> pure DEL
        QUE_ -> pure QUE
    CT SRecipientService SUBS_
      | v >= rcvServiceSMPVersion -> Cmd SRecipientService <$> (SUBS <$> _smpP <*> smpP)
      | otherwise -> pure $ Cmd SRecipientService $ SUBS (-1) mempty
    CT SSender tag ->
      Cmd SSender <$> case tag of
        SKEY_ -> SKEY <$> _smpP
        SEND_ -> SEND <$> _smpP <*> (unTail <$> _smpP)
    CT SIdleClient PING_ -> pure $ Cmd SIdleClient PING
    CT SProxyService RFWD_ ->
      Cmd SProxyService . RFWD . EncFwdTransmission . unTail <$> _smpP
    CT SSenderLink tag ->
      Cmd SSenderLink <$> case tag of
        LKEY_ -> LKEY <$> _smpP
        LGET_ -> pure LGET
    CT SProxiedClient tag ->
      Cmd SProxiedClient <$> case tag of
        PFWD_ -> PFWD <$> _smpP <*> smpP <*> (EncTransmission . unTail <$> smpP)
        PRXY_ -> PRXY <$> _smpP <*> smpP
    CT SNotifier NSUB_ -> pure $ Cmd SNotifier NSUB
    CT SNotifierService NSUBS_
      | v >= rcvServiceSMPVersion -> Cmd SNotifierService <$> (NSUBS <$> _smpP <*> smpP)
      | otherwise -> pure $ Cmd SNotifierService $ NSUBS (-1) mempty
    CT SResolver RSLV_ -> Cmd SResolver . RSLV <$> _smpP <* A.takeByteString

  fromProtocolError = fromProtocolError @SMPVersion @ErrorType @BrokerMsg
  {-# INLINE fromProtocolError #-}

  checkCredentials tAuth entId (Cmd p c) = Cmd p <$> checkCredentials tAuth entId c
  {-# INLINE checkCredentials #-}

instance ProtocolEncoding SMPVersion ErrorType BrokerMsg where
  type Tag BrokerMsg = BrokerMsgTag
  encodeProtocol v = \case
    IDS QIK {rcvId, sndId, rcvPublicDhKey = srvDh, queueMode, linkId, serviceId, serverNtfCreds}
      | v >= newNtfCredsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId <> e serverNtfCreds
      | v >= serviceCertsSMPVersion -> ids <> e queueMode <> e linkId <> e serviceId
      | v >= shortLinksSMPVersion -> ids <> e queueMode <> e linkId
      | v >= sndAuthKeySMPVersion -> ids <> e (senderCanSecure queueMode)
      | otherwise -> ids
      where
        ids = e (IDS_, ' ', rcvId, sndId, srvDh)
    LNK sId d -> e (LNK_, ' ', sId, d)
    SOK serviceId_
      | v >= serviceCertsSMPVersion -> e (SOK_, ' ', serviceId_)
      | otherwise -> e OK_ -- won't happen, the association with the service requires v >= serviceCertsSMPVersion
    SOKS n idsHash -> serviceResp SOKS_ n idsHash
    MSG RcvMessage {msgId, msgBody = EncRcvMsgBody body} ->
      e (MSG_, ' ', msgId, Tail body)
    ALLS -> e ALLS_
    NID nId srvNtfDh -> e (NID_, ' ', nId, srvNtfDh)
    NMSG nmsgNonce encNMsgMeta -> e (NMSG_, ' ', nmsgNonce, encNMsgMeta)
    PKEY sid vr certKey -> e (PKEY_, ' ', sid, vr, certKey)
    RRES (EncFwdResponse encBlock) -> e (RRES_, ' ', Tail encBlock)
    PRES (EncResponse encBlock) -> e (PRES_, ' ', Tail encBlock)
    END -> e END_
    ENDS n idsHash -> serviceResp ENDS_ n idsHash
    DELD
      | v >= deletedEventSMPVersion -> e DELD_
      | otherwise -> e END_
    INFO info -> e (INFO_, ' ', info)
    OK -> e OK_
    ERR err -> e (ERR_, ' ', err')
      where
        err' = case err of
          BLOCKED info
            | v < blockedEntitySMPVersion -> AUTH
            | v < clientNoticesSMPVersion -> BLOCKED info {notice = Nothing}
          _ -> err
    PONG -> e PONG_
    RNAME rec -> e (RNAME_, ' ', Tail $ LB.toStrict $ J.encode rec)
    where
      e :: Encoding a => a -> ByteString
      e = smpEncode
      serviceResp tag n idsHash
        | v >= rcvServiceSMPVersion = e (tag, ' ', n, idsHash)
        | otherwise = e (tag, ' ', n)

  protocolP v = \case
    MSG_ -> do
      msgId <- _smpP
      MSG . RcvMessage msgId <$> bodyP
      where
        bodyP = EncRcvMsgBody . unTail <$> smpP
    ALLS_ -> pure ALLS
    IDS_
      | v >= newNtfCredsSMPVersion -> ids smpP smpP smpP smpP
      | v >= serviceCertsSMPVersion -> ids smpP smpP smpP nothing
      | v >= shortLinksSMPVersion -> ids smpP smpP nothing nothing
      | v >= sndAuthKeySMPVersion -> ids (qm <$> smpP) nothing nothing nothing
      | otherwise -> ids nothing nothing nothing nothing
      where
        qm sndSecure = Just $ if sndSecure then QMMessaging else QMContact
        nothing = pure Nothing
        ids p1 p2 p3 p4 = do
          rcvId <- _smpP
          sndId <- smpP
          rcvPublicDhKey <- smpP
          queueMode <- p1
          linkId <- p2
          serviceId <- p3
          serverNtfCreds <- p4
          pure $ IDS QIK {rcvId, sndId, rcvPublicDhKey, queueMode, linkId, serviceId, serverNtfCreds}
    LNK_ -> LNK <$> _smpP <*> smpP
    SOK_ -> SOK <$> _smpP
    SOKS_ -> serviceRespP SOKS
    NID_ -> NID <$> _smpP <*> smpP
    NMSG_ -> NMSG <$> _smpP <*> smpP
    PKEY_ -> PKEY <$> _smpP <*> smpP <*> smpP
    RRES_ -> RRES <$> (EncFwdResponse . unTail <$> _smpP)
    PRES_ -> PRES <$> (EncResponse . unTail <$> _smpP)
    END_ -> pure END
    ENDS_ -> serviceRespP ENDS
    DELD_ -> pure DELD
    INFO_ -> INFO <$> _smpP
    OK_ -> pure OK
    ERR_ -> ERR <$> _smpP
    PONG_ -> pure PONG
    RNAME_ -> fmap RNAME . J.eitherDecodeStrict . unTail <$?> _smpP
    where
      serviceRespP resp
        | v >= rcvServiceSMPVersion = resp <$> _smpP <*> smpP
        | otherwise = resp <$> _smpP <*> pure mempty

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

  checkCredentials _ (EntityId entId) cmd = case cmd of
    -- IDS response should not have queue ID
    IDS _ -> Right cmd
    -- ERR response does not always have queue ID
    ERR _ -> Right cmd
    -- PONG response must not have queue ID
    PONG -> noEntityMsg
    PKEY {} -> noEntityMsg
    RRES _ -> noEntityMsg
    ALLS -> noEntityMsg
    RNAME _ -> noEntityMsg
    -- other broker responses must have queue ID
    _
      | B.null entId -> Left $ CMD NO_ENTITY
      | otherwise -> Right cmd
    where
      noEntityMsg :: Either ErrorType BrokerMsg
      noEntityMsg
        | B.null entId = Right cmd
        | otherwise = Left $ CMD 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 v s =
  let (tag, params) = B.break (== ' ') s
   in case decodeTag tag of
        Just cmd -> parse (protocolP v cmd) (fromProtocolError @v @err @msg $ PECmdSyntax) params
        Nothing -> Left $ fromProtocolError @v @err @msg $ PECmdUnknown

checkParty :: forall t p p'. (PartyI p, PartyI p') => t p' -> Either String (t p)
checkParty c = case testEquality (sParty @p) (sParty @p') of
  Just Refl -> Right c
  Nothing -> Left "bad command party"

checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)
checkParty' = eitherToMaybe . checkParty

instance Encoding ErrorType where
  smpEncode = \case
    BLOCK -> "BLOCK"
    SESSION -> "SESSION"
    CMD err -> "CMD " <> smpEncode err
    PROXY err -> "PROXY " <> smpEncode err
    AUTH -> "AUTH"
    BLOCKED info -> "BLOCKED " <> smpEncode info
    SERVICE -> "SERVICE"
    CRYPTO -> "CRYPTO"
    QUOTA -> "QUOTA"
    STORE err -> "STORE " <> encodeUtf8 err
    EXPIRED -> "EXPIRED"
    NO_MSG -> "NO_MSG"
    LARGE_MSG -> "LARGE_MSG"
    INTERNAL -> "INTERNAL"
    NAME err -> "NAME " <> smpEncode err
    DUPLICATE_ -> "DUPLICATE_"

  smpP =
    A.takeTill (== ' ') >>= \case
      "BLOCK" -> pure BLOCK
      "SESSION" -> pure SESSION
      "CMD" -> CMD <$> _smpP
      "PROXY" -> PROXY <$> _smpP
      "AUTH" -> pure AUTH
      "BLOCKED" -> BLOCKED <$> _smpP
      "SERVICE" -> pure SERVICE
      "CRYPTO" -> pure CRYPTO
      "QUOTA" -> pure QUOTA
      "STORE" -> STORE . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
      "EXPIRED" -> pure EXPIRED
      "NO_MSG" -> pure NO_MSG
      "LARGE_MSG" -> pure LARGE_MSG
      "INTERNAL" -> pure INTERNAL
      "NAME" -> NAME <$> _smpP
      "DUPLICATE_" -> pure DUPLICATE_
      _ -> fail "bad ErrorType"

instance Encoding NameErrorType where
  smpEncode = \case
    NO_RESOLVER -> "NO_RESOLVER"
    NOT_FOUND -> "NOT_FOUND"
    RESOLVER e -> "RESOLVER " <> encodeUtf8 e
  smpP =
    A.takeTill (== ' ') >>= \case
      "NO_RESOLVER" -> pure NO_RESOLVER
      "NOT_FOUND" -> pure NOT_FOUND
      "RESOLVER" -> RESOLVER . safeDecodeUtf8 <$> (A.space *> A.takeByteString)
      _ -> fail "bad NameErrorType"

instance StrEncoding NameErrorType where
  strEncode = smpEncode
  strP = smpP

instance Encoding CommandError where
  smpEncode e = case e of
    UNKNOWN -> "UNKNOWN"
    SYNTAX -> "SYNTAX"
    PROHIBITED -> "PROHIBITED"
    NO_AUTH -> "NO_AUTH"
    HAS_AUTH -> "HAS_AUTH"
    NO_ENTITY -> "NO_ENTITY"
  smpP =
    A.takeTill (== ' ') >>= \case
      "UNKNOWN" -> pure UNKNOWN
      "SYNTAX" -> pure SYNTAX
      "PROHIBITED" -> pure PROHIBITED
      "NO_AUTH" -> pure NO_AUTH
      "HAS_AUTH" -> pure HAS_AUTH
      "NO_ENTITY" -> pure NO_ENTITY
      "NO_QUEUE" -> pure NO_ENTITY -- for backward compatibility
      _ -> fail "bad CommandError"

instance Encoding ProxyError where
  smpEncode = \case
    PROTOCOL e -> "PROTOCOL " <> smpEncode e
    BROKER e -> "BROKER " <> smpEncode e
    BASIC_AUTH -> "BASIC_AUTH"
    NO_SESSION -> "NO_SESSION"
  smpP =
    A.takeTill (== ' ') >>= \case
      "PROTOCOL" -> PROTOCOL <$> _smpP
      "BROKER" -> BROKER <$> _smpP
      "BASIC_AUTH" -> pure BASIC_AUTH
      "NO_SESSION" -> pure NO_SESSION
      _ -> fail "bad ProxyError"

instance StrEncoding ProxyError where
  strEncode = \case
    PROTOCOL e -> "PROTOCOL " <> strEncode e
    BROKER e -> "BROKER " <> strEncode e
    BASIC_AUTH -> "BASIC_AUTH"
    NO_SESSION -> "NO_SESSION"
  strP =
    A.takeTill (== ' ') >>= \case
      "PROTOCOL" -> PROTOCOL <$> _strP
      "BROKER" -> BROKER <$> _strP
      "BASIC_AUTH" -> pure BASIC_AUTH
      "NO_SESSION" -> pure NO_SESSION
      _ -> fail "bad ProxyError"

instance Encoding BrokerErrorType where
  smpEncode = \case
    RESPONSE e -> "RESPONSE " <> smpEncode e
    UNEXPECTED e -> "UNEXPECTED " <> smpEncode e
    TRANSPORT e -> "TRANSPORT " <> smpEncode e
    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> smpEncode e
    TIMEOUT -> "TIMEOUT"
    HOST -> "HOST"
    NO_SERVICE -> "NO_SERVICE"
  smpP =
    A.takeTill (== ' ') >>= \case
      "RESPONSE" -> RESPONSE <$> _smpP
      "UNEXPECTED" -> UNEXPECTED <$> _smpP
      "TRANSPORT" -> TRANSPORT <$> _smpP
      "NETWORK" -> NETWORK <$> (_smpP <|> pure NEFailedError)
      "TIMEOUT" -> pure TIMEOUT
      "HOST" -> pure HOST
      "NO_SERVICE" -> pure NO_SERVICE
      _ -> fail "bad BrokerErrorType"

instance StrEncoding BrokerErrorType where
  strEncode = \case
    RESPONSE e -> "RESPONSE " <> encodeUtf8 (T.pack e)
    UNEXPECTED e -> "UNEXPECTED " <> encodeUtf8 (T.pack e)
    TRANSPORT e -> "TRANSPORT " <> smpEncode e
    NETWORK _e -> "NETWORK" -- TODO once all upgrade: "NETWORK " <> strEncode e
    TIMEOUT -> "TIMEOUT"
    HOST -> "HOST"
    NO_SERVICE -> "NO_SERVICE"
  strP =
    A.takeTill (== ' ') >>= \case
      "RESPONSE" -> RESPONSE <$> _textP
      "UNEXPECTED" -> UNEXPECTED <$> _textP
      "TRANSPORT" -> TRANSPORT <$> _smpP
      "NETWORK" -> NETWORK <$> (_strP <|> pure NEFailedError)
      "TIMEOUT" -> pure TIMEOUT
      "HOST" -> pure HOST
      "NO_SERVICE" -> pure NO_SERVICE
      _ -> fail "bad BrokerErrorType"

instance Encoding NetworkError where
  smpEncode = \case
    NEConnectError e -> "CONNECT " <> smpEncode e
    NETLSError e -> "TLS " <> smpEncode e
    NEUnknownCAError -> "UNKNOWNCA"
    NEFailedError -> "FAILED"
    NETimeoutError -> "TIMEOUT"
    NESubscribeError e -> "SUBSCRIBE " <> smpEncode e
  smpP =
    A.takeTill (== ' ') >>= \case
      "CONNECT" -> NEConnectError <$> _smpP
      "TLS" -> NETLSError <$> _smpP
      "UNKNOWNCA" -> pure NEUnknownCAError
      "FAILED" -> pure NEFailedError
      "TIMEOUT" -> pure NETimeoutError
      "SUBSCRIBE" -> NESubscribeError <$> _smpP
      _ -> fail "bad NetworkError"

instance StrEncoding NetworkError where
  strEncode = \case
    NEConnectError e -> "CONNECT " <> encodeUtf8 (T.pack e)
    NETLSError e -> "TLS " <> encodeUtf8 (T.pack e)
    NEUnknownCAError -> "UNKNOWNCA"
    NEFailedError -> "FAILED"
    NETimeoutError -> "TIMEOUT"
    NESubscribeError e -> "SUBSCRIBE " <> encodeUtf8 (T.pack e)
  strP =
    A.takeTill (== ' ') >>= \case
      "CONNECT" -> NEConnectError <$> _textP
      "TLS" -> NETLSError <$> _textP
      "UNKNOWNCA" -> pure NEUnknownCAError
      "FAILED" -> pure NEFailedError
      "TIMEOUT" -> pure NETimeoutError
      "SUBSCRIBE" -> NESubscribeError <$> _textP
      _ -> fail "bad NetworkError"

_textP :: Parser String
_textP = A.space *> (T.unpack . safeDecodeUtf8 <$> A.takeByteString)

-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle v c p -> NonEmpty (Either TransportError SentRawTransmission) -> IO [Either TransportError ()]
tPut th@THandle {params} = fmap concat . mapM tPutBatch . batchTransmissions params
  where
    tPutBatch :: TransportBatch () -> IO [Either TransportError ()]
    tPutBatch = \case
      TBError e _ -> [Left e] <$ putStrLn "tPut error: large message"
      TBTransmissions s n _ -> replicate n <$> tPutLog th s
      TBTransmission s _ -> (: []) <$> tPutLog th s

tPutLog :: Transport c => THandle v c p -> ByteString -> IO (Either TransportError ())
tPutLog th s = do
  r <- tPutBlock th s
  case r of
    Left e -> putStrLn ("tPut error: " <> show e)
    _ -> pure ()
  pure 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 params = batchTransmissions' params . L.map (,())

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

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

tEncode :: Bool -> SentRawTransmission -> ByteString
tEncode serviceAuth (auth, t) = tEncodeAuth serviceAuth auth <> t
{-# INLINE tEncode #-}

tEncodeForBatch :: Bool -> SentRawTransmission -> ByteString
tEncodeForBatch serviceAuth = smpEncode . Large . tEncode serviceAuth
{-# INLINE tEncodeForBatch #-}

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

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

encodeTransmissionForAuth :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> TransmissionForAuth
encodeTransmissionForAuth THandleParams {thVersion = v, sessionId, implySessId} t =
  TransmissionForAuth {tForAuth, tToSend = if implySessId then t' else tForAuth}
  where
    tForAuth = smpEncode sessionId <> t'
    t' = encodeTransmission_ v t
{-# INLINE encodeTransmissionForAuth #-}

encodeTransmission :: ProtocolEncoding v e c => THandleParams v p -> Transmission c -> ByteString
encodeTransmission THandleParams {thVersion = v, sessionId, implySessId} t =
  if implySessId then t' else smpEncode sessionId <> t'
  where
    t' = encodeTransmission_ v t
{-# INLINE encodeTransmission #-}

encodeTransmission_ :: ProtocolEncoding v e c => Version v -> Transmission c -> ByteString
encodeTransmission_ v (CorrId corrId, queueId, command) =
  smpEncode (corrId, queueId) <> encodeProtocol v 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 th@THandle {params} = eitherList (tParse params) <$> tGetBlock th
{-# INLINE tGetParse #-}

tParse :: THandleParams v p -> ByteString -> NonEmpty (Either TransportError RawTransmission)
tParse thParams@THandleParams {batch} s
  | batch = eitherList (L.map (\(Large t) -> tParse1 t)) ts
  | otherwise = [tParse1 s]
  where
    tParse1 = parse (transmissionP thParams) TEBadBlock
    ts = parse smpP TEBadBlock s

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

-- | Receive server transmissions
tGetServer :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TServer -> IO (NonEmpty (SignedTransmissionOrError err cmd))
tGetServer = tGet tDecodeServer
{-# INLINE tGetServer #-}

-- | Receive client transmissions
tGetClient :: (ProtocolEncoding v err cmd, Transport c) => THandle v c 'TClient -> IO (NonEmpty (Transmission (Either err cmd)))
tGetClient = tGet tDecodeClient
{-# INLINE tGetClient #-}

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

tDecodeServer :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TServer -> Either TransportError RawTransmission -> SignedTransmissionOrError err cmd
tDecodeServer THandleParams {sessionId, thVersion = v, implySessId} = \case
  Right RawTransmission {authenticator, serviceSig, authorized, sessId, corrId, entityId, command}
    | implySessId || sessId == sessionId -> case decodeTAuthBytes authenticator serviceSig of
        Right tAuth -> bimap t ((tAuth,authorized,) . t) cmdOrErr
          where
            cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials tAuth entityId
            t :: a -> (CorrId, EntityId, a)
            t = (corrId,entityId,)
        Left _ -> tError corrId PEBlock
    | otherwise -> tError corrId PESession
  Left _ -> tError "" PEBlock
  where
    tError :: CorrId -> ProtocolErrorType -> SignedTransmissionOrError err cmd
    tError corrId err = Left (corrId, NoEntity, fromProtocolError @v @err @cmd err)

tDecodeClient :: forall v err cmd. ProtocolEncoding v err cmd => THandleParams v 'TClient -> Either TransportError RawTransmission -> Transmission (Either err cmd)
tDecodeClient THandleParams {sessionId, thVersion = v, implySessId} = \case
  Right RawTransmission {sessId, corrId, entityId, command}
    | implySessId || sessId == sessionId -> (corrId, entityId, cmdOrErr)
    | otherwise -> tError corrId PESession
    where
      cmdOrErr = parseProtocol @v @err @cmd v command >>= checkCredentials Nothing entityId
  Left _ -> tError "" PEBlock
  where
    tError :: CorrId -> ProtocolErrorType -> Transmission (Either err cmd)
    tError corrId err = (corrId, NoEntity, Left $ fromProtocolError @v @err @cmd err)

$(J.deriveJSON defaultJSON ''MsgFlags)

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

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

instance FromJSON NetworkError where
  parseJSON = $(J.mkParseJSON (sumTypeJSON $ dropPrefix "NE") ''NetworkError)
  omittedField = Just 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, ''NameErrorType, ''ErrorType])