{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

-- |
-- Module      : Simplex.Messaging.Protocol
-- 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 types
    Command (..),
    Party (..),
    Cmd (..),
    SParty (..),
    ErrorType (..),
    CommandError (..),
    Transmission,
    SignedTransmission,
    SignedTransmissionOrError,
    RawTransmission,
    SignedRawTransmission,
    CorrId (..),
    QueueId,
    RecipientId,
    SenderId,
    RecipientPrivateKey,
    RecipientPublicKey,
    SenderPrivateKey,
    SenderPublicKey,
    Encoded,
    MsgId,
    MsgBody,

    -- * Parse and serialize
    serializeTransmission,
    serializeCommand,
    serializeErrorType,
    transmissionP,
    commandP,
    errorTypeP,

    -- * TCP transport functions
    tPut,
    tGet,
    fromClient,
    fromServer,
  )
where

import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Except
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.Kind
import Data.String
import Data.Time.Clock
import Data.Time.ISO8601
import GHC.Generics (Generic)
import Generic.Random (genericArbitraryU)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Parsers
import Simplex.Messaging.Transport (THandle, Transport, TransportError (..), tGetEncrypted, tPutEncrypted)
import Simplex.Messaging.Util
import Test.QuickCheck (Arbitrary (..))

-- | SMP protocol participants.
data Party = Broker | Recipient | Sender
  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
showList :: [Party] -> ShowS
$cshowList :: [Party] -> ShowS
show :: Party -> String
$cshow :: Party -> String
showsPrec :: Int -> Party -> ShowS
$cshowsPrec :: Int -> Party -> ShowS
Show)

-- | Singleton types for SMP protocol participants.
data SParty :: Party -> Type where
  SBroker :: SParty Broker
  SRecipient :: SParty Recipient
  SSender :: SParty Sender

deriving instance Show (SParty a)

-- | Type for command or response of any participant.
data Cmd = forall a. Cmd (SParty a) (Command a)

deriving instance Show Cmd

-- | SMP transmission without signature.
type Transmission = (CorrId, QueueId, Cmd)

-- | SMP transmission with signature.
type SignedTransmission = (C.Signature, Transmission)

type TransmissionOrError = (CorrId, QueueId, Either ErrorType Cmd)

-- | signed parsed transmission, with parsing error.
type SignedTransmissionOrError = (C.Signature, TransmissionOrError)

-- | unparsed SMP transmission with signature.
type RawTransmission = (ByteString, ByteString, ByteString, ByteString)

-- | unparsed SMP transmission with signature.
type SignedRawTransmission = (C.Signature, ByteString)

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

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

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

-- | Parameterized type for SMP protocol commands from all participants.
data Command (a :: Party) where
  -- SMP recipient commands
  NEW :: RecipientPublicKey -> Command Recipient
  SUB :: Command Recipient
  KEY :: SenderPublicKey -> Command Recipient
  ACK :: Command Recipient
  OFF :: Command Recipient
  DEL :: Command Recipient
  -- SMP sender commands
  SEND :: MsgBody -> Command Sender
  PING :: Command Sender
  -- SMP broker commands (responses, messages, notifications)
  IDS :: RecipientId -> SenderId -> Command Broker
  MSG :: MsgId -> UTCTime -> MsgBody -> Command Broker
  END :: Command Broker
  OK :: Command Broker
  ERR :: ErrorType -> Command Broker
  PONG :: Command Broker

deriving instance Show (Command a)

deriving instance Eq (Command a)

-- | Base-64 encoded string.
type Encoded = ByteString

