{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.Messaging.Server.QueueStore
  ( QueueRec (..),
    NtfCreds (..),
    ServiceRec (..),
    CertFingerprint,
    ServerEntityStatus (..),
  ) where

import Control.Applicative (optional, (<|>))
import qualified Data.ByteString.Char8 as B
import Data.Functor (($>))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.X509 as X
import qualified Data.X509.Validation as XV
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol
import Simplex.Messaging.SystemTime
import Simplex.Messaging.Transport (SMPServiceRole)
#if defined(dbServerPostgres)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Database.PostgreSQL.Simple.FromField (FromField (..))
import Database.PostgreSQL.Simple.ToField (ToField (..))
import Simplex.Messaging.Agent.Store.Postgres.DB (fromTextField_)
import Simplex.Messaging.Util (eitherToMaybe)
#endif

data QueueRec = QueueRec
  { QueueRec -> NonEmpty RcvPublicAuthKey
recipientKeys :: NonEmpty RcvPublicAuthKey,
    QueueRec -> RcvDhSecret
rcvDhSecret :: RcvDhSecret,
    QueueRec -> SenderId
senderId :: SenderId,
    QueueRec -> Maybe RcvPublicAuthKey
senderKey :: Maybe SndPublicAuthKey,
    QueueRec -> Maybe QueueMode
queueMode :: Maybe QueueMode,
    QueueRec -> Maybe (SenderId, QueueLinkData)
queueData :: Maybe (LinkId, QueueLinkData),
    QueueRec -> Maybe NtfCreds
notifier :: Maybe NtfCreds,
    QueueRec -> ServerEntityStatus
status :: ServerEntityStatus,
    QueueRec -> Maybe SystemDate
updatedAt :: Maybe SystemDate,
    QueueRec -> Maybe SenderId
rcvServiceId :: Maybe ServiceId
  }
  deriving (Int -> QueueRec -> ShowS
[QueueRec] -> ShowS
QueueRec -> String
(Int -> QueueRec -> ShowS)
-> (QueueRec -> String) -> ([QueueRec] -> ShowS) -> Show QueueRec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueueRec -> ShowS
showsPrec :: Int -> QueueRec -> ShowS
$cshow :: QueueRec -> String
show :: QueueRec -> String
$cshowList :: [QueueRec] -> ShowS
showList :: [QueueRec] -> ShowS
Show)

data NtfCreds = NtfCreds
  { NtfCreds -> SenderId
notifierId :: NotifierId,
    NtfCreds -> RcvPublicAuthKey
notifierKey :: NtfPublicAuthKey,
    NtfCreds -> RcvDhSecret
rcvNtfDhSecret :: RcvNtfDhSecret,
    NtfCreds -> Maybe SenderId
ntfServiceId :: Maybe ServiceId
  }
  deriving (Int -> NtfCreds -> ShowS
[NtfCreds] -> ShowS
NtfCreds -> String
(Int -> NtfCreds -> ShowS)
-> (NtfCreds -> String) -> ([NtfCreds] -> ShowS) -> Show NtfCreds
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtfCreds -> ShowS
showsPrec :: Int -> NtfCreds -> ShowS
$cshow :: NtfCreds -> String
show :: NtfCreds -> String
$cshowList :: [NtfCreds] -> ShowS
showList :: [NtfCreds] -> ShowS
Show)

instance StrEncoding NtfCreds where
  strEncode :: NtfCreds -> ByteString
strEncode NtfCreds {SenderId
$sel:notifierId:NtfCreds :: NtfCreds -> SenderId
notifierId :: SenderId
notifierId, RcvPublicAuthKey
$sel:notifierKey:NtfCreds :: NtfCreds -> RcvPublicAuthKey
notifierKey :: RcvPublicAuthKey
notifierKey, RcvDhSecret
$sel:rcvNtfDhSecret:NtfCreds :: NtfCreds -> RcvDhSecret
rcvNtfDhSecret :: RcvDhSecret
rcvNtfDhSecret, Maybe SenderId
$sel:ntfServiceId:NtfCreds :: NtfCreds -> Maybe SenderId
ntfServiceId :: Maybe SenderId
ntfServiceId} =
    (SenderId, RcvPublicAuthKey, RcvDhSecret) -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode (SenderId
notifierId, RcvPublicAuthKey
notifierKey, RcvDhSecret
rcvNtfDhSecret)
      ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
-> (SenderId -> ByteString) -> Maybe SenderId -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
"" ((ByteString
" nsrv=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>) (ByteString -> ByteString)
-> (SenderId -> ByteString) -> SenderId -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SenderId -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode) Maybe SenderId
ntfServiceId
  strP :: Parser NtfCreds
strP = do
    (SenderId
notifierId, RcvPublicAuthKey
notifierKey, RcvDhSecret
rcvNtfDhSecret) <- Parser (SenderId, RcvPublicAuthKey, RcvDhSecret)
forall a. StrEncoding a => Parser a
strP
    Maybe SenderId
ntfServiceId <- Parser ByteString SenderId -> Parser ByteString (Maybe SenderId)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString SenderId -> Parser ByteString (Maybe SenderId))
-> Parser ByteString SenderId -> Parser ByteString (Maybe SenderId)
forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
" nsrv=" Parser ByteString ByteString
-> Parser ByteString SenderId -> Parser ByteString SenderId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString SenderId
forall a. StrEncoding a => Parser a
strP
    NtfCreds -> Parser NtfCreds
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NtfCreds {SenderId
$sel:notifierId:NtfCreds :: SenderId
notifierId :: SenderId
notifierId, RcvPublicAuthKey
$sel:notifierKey:NtfCreds :: RcvPublicAuthKey
notifierKey :: RcvPublicAuthKey
notifierKey, RcvDhSecret
$sel:rcvNtfDhSecret:NtfCreds :: RcvDhSecret
rcvNtfDhSecret :: RcvDhSecret
rcvNtfDhSecret, Maybe SenderId
$sel:ntfServiceId:NtfCreds :: Maybe SenderId
ntfServiceId :: Maybe SenderId
ntfServiceId}

data ServiceRec = ServiceRec
  { ServiceRec -> SenderId
serviceId :: ServiceId,
    ServiceRec -> SMPServiceRole
serviceRole :: SMPServiceRole,
    ServiceRec -> CertificateChain
serviceCert :: X.CertificateChain,
    ServiceRec -> Fingerprint
serviceCertHash :: XV.Fingerprint, -- SHA512 hash of long-term service client certificate. See comment for ClientHandshake.
    ServiceRec -> SystemDate
serviceCreatedAt :: SystemDate
  }
  deriving (Int -> ServiceRec -> ShowS
[ServiceRec] -> ShowS
ServiceRec -> String
(Int -> ServiceRec -> ShowS)
-> (ServiceRec -> String)
-> ([ServiceRec] -> ShowS)
-> Show ServiceRec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServiceRec -> ShowS
showsPrec :: Int -> ServiceRec -> ShowS
$cshow :: ServiceRec -> String
show :: ServiceRec -> String
$cshowList :: [ServiceRec] -> ShowS
showList :: [ServiceRec] -> ShowS
Show)

type CertFingerprint = B.ByteString

instance StrEncoding ServiceRec where
  strEncode :: ServiceRec -> ByteString
strEncode ServiceRec {SenderId
$sel:serviceId:ServiceRec :: ServiceRec -> SenderId
serviceId :: SenderId
serviceId, SMPServiceRole
$sel:serviceRole:ServiceRec :: ServiceRec -> SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, CertificateChain
$sel:serviceCert:ServiceRec :: ServiceRec -> CertificateChain
serviceCert :: CertificateChain
serviceCert, Fingerprint
$sel:serviceCertHash:ServiceRec :: ServiceRec -> Fingerprint
serviceCertHash :: Fingerprint
serviceCertHash, SystemDate
$sel:serviceCreatedAt:ServiceRec :: ServiceRec -> SystemDate
serviceCreatedAt :: SystemDate
serviceCreatedAt} =
    [ByteString] -> ByteString
B.unwords
      [ ByteString
"service_id=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SenderId -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SenderId
serviceId,
        ByteString
"role=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SMPServiceRole -> ByteString
forall a. Encoding a => a -> ByteString
smpEncode SMPServiceRole
serviceRole,
        ByteString
"cert=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> CertificateChain -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode CertificateChain
serviceCert,
        ByteString
"cert_hash=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Fingerprint -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode Fingerprint
serviceCertHash,
        ByteString
"created_at=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> SystemDate -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode SystemDate
serviceCreatedAt
      ]
  strP :: Parser ServiceRec
strP = do
    SenderId
serviceId <- Parser ByteString ByteString
"service_id=" Parser ByteString ByteString
-> Parser ByteString SenderId -> Parser ByteString SenderId
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString SenderId
forall a. StrEncoding a => Parser a
strP
    SMPServiceRole
serviceRole <- Parser ByteString ByteString
" role=" Parser ByteString ByteString
-> Parser ByteString SMPServiceRole
-> Parser ByteString SMPServiceRole
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString SMPServiceRole
forall a. Encoding a => Parser a
smpP
    CertificateChain
serviceCert <- Parser ByteString ByteString
" cert=" Parser ByteString ByteString
-> Parser ByteString CertificateChain
-> Parser ByteString CertificateChain
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString CertificateChain
forall a. StrEncoding a => Parser a
strP
    Fingerprint
serviceCertHash <- Parser ByteString ByteString
" cert_hash=" Parser ByteString ByteString
-> Parser ByteString Fingerprint -> Parser ByteString Fingerprint
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Fingerprint
forall a. StrEncoding a => Parser a
strP
    SystemDate
serviceCreatedAt <- Parser ByteString ByteString
" created_at=" Parser ByteString ByteString
-> Parser ByteString SystemDate -> Parser ByteString SystemDate
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString SystemDate
forall a. StrEncoding a => Parser a
strP
    ServiceRec -> Parser ServiceRec
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServiceRec {SenderId
$sel:serviceId:ServiceRec :: SenderId
serviceId :: SenderId
serviceId, SMPServiceRole
$sel:serviceRole:ServiceRec :: SMPServiceRole
serviceRole :: SMPServiceRole
serviceRole, CertificateChain
$sel:serviceCert:ServiceRec :: CertificateChain
serviceCert :: CertificateChain
serviceCert, Fingerprint
$sel:serviceCertHash:ServiceRec :: Fingerprint
serviceCertHash :: Fingerprint
serviceCertHash, SystemDate
$sel:serviceCreatedAt:ServiceRec :: SystemDate
serviceCreatedAt :: SystemDate
serviceCreatedAt}

data ServerEntityStatus
  = EntityActive
  | EntityBlocked BlockingInfo
  | EntityOff
  deriving (ServerEntityStatus -> ServerEntityStatus -> Bool
(ServerEntityStatus -> ServerEntityStatus -> Bool)
-> (ServerEntityStatus -> ServerEntityStatus -> Bool)
-> Eq ServerEntityStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServerEntityStatus -> ServerEntityStatus -> Bool
== :: ServerEntityStatus -> ServerEntityStatus -> Bool
$c/= :: ServerEntityStatus -> ServerEntityStatus -> Bool
/= :: ServerEntityStatus -> ServerEntityStatus -> Bool
Eq, Int -> ServerEntityStatus -> ShowS
[ServerEntityStatus] -> ShowS
ServerEntityStatus -> String
(Int -> ServerEntityStatus -> ShowS)
-> (ServerEntityStatus -> String)
-> ([ServerEntityStatus] -> ShowS)
-> Show ServerEntityStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerEntityStatus -> ShowS
showsPrec :: Int -> ServerEntityStatus -> ShowS
$cshow :: ServerEntityStatus -> String
show :: ServerEntityStatus -> String
$cshowList :: [ServerEntityStatus] -> ShowS
showList :: [ServerEntityStatus] -> ShowS
Show)

instance StrEncoding ServerEntityStatus where
  strEncode :: ServerEntityStatus -> ByteString
strEncode = \case
    ServerEntityStatus
EntityActive -> ByteString
"active"
    EntityBlocked BlockingInfo
info -> ByteString
"blocked," ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> BlockingInfo -> ByteString
forall a. StrEncoding a => a -> ByteString
strEncode BlockingInfo
info
    ServerEntityStatus
EntityOff -> ByteString
"off"
  strP :: Parser ServerEntityStatus
strP =
    Parser ByteString ByteString
"active" Parser ByteString ByteString
-> ServerEntityStatus -> Parser ServerEntityStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ServerEntityStatus
EntityActive
      Parser ServerEntityStatus
-> Parser ServerEntityStatus -> Parser ServerEntityStatus
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"blocked," Parser ByteString ByteString
-> Parser ServerEntityStatus -> Parser ServerEntityStatus
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (BlockingInfo -> ServerEntityStatus
EntityBlocked (BlockingInfo -> ServerEntityStatus)
-> Parser ByteString BlockingInfo -> Parser ServerEntityStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString BlockingInfo
forall a. StrEncoding a => Parser a
strP)
      Parser ServerEntityStatus
-> Parser ServerEntityStatus -> Parser ServerEntityStatus
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"off" Parser ByteString ByteString
-> ServerEntityStatus -> Parser ServerEntityStatus
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ServerEntityStatus
EntityOff

#if defined(dbServerPostgres)
instance FromField ServerEntityStatus where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8

instance ToField ServerEntityStatus where toField = toField . decodeLatin1 . strEncode
#endif