-- | Transmission correlation ID.
--
-- A newtype to avoid accidentally changing order of transmission parts.
newtype CorrId = CorrId {CorrId -> ByteString
bs :: ByteString} deriving (CorrId -> CorrId -> Bool
(CorrId -> CorrId -> Bool)
-> (CorrId -> CorrId -> Bool) -> Eq CorrId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CorrId -> CorrId -> Bool
$c/= :: CorrId -> CorrId -> Bool
== :: CorrId -> CorrId -> Bool
$c== :: 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
min :: CorrId -> CorrId -> CorrId
$cmin :: CorrId -> CorrId -> CorrId
max :: CorrId -> CorrId -> CorrId
$cmax :: CorrId -> CorrId -> CorrId
>= :: CorrId -> CorrId -> Bool
$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
compare :: CorrId -> CorrId -> Ordering
$ccompare :: CorrId -> CorrId -> Ordering
$cp1Ord :: Eq 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
showList :: [CorrId] -> ShowS
$cshowList :: [CorrId] -> ShowS
show :: CorrId -> String
$cshow :: CorrId -> String
showsPrec :: Int -> CorrId -> ShowS
$cshowsPrec :: Int -> CorrId -> ShowS
Show)

instance IsString CorrId where
  fromString :: String -> CorrId
fromString = ByteString -> CorrId
CorrId (ByteString -> CorrId)
-> (String -> ByteString) -> String -> CorrId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. IsString a => String -> a
fromString

-- | Recipient's private key used by the recipient to authorize (sign) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type RecipientPrivateKey = C.SafePrivateKey

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

-- | Sender's private key used by the recipient to authorize (sign) SMP commands.
--
-- Only used by SMP agent, kept here so its definition is close to respective public key.
type SenderPrivateKey = C.SafePrivateKey

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

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

-- | SMP message body.
type MsgBody = ByteString

-- | Type for protocol errors.
data ErrorType
  = -- | incorrect block format, encoding or signature size
    BLOCK
  | -- | SMP command is unknown or has invalid syntax
    CMD CommandError
  | -- | command authorization error - bad signature or non-existing SMP queue
    AUTH
  | -- | SMP queue capacity is exceeded on the server
    QUOTA
  | -- | ACK command is sent without message to be acknowledged
    NO_MSG
  | -- | internal server error
    INTERNAL
  | -- | used internally, never returned by the server (to be removed)
    DUPLICATE_ -- TODO remove, not part of SMP protocol
  deriving (ErrorType -> ErrorType -> Bool
(ErrorType -> ErrorType -> Bool)
-> (ErrorType -> ErrorType -> Bool) -> Eq ErrorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorType -> ErrorType -> Bool
$c/= :: ErrorType -> ErrorType -> Bool
== :: ErrorType -> ErrorType -> Bool
$c== :: ErrorType -> ErrorType -> Bool
Eq, (forall x. ErrorType -> Rep ErrorType x)
-> (forall x. Rep ErrorType x -> ErrorType) -> Generic ErrorType
forall x. Rep ErrorType x -> ErrorType
forall x. ErrorType -> Rep ErrorType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrorType x -> ErrorType
$cfrom :: forall x. ErrorType -> Rep ErrorType x
Generic, ReadPrec [ErrorType]
ReadPrec ErrorType
Int -> ReadS ErrorType
ReadS [ErrorType]
(Int -> ReadS ErrorType)
-> ReadS [ErrorType]
-> ReadPrec ErrorType
-> ReadPrec [ErrorType]
-> Read ErrorType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ErrorType]
$creadListPrec :: ReadPrec [ErrorType]
readPrec :: ReadPrec ErrorType
$creadPrec :: ReadPrec ErrorType
readList :: ReadS [ErrorType]
$creadList :: ReadS [ErrorType]
readsPrec :: Int -> ReadS ErrorType
$creadsPrec :: Int -> ReadS ErrorType
Read, 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
showList :: [ErrorType] -> ShowS
$cshowList :: [ErrorType] -> ShowS
show :: ErrorType -> String
$cshow :: ErrorType -> String
showsPrec :: Int -> ErrorType -> ShowS
$cshowsPrec :: Int -> ErrorType -> ShowS
Show)

-- | SMP command error type.
data CommandError
  = -- | server response sent from client or vice versa
    PROHIBITED
  | -- | bad RSA key size in NEW or KEY commands (only 1024, 2048 and 4096 bits keys are allowed)
    KEY_SIZE
  | -- | error parsing command
    SYNTAX
  | -- | 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 queue ID
    NO_QUEUE
  deriving (CommandError -> CommandError -> Bool
(CommandError -> CommandError -> Bool)
-> (CommandError -> CommandError -> Bool) -> Eq CommandError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommandError -> CommandError -> Bool
$c/= :: CommandError -> CommandError -> Bool
== :: CommandError -> CommandError -> Bool
$c== :: CommandError -> CommandError -> Bool
Eq, (forall x. CommandError -> Rep CommandError x)
-> (forall x. Rep CommandError x -> CommandError)
-> Generic CommandError
forall x. Rep CommandError x -> CommandError
forall x. CommandError -> Rep CommandError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CommandError x -> CommandError
$cfrom :: forall x. CommandError -> Rep CommandError x
Generic, 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
readListPrec :: ReadPrec [CommandError]
$creadListPrec :: ReadPrec [CommandError]
readPrec :: ReadPrec CommandError
$creadPrec :: ReadPrec CommandError
readList :: ReadS [CommandError]
$creadList :: ReadS [CommandError]
readsPrec :: Int -> ReadS CommandError
$creadsPrec :: Int -> ReadS 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
showList :: [CommandError] -> ShowS
$cshowList :: [CommandError] -> ShowS
show :: CommandError -> String
$cshow :: CommandError -> String
showsPrec :: Int -> CommandError -> ShowS
$cshowsPrec :: Int -> CommandError -> ShowS
Show)

instance Arbitrary ErrorType where arbitrary :: Gen ErrorType
arbitrary = Gen ErrorType
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU

instance Arbitrary CommandError where arbitrary :: Gen CommandError
arbitrary = Gen CommandError
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU

-- | SMP transmission parser.
transmissionP :: Parser RawTransmission
transmissionP :: Parser RawTransmission
transmissionP = do
  ByteString
signature <- Parser ByteString ByteString
segment
  ByteString
corrId <- Parser ByteString ByteString
segment
  ByteString
queueId <- Parser ByteString ByteString
segment
  ByteString
command <- Parser ByteString ByteString
A.takeByteString
  RawTransmission -> Parser RawTransmission
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
signature, ByteString
corrId, ByteString
queueId, ByteString
command)
  where
    segment :: Parser ByteString ByteString
segment = (Char -> Bool) -> Parser ByteString ByteString
A.takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
" "

-- | SMP command parser.
commandP :: Parser Cmd
commandP :: Parser Cmd
commandP =
  Parser ByteString ByteString
"NEW " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
newCmd
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"IDS " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
idsResp
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"SUB" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
SUB
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"KEY " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
keyCmd
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"ACK" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
ACK
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"OFF" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
OFF
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"DEL" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient Command 'Recipient
DEL
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"SEND " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
sendCmd
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"PING" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Sender -> Command 'Sender -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Sender
SSender Command 'Sender
PING
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"MSG " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
message
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"END" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker Command 'Broker
END
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"OK" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker Command 'Broker
OK
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"ERR " Parser ByteString ByteString -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Cmd
serverError
    Parser Cmd -> Parser Cmd -> Parser Cmd
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"PONG" Parser ByteString ByteString -> Cmd -> Parser Cmd
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker Command 'Broker
PONG
  where
    newCmd :: Parser Cmd
newCmd = SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd)
-> (RecipientPublicKey -> Command 'Recipient)
-> RecipientPublicKey
-> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientPublicKey -> Command 'Recipient
NEW (RecipientPublicKey -> Cmd)
-> Parser ByteString RecipientPublicKey -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientPublicKey
C.pubKeyP
    idsResp :: Parser Cmd
idsResp = SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker (Command 'Broker -> Cmd)
-> Parser ByteString (Command 'Broker) -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> ByteString -> Command 'Broker
IDS (ByteString -> ByteString -> Command 'Broker)
-> Parser ByteString ByteString
-> Parser ByteString (ByteString -> Command 'Broker)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString ByteString
base64P Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space) Parser ByteString (ByteString -> Command 'Broker)
-> Parser ByteString ByteString
-> Parser ByteString (Command 'Broker)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
base64P)
    keyCmd :: Parser Cmd
keyCmd = SParty 'Recipient -> Command 'Recipient -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Recipient
SRecipient (Command 'Recipient -> Cmd)
-> (RecipientPublicKey -> Command 'Recipient)
-> RecipientPublicKey
-> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RecipientPublicKey -> Command 'Recipient
KEY (RecipientPublicKey -> Cmd)
-> Parser ByteString RecipientPublicKey -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString RecipientPublicKey
C.pubKeyP
    sendCmd :: Parser Cmd
sendCmd = do
      Int
size <- Parser Int
forall a. Integral a => Parser a
A.decimal Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
      SParty 'Sender -> Command 'Sender -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Sender
SSender (Command 'Sender -> Cmd)
-> (ByteString -> Command 'Sender) -> ByteString -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Command 'Sender
SEND (ByteString -> Cmd) -> Parser ByteString ByteString -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString ByteString
A.take Int
size Parser Cmd -> Parser ByteString Char -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
    message :: Parser Cmd
message = do
      ByteString
msgId <- Parser ByteString ByteString
base64P Parser ByteString ByteString
-> Parser ByteString Char -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
      UTCTime
ts <- Parser UTCTime
tsISO8601P Parser UTCTime -> Parser ByteString Char -> Parser UTCTime
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
      Int
size <- Parser Int
forall a. Integral a => Parser a
A.decimal Parser Int -> Parser ByteString Char -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
      SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker (Command 'Broker -> Cmd)
-> (ByteString -> Command 'Broker) -> ByteString -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> UTCTime -> ByteString -> Command 'Broker
MSG ByteString
msgId UTCTime
ts (ByteString -> Cmd) -> Parser ByteString ByteString -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString ByteString
A.take Int
size Parser Cmd -> Parser ByteString Char -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString Char
A.space
    serverError :: Parser Cmd
serverError = SParty 'Broker -> Command 'Broker -> Cmd
forall (a :: Party). SParty a -> Command a -> Cmd
Cmd SParty 'Broker
SBroker (Command 'Broker -> Cmd)
-> (ErrorType -> Command 'Broker) -> ErrorType -> Cmd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorType -> Command 'Broker
ERR (ErrorType -> Cmd) -> Parser ByteString ErrorType -> Parser Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ErrorType
errorTypeP

-- TODO ignore the end of block, no need to parse it

-- | Parse SMP command.
parseCommand :: ByteString -> Either ErrorType Cmd
parseCommand :: ByteString -> Either ErrorType Cmd
parseCommand = Parser Cmd -> ErrorType -> ByteString -> Either ErrorType Cmd
forall a e. Parser a -> e -> ByteString -> Either e a
parse (Parser Cmd
commandP Parser Cmd -> Parser ByteString ByteString -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
" " Parser Cmd -> Parser ByteString ByteString -> Parser Cmd
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
A.takeByteString) (ErrorType -> ByteString -> Either ErrorType Cmd)
-> ErrorType -> ByteString -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
SYNTAX

-- | Serialize SMP command.
serializeCommand :: Cmd -> ByteString
serializeCommand :: Cmd -> ByteString
serializeCommand = \case
  Cmd SParty a
SRecipient (NEW RecipientPublicKey
rKey) -> ByteString
"NEW " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RecipientPublicKey -> ByteString
C.serializePubKey RecipientPublicKey
rKey
  Cmd SParty a
SRecipient (KEY RecipientPublicKey
sKey) -> ByteString
"KEY " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> RecipientPublicKey -> ByteString
C.serializePubKey RecipientPublicKey
sKey
  Cmd SParty a
SRecipient Command a
cmd -> Command a -> ByteString
forall a. Show a => a -> ByteString
bshow Command a
cmd
  Cmd SParty a
SSender (SEND ByteString
msgBody) -> ByteString
"SEND " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
serializeMsg ByteString
msgBody
  Cmd SParty a
SSender Command a
PING -> ByteString
"PING"
  Cmd SParty a
SBroker (MSG ByteString
msgId UTCTime
ts ByteString
msgBody) ->
    [ByteString] -> ByteString
B.unwords [ByteString
"MSG", ByteString -> ByteString
encode ByteString
msgId, String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
formatISO8601Millis UTCTime
ts, ByteString -> ByteString
serializeMsg ByteString
msgBody]
  Cmd SParty a
SBroker (IDS ByteString
rId ByteString
sId) -> [ByteString] -> ByteString
B.unwords [ByteString
"IDS", ByteString -> ByteString
encode ByteString
rId, ByteString -> ByteString
encode ByteString
sId]
  Cmd SParty a
SBroker (ERR ErrorType
err) -> ByteString
"ERR " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ErrorType -> ByteString
serializeErrorType ErrorType
err
  Cmd SParty a
SBroker Command a
resp -> Command a -> ByteString
forall a. Show a => a -> ByteString
bshow Command a
resp
  where
    serializeMsg :: ByteString -> ByteString
serializeMsg ByteString
msgBody = Int -> ByteString
forall a. Show a => a -> ByteString
bshow (ByteString -> Int
B.length ByteString
msgBody) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
msgBody ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" "

-- | SMP error parser.
errorTypeP :: Parser ErrorType
errorTypeP :: Parser ByteString ErrorType
errorTypeP = Parser ByteString ByteString
"CMD " Parser ByteString ByteString
-> Parser ByteString ErrorType -> Parser ByteString ErrorType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (CommandError -> ErrorType
CMD (CommandError -> ErrorType)
-> Parser ByteString CommandError -> Parser ByteString ErrorType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString CommandError
forall a. Read a => Parser a
parseRead1) Parser ByteString ErrorType
-> Parser ByteString ErrorType -> Parser ByteString ErrorType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ErrorType
forall a. Read a => Parser a
parseRead1

-- | Serialize SMP error.
serializeErrorType :: ErrorType -> ByteString
serializeErrorType :: ErrorType -> ByteString
serializeErrorType = ErrorType -> ByteString
forall a. Show a => a -> ByteString
bshow

-- | Send signed SMP transmission to TCP transport.
tPut :: Transport c => THandle c -> SignedRawTransmission -> IO (Either TransportError ())
tPut :: THandle c -> SignedRawTransmission -> IO (Either TransportError ())
tPut THandle c
th (C.Signature ByteString
sig, ByteString
t) =
  THandle c -> ByteString -> IO (Either TransportError ())
forall c.
Transport c =>
THandle c -> ByteString -> IO (Either TransportError ())
tPutEncrypted THandle c
th (ByteString -> IO (Either TransportError ()))
-> ByteString -> IO (Either TransportError ())
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode ByteString
sig ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
t ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" "

-- | Serialize SMP transmission.
serializeTransmission :: Transmission -> ByteString
serializeTransmission :: Transmission -> ByteString
serializeTransmission (CorrId ByteString
corrId, ByteString
queueId, Cmd
command) =
  ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
" " [ByteString
corrId, ByteString -> ByteString
encode ByteString
queueId, Cmd -> ByteString
serializeCommand Cmd
command]

-- | Validate that it is an SMP client command, used with 'tGet' by 'Simplex.Messaging.Server'.
fromClient :: Cmd -> Either ErrorType Cmd
fromClient :: Cmd -> Either ErrorType Cmd
fromClient = \case
  Cmd SParty a
SBroker Command a
_ -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED
  Cmd
cmd -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd

-- | Validate that it is an SMP server command, used with 'tGet' by 'Simplex.Messaging.Client'.
fromServer :: Cmd -> Either ErrorType Cmd
fromServer :: Cmd -> Either ErrorType Cmd
fromServer = \case
  cmd :: Cmd
cmd@(Cmd SParty a
SBroker Command a
_) -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
  Cmd
_ -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
PROHIBITED

-- | Receive and parse transmission from the TCP transport.
tGetParse :: Transport c => THandle c -> IO (Either TransportError RawTransmission)
tGetParse :: THandle c -> IO (Either TransportError RawTransmission)
tGetParse THandle c
th = (Either TransportError ByteString
-> (ByteString -> Either TransportError RawTransmission)
-> Either TransportError RawTransmission
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser RawTransmission
-> TransportError
-> ByteString
-> Either TransportError RawTransmission
forall a e. Parser a -> e -> ByteString -> Either e a
parse Parser RawTransmission
transmissionP TransportError
TEBadBlock) (Either TransportError ByteString
 -> Either TransportError RawTransmission)
-> IO (Either TransportError ByteString)
-> IO (Either TransportError RawTransmission)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> THandle c -> IO (Either TransportError ByteString)
forall c.
Transport c =>
THandle c -> IO (Either TransportError ByteString)
tGetEncrypted THandle c
th

-- | Receive client and server transmissions.
--
-- The first argument is used to limit allowed senders.
-- 'fromClient' or 'fromServer' should be used here.
tGet :: forall c m. (Transport c, MonadIO m) => (Cmd -> Either ErrorType Cmd) -> THandle c -> m SignedTransmissionOrError
tGet :: (Cmd -> Either ErrorType Cmd)
-> THandle c -> m SignedTransmissionOrError
tGet Cmd -> Either ErrorType Cmd
fromParty THandle c
th = IO (Either TransportError RawTransmission)
-> m (Either TransportError RawTransmission)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (THandle c -> IO (Either TransportError RawTransmission)
forall c.
Transport c =>
THandle c -> IO (Either TransportError RawTransmission)
tGetParse THandle c
th) m (Either TransportError RawTransmission)
-> (Either TransportError RawTransmission
    -> m SignedTransmissionOrError)
-> m SignedTransmissionOrError
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either TransportError RawTransmission
-> m SignedTransmissionOrError
decodeParseValidate
  where
    decodeParseValidate :: Either TransportError RawTransmission -> m SignedTransmissionOrError
    decodeParseValidate :: Either TransportError RawTransmission
-> m SignedTransmissionOrError
decodeParseValidate = \case
      Right (ByteString
signature, ByteString
corrId, ByteString
queueId, ByteString
command) ->
        let decodedTransmission :: Either String RawTransmission
decodedTransmission = (ByteString -> ByteString -> RawTransmission)
-> Either String ByteString
-> Either String ByteString
-> Either String RawTransmission
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,ByteString
corrId,,ByteString
command) (ByteString -> Either String ByteString
validSig (ByteString -> Either String ByteString)
-> Either String ByteString -> Either String ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Either String ByteString
decode ByteString
signature) (ByteString -> Either String ByteString
decode ByteString
queueId)
         in (String -> m SignedTransmissionOrError)
-> (RawTransmission -> m SignedTransmissionOrError)
-> Either String RawTransmission
-> m SignedTransmissionOrError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m SignedTransmissionOrError
-> String -> m SignedTransmissionOrError
forall a b. a -> b -> a
const (m SignedTransmissionOrError
 -> String -> m SignedTransmissionOrError)
-> m SignedTransmissionOrError
-> String
-> m SignedTransmissionOrError
forall a b. (a -> b) -> a -> b
$ ByteString -> m SignedTransmissionOrError
tError ByteString
corrId) RawTransmission -> m SignedTransmissionOrError
tParseValidate Either String RawTransmission
decodedTransmission
      Left TransportError
_ -> ByteString -> m SignedTransmissionOrError
tError ByteString
""

    validSig :: ByteString -> Either String ByteString
    validSig :: ByteString -> Either String ByteString
validSig ByteString
sig
      | ByteString -> Bool
B.null ByteString
sig Bool -> Bool -> Bool
|| Int -> Bool
C.validKeySize (ByteString -> Int
B.length ByteString
sig) = ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
sig
      | Bool
otherwise = String -> Either String ByteString
forall a b. a -> Either a b
Left String
"invalid signature size"

    tError :: ByteString -> m SignedTransmissionOrError
    tError :: ByteString -> m SignedTransmissionOrError
tError ByteString
corrId = SignedTransmissionOrError -> m SignedTransmissionOrError
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Signature
C.Signature ByteString
"", (ByteString -> CorrId
CorrId ByteString
corrId, ByteString
"", ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left ErrorType
BLOCK))

    tParseValidate :: RawTransmission -> m SignedTransmissionOrError
    tParseValidate :: RawTransmission -> m SignedTransmissionOrError
tParseValidate t :: RawTransmission
t@(ByteString
sig, ByteString
corrId, ByteString
queueId, ByteString
command) = do
      let cmd :: Either ErrorType Cmd
cmd = ByteString -> Either ErrorType Cmd
parseCommand ByteString
command Either ErrorType Cmd
-> (Cmd -> Either ErrorType Cmd) -> Either ErrorType Cmd
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cmd -> Either ErrorType Cmd
fromParty Either ErrorType Cmd
-> (Cmd -> Either ErrorType Cmd) -> Either ErrorType Cmd
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RawTransmission -> Cmd -> Either ErrorType Cmd
tCredentials RawTransmission
t
      SignedTransmissionOrError -> m SignedTransmissionOrError
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Signature
C.Signature ByteString
sig, (ByteString -> CorrId
CorrId ByteString
corrId, ByteString
queueId, Either ErrorType Cmd
cmd))

    tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
    tCredentials :: RawTransmission -> Cmd -> Either ErrorType Cmd
tCredentials (ByteString
signature, ByteString
_, ByteString
queueId, ByteString
_) Cmd
cmd = case Cmd
cmd of
      -- IDS response must not have queue ID
      Cmd SParty a
SBroker (IDS ByteString
_ ByteString
_) -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
      -- ERR response does not always have queue ID
      Cmd SParty a
SBroker (ERR ErrorType
_) -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
      -- PONG response must not have queue ID
      Cmd SParty a
SBroker Command a
PONG
        | ByteString -> Bool
B.null ByteString
queueId -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
        | Bool
otherwise -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
      -- other responses must have queue ID
      Cmd SParty a
SBroker Command a
_
        | ByteString -> Bool
B.null ByteString
queueId -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_QUEUE
        | Bool
otherwise -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
      -- NEW must have signature but NOT queue ID
      Cmd SParty a
SRecipient (NEW RecipientPublicKey
_)
        | ByteString -> Bool
B.null ByteString
signature -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
        | Bool -> Bool
not (ByteString -> Bool
B.null ByteString
queueId) -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
        | Bool
otherwise -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
      -- SEND must have queue ID, signature is not always required
      Cmd SParty a
SSender (SEND ByteString
_)
        | ByteString -> Bool
B.null ByteString
queueId -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_QUEUE
        | Bool
otherwise -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
      -- PING must not have queue ID or signature
      Cmd SParty a
SSender Command a
PING
        | ByteString -> Bool
B.null ByteString
queueId Bool -> Bool -> Bool
&& ByteString -> Bool
B.null ByteString
signature -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd
        | Bool
otherwise -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
HAS_AUTH
      -- other client commands must have both signature and queue ID
      Cmd SParty a
SRecipient Command a
_
        | ByteString -> Bool
B.null ByteString
signature Bool -> Bool -> Bool
|| ByteString -> Bool
B.null ByteString
queueId -> ErrorType -> Either ErrorType Cmd
forall a b. a -> Either a b
Left (ErrorType -> Either ErrorType Cmd)
-> ErrorType -> Either ErrorType Cmd
forall a b. (a -> b) -> a -> b
$ CommandError -> ErrorType
CMD CommandError
NO_AUTH
        | Bool
otherwise -> Cmd -> Either ErrorType Cmd
forall a b. b -> Either a b
Right Cmd
cmd