simplex-chat/src/Simplex/Chat/Protocol.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}

module Simplex.Chat.Protocol where

import Control.Applicative ((<|>))
import Control.Monad (when, (<=<))
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.TH as JQ
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Either (fromRight)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe, 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 (UTCTime)
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Simplex.Chat.Call
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_)
import Simplex.Messaging.Compression (Compressed, compress1, decompress1, decompressedSize)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Protocol (MsgBody)
import Simplex.Messaging.Util (decodeJSON, eitherToMaybe, encodeJSON, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version)

-- Chat version history:
-- 1 - support chat versions in connections (9/1/2023)
-- 2 - create contacts for group members only via x.grp.direct.inv (9/16/2023)
-- 3 - faster joining via group links without creating contact (10/30/2023)
-- 4 - group message forwarding (11/18/2023)
-- 5 - batch sending messages (12/23/2023)
-- 6 - send group welcome message after history (12/29/2023)
-- 7 - update member profiles (1/15/2024)
-- 8 - compress messages and PQ e2e encryption (2024-03-08)
-- 9 - batch sending in direct connections (2024-07-24)
-- 10 - business chats (2024-11-29)
-- 11 - fix profile update in business chats (2024-12-05)
-- 12 - support sending and receiving content reports (2025-01-03)
-- 14 - support sending and receiving group join rejection (2025-02-24)
-- 15 - support specifying message scopes for group messages (2025-03-12)
-- 16 - support short link data (2025-06-10)
-- 17 - allow host voice messages during member approval regardless of group voice setting (2026-02-10)

-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
-- This indirection is needed for backward/forward compatibility testing.
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
currentChatVersion :: VersionChat
currentChatVersion = VersionChat 17

-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRangeChat
supportedChatVRange = mkVersionRange initialChatVersion currentChatVersion
{-# INLINE supportedChatVRange #-}

-- version range that supports skipping establishing direct connections in a group and establishing direct connection via x.grp.direct.inv
groupDirectInvVersion :: VersionChat
groupDirectInvVersion = VersionChat 2

-- version range that supports joining group via group link without creating direct contact
groupFastLinkJoinVersion :: VersionChat
groupFastLinkJoinVersion = VersionChat 3

-- version range that supports group forwarding
groupForwardVersion :: VersionChat
groupForwardVersion = VersionChat 4

-- version range that supports batch sending in groups
batchSendVersion :: VersionChat
batchSendVersion = VersionChat 5

-- version range that supports sending group welcome message in group history
groupHistoryIncludeWelcomeVersion :: VersionChat
groupHistoryIncludeWelcomeVersion = VersionChat 6

-- version range that supports sending member profile updates to groups
memberProfileUpdateVersion :: VersionChat
memberProfileUpdateVersion = VersionChat 7

-- version range that supports compressing messages and PQ e2e encryption
pqEncryptionCompressionVersion :: VersionChat
pqEncryptionCompressionVersion = VersionChat 8

-- version range that supports batch sending in direct connections, and forwarding batched messages in groups
batchSend2Version :: VersionChat
batchSend2Version = VersionChat 9

-- supports differentiating business chats when joining contact addresses
businessChatsVersion :: VersionChat
businessChatsVersion = VersionChat 10

-- support updating preferences in business chats (XGrpPrefs message)
businessChatPrefsVersion :: VersionChat
businessChatPrefsVersion = VersionChat 11

-- support sending and receiving content reports (MCReport message content)
contentReportsVersion :: VersionChat
contentReportsVersion = VersionChat 12

-- support sending and receiving group join rejection (XGrpLinkReject)
groupJoinRejectVersion :: VersionChat
groupJoinRejectVersion = VersionChat 14

-- support group knocking (MsgScope)
groupKnockingVersion :: VersionChat
groupKnockingVersion = VersionChat 15

-- support short link data in invitation, contact and group links
shortLinkDataVersion :: VersionChat
shortLinkDataVersion = VersionChat 16

-- support host voice messages during member approval regardless of group voice setting
memberSupportVoiceVersion :: VersionChat
memberSupportVoiceVersion = VersionChat 17

agentToChatVersion :: VersionSMPA -> VersionChat
agentToChatVersion v
  | v < pqdrSMPAgentVersion = initialChatVersion
  | otherwise = pqEncryptionCompressionVersion

data ConnectionEntity
  = RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
  | RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
  | UserContactConnection {entityConnection :: Connection, userContact :: UserContact}
  deriving (Eq, Show)

$(JQ.deriveJSON (sumTypeJSON fstToLower) ''ConnectionEntity)

connEntityInfo :: ConnectionEntity -> String
connEntityInfo = \case
  RcvDirectMsgConnection c ct_ -> ctInfo ct_ <> ", status: " <> show (connStatus c)
  RcvGroupMsgConnection c g m -> mInfo g m <> ", status: " <> show (connStatus c)
  UserContactConnection c _uc -> "user address, status: " <> show (connStatus c)
  where
    ctInfo = maybe "connection" $ \Contact {contactId} -> "contact " <> show contactId
    mInfo GroupInfo {groupId} GroupMember {groupMemberId} = "group " <> show groupId <> ", member " <> show groupMemberId

updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity
updateEntityConnStatus connEntity connStatus = case connEntity of
  RcvDirectMsgConnection c ct_ -> RcvDirectMsgConnection (st c) ((\ct -> (ct :: Contact) {activeConn = Just $ st c}) <$> ct_)
  RcvGroupMsgConnection c gInfo m@GroupMember {activeConn = c'} -> RcvGroupMsgConnection (st c) gInfo m {activeConn = st <$> c'}
  UserContactConnection c uc -> UserContactConnection (st c) uc
  where
    st c = c {connStatus}

data MsgEncoding = Binary | Json

data SMsgEncoding (e :: MsgEncoding) where
  SBinary :: SMsgEncoding 'Binary
  SJson :: SMsgEncoding 'Json

deriving instance Show (SMsgEncoding e)

class MsgEncodingI (e :: MsgEncoding) where
  encoding :: SMsgEncoding e

instance MsgEncodingI 'Binary where encoding = SBinary

instance MsgEncodingI 'Json where encoding = SJson

instance TestEquality SMsgEncoding where
  testEquality SBinary SBinary = Just Refl
  testEquality SJson SJson = Just Refl
  testEquality _ _ = Nothing

checkEncoding :: forall t e e'. (MsgEncodingI e, MsgEncodingI e') => t e' -> Either String (t e)
checkEncoding x = case testEquality (encoding @e) (encoding @e') of
  Just Refl -> Right x
  Nothing -> Left "bad encoding"

data AppMessage (e :: MsgEncoding) where
  AMJson :: AppMessageJson -> AppMessage 'Json
  AMBinary :: AppMessageBinary -> AppMessage 'Binary

-- chat message is sent as JSON with these properties
data AppMessageJson = AppMessageJson
  { v :: Maybe ChatVersionRange,
    msgId :: Maybe SharedMsgId,
    event :: Text,
    params :: J.Object
  }

data AppMessageBinary = AppMessageBinary
  { msgId :: Maybe SharedMsgId,
    tag :: Char,
    body :: ByteString
  }

instance StrEncoding AppMessageBinary where
  strEncode AppMessageBinary {tag, msgId, body} = smpEncode (tag, msgId', Tail body)
    where
      msgId' = maybe B.empty (\(SharedMsgId mId') -> mId') msgId
  strP = do
    (tag, msgId', Tail body) <- smpP
    let msgId = if B.null msgId' then Nothing else Just (SharedMsgId msgId')
    pure AppMessageBinary {tag, msgId, body}

data MsgScope = MSMember {memberId :: MemberId} -- Admins can use any member id; members can use only their own id
  deriving (Eq, Show)

$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MS") ''MsgScope)

$(JQ.deriveJSON defaultJSON ''AppMessageJson)

data MsgRef = MsgRef
  { msgId :: Maybe SharedMsgId,
    sentAt :: UTCTime,
    sent :: Bool,
    memberId :: Maybe MemberId -- present in group message references, Nothing for channel messages
  }
  deriving (Eq, Show)

$(JQ.deriveJSON defaultJSON ''MsgRef)

data LinkPreview = LinkPreview {uri :: Text, title :: Text, description :: Text, image :: ImageData, content :: Maybe LinkContent}
  deriving (Eq, Show)

data LinkContent = LCPage | LCImage | LCVideo {duration :: Maybe Int} | LCUnknown {tag :: Text, json :: J.Object}
  deriving (Eq, Show)

data ReportReason = RRSpam | RRContent | RRCommunity | RRProfile | RROther | RRUnknown Text
  deriving (Eq, Show)

$(pure [])

instance FromJSON LinkContent where
  parseJSON v@(J.Object j) =
    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
      <|> LCUnknown <$> j .: "type" <*> pure j
  parseJSON invalid =
    JT.prependFailure "bad LinkContent, " (JT.typeMismatch "Object" invalid)

instance ToJSON LinkContent where
  toJSON = \case
    LCUnknown _ j -> J.Object j
    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v
  toEncoding = \case
    LCUnknown _ j -> JE.value $ J.Object j
    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "LC") ''LinkContent) v

$(JQ.deriveJSON defaultJSON ''LinkPreview)

instance StrEncoding ReportReason where
  strEncode = \case
    RRSpam -> "spam"
    RRContent -> "content"
    RRCommunity -> "community"
    RRProfile -> "profile"
    RROther -> "other"
    RRUnknown t -> encodeUtf8 t
  strP =
    A.takeTill (== ' ') >>= \case
      "spam" -> pure RRSpam
      "content" -> pure RRContent
      "community" -> pure RRCommunity
      "profile" -> pure RRProfile
      "other" -> pure RROther
      t -> pure $ RRUnknown $ safeDecodeUtf8 t

instance FromJSON ReportReason where
  parseJSON = strParseJSON "ReportReason"

instance ToJSON ReportReason where
  toJSON = strToJSON
  toEncoding = strToJEncoding

data ChatMessage e = ChatMessage
  { chatVRange :: VersionRangeChat,
    msgId :: Maybe SharedMsgId,
    chatMsgEvent :: ChatMsgEvent e
  }
  deriving (Eq, Show)

data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)

-- Can be extended to support profile identity keys (e.g., secp256k1 for Nostr)
data KeyRef = KRMember
  deriving (Eq, Show)

data ChatBinding = CBGroup | CBDirect | CBChannel
  deriving (Eq, Show)

data MsgSignature = MsgSignature KeyRef C.ASignature
  deriving (Show)

data SignedMsg = SignedMsg
  { chatBinding :: ChatBinding,
    signatures :: L.NonEmpty MsgSignature,
    signedBody :: ByteString -- exact bytes that were signed
  }
  deriving (Show)

-- | Post-verification message. Encodes the invariant that signature
-- has been checked (or wasn't required). Store and forward functions
-- accept only VerifiedMsg, preventing unverified messages from being persisted.
data VerifiedMsg e
  = VMUnsigned (ChatMessage e)
  | VMSigned MsgSigStatus SignedMsg (ChatMessage e)

data ParsedMsg e = ParsedMsg (Maybe GrpMsgForward) (Maybe SignedMsg) (ChatMessage e)

data AParsedMsg = forall e. MsgEncodingI e => APMsg (SMsgEncoding e) (ParsedMsg e)

data FwdSender
  = FwdMember MemberId ContactName
  | FwdChannel
  deriving (Eq, Show)

data GrpMsgForward = GrpMsgForward
  { fwdSender :: FwdSender,
    fwdBrokerTs :: UTCTime
  }
  deriving (Eq, Show)


instance Encoding FwdSender where
  smpEncode = \case
    FwdMember memberId memberName -> smpEncode ('M', memberId, memberName)
    FwdChannel -> "C"
  smpP =
    A.anyChar >>= \case
      'M' -> uncurry FwdMember <$> smpP
      'C' -> pure FwdChannel
      c -> fail $ "invalid FwdSender tag: " <> show c

instance Encoding GrpMsgForward where
  smpEncode GrpMsgForward {fwdSender, fwdBrokerTs} =
    smpEncode (fwdSender, utcToSystemTime fwdBrokerTs)
  smpP = do
    fwdSender <- smpP
    fwdBrokerTs <- systemToUTCTime <$> smpP
    pure GrpMsgForward {fwdSender, fwdBrokerTs}

instance Encoding KeyRef where
  smpEncode = \case
    KRMember -> "M"
  smpP =
    A.anyChar >>= \case
      'M' -> pure KRMember
      c -> fail $ "invalid KeyRef tag: " <> show c

instance Encoding ChatBinding where
  smpEncode = \case
    CBGroup -> "G"
    CBDirect -> "D"
    CBChannel -> "C"
  smpP =
    A.anyChar >>= \case
      'G' -> pure CBGroup
      'D' -> pure CBDirect
      'C' -> pure CBChannel
      c -> fail $ "invalid ChatBinding: " <> show c

instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode

instance FromField ChatBinding where fromField = fromTextField_ $ eitherToMaybe . smpDecode . encodeUtf8

instance Encoding MsgSignature where
  smpEncode (MsgSignature keyRef sig) = smpEncode (keyRef, C.signatureBytes sig)
  smpP = MsgSignature <$> smpP <*> (C.decodeSignature <$?> smpP)

-- Wire format: <binding:1> <sigCount:1> (<keyRef><sig:64>)* <body>
instance Encoding SignedMsg where
  smpEncode SignedMsg {chatBinding, signatures, signedBody} = smpEncode (chatBinding, signatures, Tail signedBody)
  smpP = do
    (chatBinding, signatures, Tail signedBody) <- smpP
    pure SignedMsg {chatBinding, signatures, signedBody}

-- | Generic signing context — data, not function.
-- Callers construct per-event; createSndMessages uses mechanically.
data MsgSigning = MsgSigning
  { bindingTag :: ChatBinding,
    bindingData :: ByteString,
    keyRef :: KeyRef,
    privKey :: C.PrivateKeyEd25519
  }

encodeChatBinding :: ChatBinding -> ByteString -> ByteString
encodeChatBinding cb bindingData = smpEncode cb <> bindingData

data ChatMsgEvent (e :: MsgEncoding) where
  XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
  XMsgFileDescr :: {msgId :: SharedMsgId, fileDescr :: FileDescr} -> ChatMsgEvent 'Json
  XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, mentions :: Map MemberName MsgMention, ttl :: Maybe Int, live :: Maybe Bool, scope :: Maybe MsgScope, asGroup :: Maybe Bool} -> ChatMsgEvent 'Json
  XMsgDel :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, onlyHistory :: Bool} -> ChatMsgEvent 'Json
  XMsgDeleted :: ChatMsgEvent 'Json
  XMsgReact :: {msgId :: SharedMsgId, memberId :: Maybe MemberId, scope :: Maybe MsgScope, reaction :: MsgReaction, add :: Bool} -> ChatMsgEvent 'Json
  XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue
  XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
  XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
  XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
  XInfo :: Profile -> ChatMsgEvent 'Json
  XContact :: {profile :: Profile, contactReqId :: Maybe XContactId, welcomeMsgId :: Maybe SharedMsgId, requestMsg :: Maybe (SharedMsgId, MsgContent)} -> ChatMsgEvent 'Json
  XMember :: {profile :: Profile, newMemberId :: MemberId, newMemberKey :: MemberKey} -> ChatMsgEvent 'Json
  XDirectDel :: ChatMsgEvent 'Json
  XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
  XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
  XGrpLinkInv :: GroupLinkInvitation -> ChatMsgEvent 'Json
  XGrpLinkReject :: GroupLinkRejection -> ChatMsgEvent 'Json
  XGrpLinkMem :: Profile -> ChatMsgEvent 'Json
  XGrpLinkAcpt :: GroupAcceptance -> GroupMemberRole -> MemberId -> ChatMsgEvent 'Json
  XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
  XGrpRelayAcpt :: ShortLinkContact -> ChatMsgEvent 'Json
  XGrpRelayTest :: ByteString -> Maybe ByteString -> ChatMsgEvent 'Json
  XGrpRelayNew :: ShortLinkContact -> ChatMsgEvent 'Json
  XGrpRelayReject :: RelayRejectionReason -> ChatMsgEvent 'Json
  XGrpMemNew :: MemberInfo -> Maybe MsgScope -> ChatMsgEvent 'Json
  XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json
  XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
  XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
  XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
  XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
  XGrpMemRestrict :: MemberId -> MemberRestrictions -> ChatMsgEvent 'Json
  XGrpMemCon :: MemberId -> ChatMsgEvent 'Json
  XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
  XGrpMemDel :: MemberId -> Bool -> ChatMsgEvent 'Json
  XGrpLeave :: ChatMsgEvent 'Json
  XGrpDel :: ChatMsgEvent 'Json
  XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
  XGrpPrefs :: GroupPreferences -> ChatMsgEvent 'Json
  XGrpDirectInv :: ConnReqInvitation -> Maybe MsgContent -> Maybe MsgScope -> ChatMsgEvent 'Json
  XGrpMsgForward :: GrpMsgForward -> ChatMessage 'Json -> ChatMsgEvent 'Json
  XInfoProbe :: Probe -> ChatMsgEvent 'Json
  XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
  XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
  XCallInv :: CallId -> CallInvitation -> ChatMsgEvent 'Json
  XCallOffer :: CallId -> CallOffer -> ChatMsgEvent 'Json
  XCallAnswer :: CallId -> CallAnswer -> ChatMsgEvent 'Json
  XCallExtra :: CallId -> CallExtraInfo -> ChatMsgEvent 'Json
  XCallEnd :: CallId -> ChatMsgEvent 'Json
  XOk :: ChatMsgEvent 'Json
  XUnknown :: {event :: Text, params :: J.Object} -> ChatMsgEvent 'Json
  BFileChunk :: SharedMsgId -> FileChunk -> ChatMsgEvent 'Binary

deriving instance Eq (ChatMsgEvent e)

deriving instance Show (ChatMsgEvent e)

data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgEvent e)

deriving instance Show AChatMsgEvent

-- when sending, used for deciding whether message will be forwarded by host or not (memberSendAction);
-- actual filtering on forwarding is done in processEvent
isForwardedGroupMsg :: ChatMsgEvent e -> Bool
isForwardedGroupMsg ev = case ev of
  XMsgNew mc -> case mc of
    MsgContainer {file = Just FileInvitation {fileInline = Just _}} -> False
    _ -> True
  XMsgFileDescr _ _ -> True
  XMsgUpdate {} -> True
  XMsgDel {} -> True
  XMsgReact {} -> True
  XFileCancel _ -> True
  XInfo _ -> True
  XGrpRelayNew _ -> True
  XGrpMemNew {} -> True
  XGrpMemRole {} -> True
  XGrpMemRestrict {} -> True
  XGrpMemDel {} -> True
  XGrpLeave -> True
  XGrpDel -> True
  XGrpInfo _ -> True
  XGrpPrefs _ -> True
  _ -> False

data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object}
  deriving (Eq, Show)

emojiTag :: IsString a => a
emojiTag = "emoji"

knownReaction :: MsgReaction -> Either String MsgReaction
knownReaction = \case
  r@MREmoji {} -> Right r
  MRUnknown {} -> Left "unknown MsgReaction"

-- parseJSON for MsgReaction parses unknown emoji reactions as MRUnknown with type "emoji",
-- allowing to add new emojis in a backwards compatible way - UI shows them as ?
instance FromJSON MsgReaction where
  parseJSON (J.Object v) = do
    tag <- v .: "type"
    if tag == emojiTag
      then (MREmoji <$> v .: emojiTag) <|> pure (MRUnknown tag v)
      else pure $ MRUnknown tag v
  parseJSON invalid =
    JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid)

instance ToJSON MsgReaction where
  toJSON = \case
    MRUnknown {json} -> J.Object json
    MREmoji emoji -> J.object ["type" .= (emojiTag :: Text), emojiTag .= emoji]
  toEncoding = \case
    MRUnknown {json} -> JE.value $ J.Object json
    MREmoji emoji -> J.pairs $ "type" .= (emojiTag :: Text) <> emojiTag .= emoji

instance ToField MsgReaction where
  toField = toField . encodeJSON

instance FromField MsgReaction where
  fromField = fromTextField_ decodeJSON

newtype MREmojiChar = MREmojiChar Char
  deriving (Eq, Show)

instance ToJSON MREmojiChar where
  toEncoding (MREmojiChar c) = J.toEncoding c
  toJSON (MREmojiChar c) = J.toJSON c

instance FromJSON MREmojiChar where
  parseJSON v = mrEmojiChar <$?> J.parseJSON v

mrEmojiChar :: Char -> Either String MREmojiChar
mrEmojiChar c
  | c `elem` ("👍👎😀😂😢❤️🚀✅" :: String) = Right $ MREmojiChar c
  | otherwise = Left "bad emoji"

data FileChunk = FileChunk {chunkNo :: Integer, chunkBytes :: ByteString} | FileChunkCancel
  deriving (Eq, Show)

instance Encoding FileChunk where
  smpEncode = \case
    FileChunk {chunkNo, chunkBytes} -> smpEncode ('F', fromIntegral chunkNo :: Word32, Tail chunkBytes)
    FileChunkCancel -> smpEncode 'C'
  smpP =
    smpP >>= \case
      'F' -> do
        chunkNo <- fromIntegral <$> smpP @Word32
        Tail chunkBytes <- smpP
        pure FileChunk {chunkNo, chunkBytes}
      'C' -> pure FileChunkCancel
      _ -> fail "bad FileChunk"

newtype InlineFileChunk = IFC {unIFC :: FileChunk}

instance Encoding InlineFileChunk where
  smpEncode (IFC chunk) = case chunk of
    FileChunk {chunkNo, chunkBytes} -> smpEncode (w2c $ fromIntegral chunkNo, Tail chunkBytes)
    FileChunkCancel -> smpEncode '\NUL'
  smpP = do
    c <- A.anyChar
    IFC <$> case c of
      '\NUL' -> pure FileChunkCancel
      _ -> do
        Tail chunkBytes <- smpP
        pure FileChunk {chunkNo = fromIntegral $ c2w c, chunkBytes}

data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
  deriving (Eq, Show)

cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg = \case
  ACME _ (XMsgNew MsgContainer {quote = Just quotedMsg}) -> Just quotedMsg
  _ -> Nothing

data MsgContentTag
  = MCText_
  | MCLink_
  | MCImage_
  | MCVideo_
  | MCVoice_
  | MCFile_
  | MCReport_
  | MCChat_
  | MCUnknown_ Text
  deriving (Eq, Show)

instance StrEncoding MsgContentTag where
  strEncode = \case
    MCText_ -> "text"
    MCLink_ -> "link"
    MCImage_ -> "image"
    MCVideo_ -> "video"
    MCFile_ -> "file"
    MCVoice_ -> "voice"
    MCReport_ -> "report"
    MCChat_ -> "chat"
    MCUnknown_ t -> encodeUtf8 t
  strDecode = \case
    "text" -> Right MCText_
    "link" -> Right MCLink_
    "image" -> Right MCImage_
    "video" -> Right MCVideo_
    "voice" -> Right MCVoice_
    "file" -> Right MCFile_
    "report" -> Right MCReport_
    "chat" -> Right MCChat_
    t -> Right . MCUnknown_ $ safeDecodeUtf8 t
  strP = strDecode <$?> A.takeTill (== ' ')

instance FromJSON MsgContentTag where
  parseJSON = strParseJSON "MsgContentType"

instance ToJSON MsgContentTag where
  toJSON = strToJSON
  toEncoding = strToJEncoding

instance FromField MsgContentTag where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8

instance ToField MsgContentTag where toField = toField . safeDecodeUtf8 . strEncode

-- Wire JSON 1:1 with parsed form. The three discriminator fields `quote`, `parent`,
-- and `forward` are independent and may co-occur (e.g. a comment that quotes another
-- comment carries both `parent` and `quote`). `forward` is `Maybe Bool` for backwards
-- compatibility with the previous wire encoding: the serializer omits the field when
-- `Nothing` and the parser treats absent/false as "not a forward".
data MsgContainer = MsgContainer
  { content :: MsgContent,
    -- the key used in mentions is a locally (per message) unique display name of member.
    -- Suffixes _1, _2 should be appended to make names locally unique.
    -- It should be done in the UI, as they will be part of the text, and validated in the API.
    mentions :: MsgMentions,
    file :: Maybe FileInvitation,
    ttl :: Maybe Int,
    live :: Maybe Bool,
    scope :: Maybe MsgScope,
    asGroup :: Maybe Bool,
    quote :: Maybe QuotedMsg,
    parent :: Maybe MsgRef,
    forward :: Maybe Bool
  }
  deriving (Eq, Show)

mcSimple :: MsgContent -> MsgContainer
mcSimple content =
  MsgContainer
    { content,
      mentions = MsgMentions M.empty,
      file = Nothing,
      ttl = Nothing,
      live = Nothing,
      scope = Nothing,
      asGroup = Nothing,
      quote = Nothing,
      parent = Nothing,
      forward = Nothing
    }

mcQuote :: QuotedMsg -> MsgContent -> MsgContainer
mcQuote q c = (mcSimple c) {quote = Just q}

mcComment :: MsgRef -> MsgContent -> MsgContainer
mcComment p c = (mcSimple c) {parent = Just p}

mcForward :: MsgContent -> MsgContainer
mcForward c = (mcSimple c) {forward = Just True}

data MsgContent
  = MCText {text :: Text}
  | MCLink {text :: Text, preview :: LinkPreview}
  | MCImage {text :: Text, image :: ImageData}
  | MCVideo {text :: Text, image :: ImageData, duration :: Int}
  | MCVoice {text :: Text, duration :: Int}
  | MCFile {text :: Text}
  | MCReport {text :: Text, reason :: ReportReason}
  | MCChat {text :: Text, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig}
  | MCUnknown {tag :: Text, text :: Text, json :: J.Object}
  deriving (Eq, Show)

data MsgChatLink
  = MCLContact {connLink :: ShortLinkContact, profile :: Profile, business :: Bool}
  | MCLInvitation {invLink :: ShortLinkInvitation, profile :: Profile}
  | MCLGroup {connLink :: ShortLinkContact, groupProfile :: GroupProfile}
  deriving (Eq, Show)

data LinkOwnerSig = LinkOwnerSig
  { ownerId :: Maybe B64UrlByteString,
    chatBinding :: B64UrlByteString,
    ownerSig :: C.Signature 'C.Ed25519
  }
  deriving (Eq, Show)

msgContentText :: MsgContent -> Text
msgContentText = \case
  MCText t -> t
  MCLink {text} -> text
  MCImage {text} -> text
  MCVideo {text} -> text
  MCVoice {text, duration} ->
    if T.null text then msg else msg <> "; " <> text
    where
      msg = "voice message " <> durationText duration
  MCFile t -> t
  MCReport {text, reason} ->
    if T.null text then msg else msg <> ": " <> text
    where
      msg = "report " <> safeDecodeUtf8 (strEncode reason)
  MCChat {text} -> text
  MCUnknown {text} -> text

durationText :: Int -> Text
durationText duration =
  let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> with0 mins <> ":" <> with0 secs <> ")"
  where
    with0 n
      | n <= 9 = '0' : show n
      | otherwise = show n

msgContentHasText :: MsgContent -> Bool
msgContentHasText =
  not . T.null . \case
    MCVoice {text} -> text
    mc -> msgContentText mc

isVoice :: MsgContent -> Bool
isVoice = \case
  MCVoice {} -> True
  _ -> False

isReport :: MsgContent -> Bool
isReport = \case
  MCReport {} -> True
  _ -> False

msgContentTag :: MsgContent -> MsgContentTag
msgContentTag = \case
  MCText _ -> MCText_
  MCLink {} -> MCLink_
  MCImage {} -> MCImage_
  MCVideo {} -> MCVideo_
  MCVoice {} -> MCVoice_
  MCFile {} -> MCFile_
  MCReport {} -> MCReport_
  MCChat {} -> MCChat_
  MCUnknown {tag} -> MCUnknown_ tag

data MsgMention = MsgMention {memberId :: MemberId}
  deriving (Eq, Show)

newtype MsgMentions = MsgMentions (Map MemberName MsgMention)
  deriving (Eq, Show)

$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink)

$(JQ.deriveJSON defaultJSON ''LinkOwnerSig)

$(JQ.deriveJSON defaultJSON ''MsgMention)

instance FromJSON MsgMentions where
  parseJSON v = MsgMentions <$> parseJSON v
  omittedField = Just $ MsgMentions M.empty

instance ToJSON MsgMentions where
  toJSON (MsgMentions m) = toJSON $ toMaybeMap m
  toEncoding (MsgMentions m) = toEncoding $ toMaybeMap m
  omitField (MsgMentions m) = M.null m

toMaybeMap :: Map k v -> Maybe (Map k v)
toMaybeMap m = if M.null m then Nothing else Just m
{-# INLINE toMaybeMap #-}

$(JQ.deriveJSON defaultJSON ''QuotedMsg)

instance FromJSON MsgContent where
  parseJSON (J.Object v) =
    v .: "type" >>= \case
      MCText_ -> MCText <$> v .: "text"
      MCLink_ -> do
        text <- v .: "text"
        preview <- v .: "preview"
        pure MCLink {text, preview}
      MCImage_ -> do
        text <- v .: "text"
        image <- v .: "image"
        pure MCImage {text, image}
      MCVideo_ -> do
        text <- v .: "text"
        image <- v .: "image"
        duration <- v .: "duration"
        pure MCVideo {text, image, duration}
      MCVoice_ -> do
        text <- v .: "text"
        duration <- v .: "duration"
        pure MCVoice {text, duration}
      MCFile_ -> MCFile <$> v .: "text"
      MCReport_ -> do
        text <- v .: "text"
        reason <- v .: "reason"
        pure MCReport {text, reason}
      MCChat_ -> do
        text <- v .: "text"
        chatLink <- v .: "chatLink"
        ownerSig <- v .:? "ownerSig"
        pure MCChat {text, chatLink, ownerSig}
      MCUnknown_ tag -> do
        text <- fromMaybe unknownMsgType <$> v .:? "text"
        pure MCUnknown {tag, text, json = v}
  parseJSON invalid =
    JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid)

unknownMsgType :: Text
unknownMsgType = "unknown message type"

(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
key .=? value = maybe id ((:) . (key .=)) value

instance ToJSON MsgContent where
  toJSON = \case
    MCUnknown {json} -> J.Object json
    MCText t -> J.object ["type" .= MCText_, "text" .= t]
    MCLink {text, preview} -> J.object ["type" .= MCLink_, "text" .= text, "preview" .= preview]
    MCImage {text, image} -> J.object ["type" .= MCImage_, "text" .= text, "image" .= image]
    MCVideo {text, image, duration} -> J.object ["type" .= MCVideo_, "text" .= text, "image" .= image, "duration" .= duration]
    MCVoice {text, duration} -> J.object ["type" .= MCVoice_, "text" .= text, "duration" .= duration]
    MCFile t -> J.object ["type" .= MCFile_, "text" .= t]
    MCReport {text, reason} -> J.object ["type" .= MCReport_, "text" .= text, "reason" .= reason]
    MCChat {text, chatLink, ownerSig} -> J.object $ ("ownerSig" .=? ownerSig) ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink]
  toEncoding = \case
    MCUnknown {json} -> JE.value $ J.Object json
    MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t
    MCLink {text, preview} -> J.pairs $ "type" .= MCLink_ <> "text" .= text <> "preview" .= preview
    MCImage {text, image} -> J.pairs $ "type" .= MCImage_ <> "text" .= text <> "image" .= image
    MCVideo {text, image, duration} -> J.pairs $ "type" .= MCVideo_ <> "text" .= text <> "image" .= image <> "duration" .= duration
    MCVoice {text, duration} -> J.pairs $ "type" .= MCVoice_ <> "text" .= text <> "duration" .= duration
    MCFile t -> J.pairs $ "type" .= MCFile_ <> "text" .= t
    MCReport {text, reason} -> J.pairs $ "type" .= MCReport_ <> "text" .= text <> "reason" .= reason
    MCChat {text, chatLink, ownerSig} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink <> maybe mempty ("ownerSig" .=) ownerSig

$(JQ.deriveJSON defaultJSON ''MsgContainer)

-- this limit reserves space for metadata in forwarded messages
-- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, - 16 for block encryption ("rounded" to 15602)
maxEncodedMsgLength :: Int
maxEncodedMsgLength = 15602

-- maxEncodedMsgLength - 2222, see e2eEncUserMsgLength in agent
maxCompressedMsgLength :: Int
maxCompressedMsgLength = 13380

maxDecompressedMsgLength :: Int
maxDecompressedMsgLength = 65536

-- maxEncodedMsgLength - delta between MSG and INFO + 100 (returned for forward overhead)
-- delta between MSG and INFO = e2eEncUserMsgLength (no PQ) - e2eEncConnInfoLength (no PQ) = 1008
maxEncodedInfoLength :: Int
maxEncodedInfoLength = 14694

maxCompressedInfoLength :: Int
maxCompressedInfoLength = 10968 -- maxEncodedInfoLength - 3726, see e2eEncConnInfoLength in agent

data EncodedChatMessage = ECMEncoded ByteString | ECMLarge

encodeChatMessage :: MsgEncodingI e => Int -> ChatMessage e -> EncodedChatMessage
encodeChatMessage maxSize msg = do
  case chatToAppMessage msg of
    AMJson m -> do
      let body = LB.toStrict $ J.encode m
      if B.length body > maxSize
        then ECMLarge
        else ECMEncoded body
    AMBinary m -> ECMEncoded $ strEncode m

parseChatMessages :: ByteString -> [Either String AParsedMsg]
parseChatMessages "" = [Left "empty string"]
parseChatMessages msg = case B.head msg of
  'X' -> decodeCompressed (B.tail msg)
  c -> parseUncompressed c msg
  where
    parseUncompressed c s = case c of
      '[' -> case J.eitherDecodeStrict' s of
        Right v -> map (fmap plainMsg . parseItem) v
        Left e -> [Left e]
      '=' -> decodeBinaryBatch (B.tail s)
      _ -> [parseAll (elementP Nothing) s]
    plainMsg = aParsedMsg Nothing Nothing
    aParsedMsg fwd sm (ACMsg enc cm) = APMsg enc (ParsedMsg fwd sm cm)
    parseMsg s = ACMsg SJson <$> J.eitherDecodeStrict' s
    msgP :: A.Parser AChatMessage
    msgP = parseMsg <$?> A.takeByteString
    parseItem :: J.Value -> Either String AChatMessage
    parseItem v = ACMsg SJson <$> JT.parseEither parseJSON v
    decodeCompressed :: ByteString -> [Either String AParsedMsg]
    decodeCompressed s = case smpDecode s of
      Left e -> [Left e]
      Right (compressed :: L.NonEmpty Compressed) -> case traverse decompressedSize compressed of
        Nothing -> [Left "compressed size not specified"]
        Just sizes
          | sum sizes > maxDecompressedMsgLength -> [Left "decompressed size exceeds limit"]
          | otherwise -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1) compressed
    parseUncompressed' "" = [Left "empty string"]
    parseUncompressed' s = parseUncompressed (B.head s) s
    -- Binary batch format: '=' <count:1> (<len:2> <body>)*
    decodeBinaryBatch :: ByteString -> [Either String AParsedMsg]
    decodeBinaryBatch s = case parseAll smpListP s of
      Left e -> [Left e]
      Right msgs -> map parseBatchElement msgs
    parseBatchElement :: Large -> Either String AParsedMsg
    parseBatchElement (Large s) = parseAll (elementP Nothing) s
    elementP :: Maybe GrpMsgForward -> A.Parser AParsedMsg
    elementP fwd = A.peekChar' >>= \case
      '/' -> A.char '/' *> do
        tag <- smpP
        sigs <- smpP
        (body, acm) <- A.match msgP
        pure $ aParsedMsg fwd (Just $ SignedMsg tag sigs body) acm
      '>' -> A.char '>' *> do
        when (isJust fwd) $ fail "nested forward elements not supported"
        elementP . Just =<< smpP
      '{' -> aParsedMsg fwd Nothing <$> msgP
      -- 'F' must match BFileChunk_ tag encoding
      'F' -> aParsedMsg fwd Nothing . ACMsg SBinary <$> (appBinaryToCM <$?> strP)
      c -> fail $ "invalid element prefix: " <> show c

compressedBatchMsgBody_ :: MsgBody -> ByteString
compressedBatchMsgBody_ = markCompressedBatch . smpEncode . (L.:| []) . compress1

markCompressedBatch :: ByteString -> ByteString
markCompressedBatch = B.cons 'X'
{-# INLINE markCompressedBatch #-}

justTrue :: Bool -> Maybe Bool
justTrue True = Just True
justTrue False = Nothing

nonEmptyMap :: Map k v -> Maybe (Map k v)
nonEmptyMap m = if M.null m then Nothing else Just m
{-# INLINE nonEmptyMap #-}

instance ToField MsgContent where
  toField = toField . encodeJSON

instance FromField MsgContent where
  fromField = fromTextField_ decodeJSON

data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)

data CMEventTag (e :: MsgEncoding) where
  XMsgNew_ :: CMEventTag 'Json
  XMsgFileDescr_ :: CMEventTag 'Json
  XMsgUpdate_ :: CMEventTag 'Json
  XMsgDel_ :: CMEventTag 'Json
  XMsgDeleted_ :: CMEventTag 'Json
  XMsgReact_ :: CMEventTag 'Json
  XFile_ :: CMEventTag 'Json
  XFileAcpt_ :: CMEventTag 'Json
  XFileAcptInv_ :: CMEventTag 'Json
  XFileCancel_ :: CMEventTag 'Json
  XInfo_ :: CMEventTag 'Json
  XContact_ :: CMEventTag 'Json
  XMember_ :: CMEventTag 'Json
  XDirectDel_ :: CMEventTag 'Json
  XGrpInv_ :: CMEventTag 'Json
  XGrpAcpt_ :: CMEventTag 'Json
  XGrpLinkInv_ :: CMEventTag 'Json
  XGrpLinkReject_ :: CMEventTag 'Json
  XGrpLinkMem_ :: CMEventTag 'Json
  XGrpLinkAcpt_ :: CMEventTag 'Json
  XGrpRelayInv_ :: CMEventTag 'Json
  XGrpRelayAcpt_ :: CMEventTag 'Json
  XGrpRelayTest_ :: CMEventTag 'Json
  XGrpRelayNew_ :: CMEventTag 'Json
  XGrpRelayReject_ :: CMEventTag 'Json
  XGrpMemNew_ :: CMEventTag 'Json
  XGrpMemIntro_ :: CMEventTag 'Json
  XGrpMemInv_ :: CMEventTag 'Json
  XGrpMemFwd_ :: CMEventTag 'Json
  XGrpMemInfo_ :: CMEventTag 'Json
  XGrpMemRole_ :: CMEventTag 'Json
  XGrpMemRestrict_ :: CMEventTag 'Json
  XGrpMemCon_ :: CMEventTag 'Json
  XGrpMemConAll_ :: CMEventTag 'Json
  XGrpMemDel_ :: CMEventTag 'Json
  XGrpLeave_ :: CMEventTag 'Json
  XGrpDel_ :: CMEventTag 'Json
  XGrpInfo_ :: CMEventTag 'Json
  XGrpPrefs_ :: CMEventTag 'Json
  XGrpDirectInv_ :: CMEventTag 'Json
  XGrpMsgForward_ :: CMEventTag 'Json
  XInfoProbe_ :: CMEventTag 'Json
  XInfoProbeCheck_ :: CMEventTag 'Json
  XInfoProbeOk_ :: CMEventTag 'Json
  XCallInv_ :: CMEventTag 'Json
  XCallOffer_ :: CMEventTag 'Json
  XCallAnswer_ :: CMEventTag 'Json
  XCallExtra_ :: CMEventTag 'Json
  XCallEnd_ :: CMEventTag 'Json
  XOk_ :: CMEventTag 'Json
  XUnknown_ :: Text -> CMEventTag 'Json
  BFileChunk_ :: CMEventTag 'Binary

deriving instance Show (CMEventTag e)

deriving instance Eq (CMEventTag e)

instance MsgEncodingI e => StrEncoding (CMEventTag e) where
  strEncode = \case
    XMsgNew_ -> "x.msg.new"
    XMsgFileDescr_ -> "x.msg.file.descr"
    XMsgUpdate_ -> "x.msg.update"
    XMsgDel_ -> "x.msg.del"
    XMsgDeleted_ -> "x.msg.deleted"
    XMsgReact_ -> "x.msg.react"
    XFile_ -> "x.file"
    XFileAcpt_ -> "x.file.acpt"
    XFileAcptInv_ -> "x.file.acpt.inv"
    XFileCancel_ -> "x.file.cancel"
    XInfo_ -> "x.info"
    XContact_ -> "x.contact"
    XMember_ -> "x.member"
    XDirectDel_ -> "x.direct.del"
    XGrpInv_ -> "x.grp.inv"
    XGrpAcpt_ -> "x.grp.acpt"
    XGrpLinkInv_ -> "x.grp.link.inv"
    XGrpLinkReject_ -> "x.grp.link.reject"
    XGrpLinkMem_ -> "x.grp.link.mem"
    XGrpLinkAcpt_ -> "x.grp.link.acpt"
    XGrpRelayInv_ -> "x.grp.relay.inv"
    XGrpRelayAcpt_ -> "x.grp.relay.acpt"
    XGrpRelayTest_ -> "x.grp.relay.test"
    XGrpRelayNew_ -> "x.grp.relay.new"
    XGrpRelayReject_ -> "x.grp.relay.reject"
    XGrpMemNew_ -> "x.grp.mem.new"
    XGrpMemIntro_ -> "x.grp.mem.intro"
    XGrpMemInv_ -> "x.grp.mem.inv"
    XGrpMemFwd_ -> "x.grp.mem.fwd"
    XGrpMemInfo_ -> "x.grp.mem.info"
    XGrpMemRole_ -> "x.grp.mem.role"
    XGrpMemRestrict_ -> "x.grp.mem.restrict"
    XGrpMemCon_ -> "x.grp.mem.con"
    XGrpMemConAll_ -> "x.grp.mem.con.all"
    XGrpMemDel_ -> "x.grp.mem.del"
    XGrpLeave_ -> "x.grp.leave"
    XGrpDel_ -> "x.grp.del"
    XGrpInfo_ -> "x.grp.info"
    XGrpPrefs_ -> "x.grp.prefs"
    XGrpDirectInv_ -> "x.grp.direct.inv"
    XGrpMsgForward_ -> "x.grp.msg.forward"
    XInfoProbe_ -> "x.info.probe"
    XInfoProbeCheck_ -> "x.info.probe.check"
    XInfoProbeOk_ -> "x.info.probe.ok"
    XCallInv_ -> "x.call.inv"
    XCallOffer_ -> "x.call.offer"
    XCallAnswer_ -> "x.call.answer"
    XCallExtra_ -> "x.call.extra"
    XCallEnd_ -> "x.call.end"
    XOk_ -> "x.ok"
    XUnknown_ t -> encodeUtf8 t
    BFileChunk_ -> "F"
  strDecode = (\(ACMEventTag _ t) -> checkEncoding t) <=< strDecode
  strP = strDecode <$?> A.takeTill (== ' ')

instance StrEncoding ACMEventTag where
  strEncode (ACMEventTag _ t) = strEncode t
  strP =
    ((,) <$> A.peekChar' <*> A.takeTill (== ' ')) >>= \case
      ('x', t) -> pure . ACMEventTag SJson $ case t of
        "x.msg.new" -> XMsgNew_
        "x.msg.file.descr" -> XMsgFileDescr_
        "x.msg.update" -> XMsgUpdate_
        "x.msg.del" -> XMsgDel_
        "x.msg.deleted" -> XMsgDeleted_
        "x.msg.react" -> XMsgReact_
        "x.file" -> XFile_
        "x.file.acpt" -> XFileAcpt_
        "x.file.acpt.inv" -> XFileAcptInv_
        "x.file.cancel" -> XFileCancel_
        "x.info" -> XInfo_
        "x.contact" -> XContact_
        "x.member" -> XMember_
        "x.direct.del" -> XDirectDel_
        "x.grp.inv" -> XGrpInv_
        "x.grp.acpt" -> XGrpAcpt_
        "x.grp.link.inv" -> XGrpLinkInv_
        "x.grp.link.reject" -> XGrpLinkReject_
        "x.grp.link.mem" -> XGrpLinkMem_
        "x.grp.link.acpt" -> XGrpLinkAcpt_
        "x.grp.relay.inv" -> XGrpRelayInv_
        "x.grp.relay.acpt" -> XGrpRelayAcpt_
        "x.grp.relay.test" -> XGrpRelayTest_
        "x.grp.relay.new" -> XGrpRelayNew_
        "x.grp.relay.reject" -> XGrpRelayReject_
        "x.grp.mem.new" -> XGrpMemNew_
        "x.grp.mem.intro" -> XGrpMemIntro_
        "x.grp.mem.inv" -> XGrpMemInv_
        "x.grp.mem.fwd" -> XGrpMemFwd_
        "x.grp.mem.info" -> XGrpMemInfo_
        "x.grp.mem.role" -> XGrpMemRole_
        "x.grp.mem.restrict" -> XGrpMemRestrict_
        "x.grp.mem.con" -> XGrpMemCon_
        "x.grp.mem.con.all" -> XGrpMemConAll_
        "x.grp.mem.del" -> XGrpMemDel_
        "x.grp.leave" -> XGrpLeave_
        "x.grp.del" -> XGrpDel_
        "x.grp.info" -> XGrpInfo_
        "x.grp.prefs" -> XGrpPrefs_
        "x.grp.direct.inv" -> XGrpDirectInv_
        "x.grp.msg.forward" -> XGrpMsgForward_
        "x.info.probe" -> XInfoProbe_
        "x.info.probe.check" -> XInfoProbeCheck_
        "x.info.probe.ok" -> XInfoProbeOk_
        "x.call.inv" -> XCallInv_
        "x.call.offer" -> XCallOffer_
        "x.call.answer" -> XCallAnswer_
        "x.call.extra" -> XCallExtra_
        "x.call.end" -> XCallEnd_
        "x.ok" -> XOk_
        _ -> XUnknown_ $ safeDecodeUtf8 t
      (_, "F") -> pure $ ACMEventTag SBinary BFileChunk_
      _ -> fail "bad ACMEventTag"

toCMEventTag :: ChatMsgEvent e -> CMEventTag e
toCMEventTag msg = case msg of
  XMsgNew _ -> XMsgNew_
  XMsgFileDescr _ _ -> XMsgFileDescr_
  XMsgUpdate {} -> XMsgUpdate_
  XMsgDel {} -> XMsgDel_
  XMsgDeleted -> XMsgDeleted_
  XMsgReact {} -> XMsgReact_
  XFile _ -> XFile_
  XFileAcpt _ -> XFileAcpt_
  XFileAcptInv {} -> XFileAcptInv_
  XFileCancel _ -> XFileCancel_
  XInfo _ -> XInfo_
  XContact {} -> XContact_
  XMember {} -> XMember_
  XDirectDel -> XDirectDel_
  XGrpInv _ -> XGrpInv_
  XGrpAcpt _ -> XGrpAcpt_
  XGrpLinkInv _ -> XGrpLinkInv_
  XGrpLinkReject _ -> XGrpLinkReject_
  XGrpLinkMem _ -> XGrpLinkMem_
  XGrpLinkAcpt {} -> XGrpLinkAcpt_
  XGrpRelayInv _ -> XGrpRelayInv_
  XGrpRelayAcpt _ -> XGrpRelayAcpt_
  XGrpRelayTest {} -> XGrpRelayTest_
  XGrpRelayNew _ -> XGrpRelayNew_
  XGrpRelayReject _ -> XGrpRelayReject_
  XGrpMemNew {} -> XGrpMemNew_
  XGrpMemIntro _ _ -> XGrpMemIntro_
  XGrpMemInv _ _ -> XGrpMemInv_
  XGrpMemFwd _ _ -> XGrpMemFwd_
  XGrpMemInfo _ _ -> XGrpMemInfo_
  XGrpMemRole _ _ -> XGrpMemRole_
  XGrpMemRestrict _ _ -> XGrpMemRestrict_
  XGrpMemCon _ -> XGrpMemCon_
  XGrpMemConAll _ -> XGrpMemConAll_
  XGrpMemDel {} -> XGrpMemDel_
  XGrpLeave -> XGrpLeave_
  XGrpDel -> XGrpDel_
  XGrpInfo _ -> XGrpInfo_
  XGrpPrefs _ -> XGrpPrefs_
  XGrpDirectInv {} -> XGrpDirectInv_
  XGrpMsgForward {} -> XGrpMsgForward_
  XInfoProbe _ -> XInfoProbe_
  XInfoProbeCheck _ -> XInfoProbeCheck_
  XInfoProbeOk _ -> XInfoProbeOk_
  XCallInv _ _ -> XCallInv_
  XCallOffer _ _ -> XCallOffer_
  XCallAnswer _ _ -> XCallAnswer_
  XCallExtra _ _ -> XCallExtra_
  XCallEnd _ -> XCallEnd_
  XOk -> XOk_
  XUnknown t _ -> XUnknown_ t
  BFileChunk _ _ -> BFileChunk_

instance MsgEncodingI e => TextEncoding (CMEventTag e) where
  textEncode = decodeLatin1 . strEncode
  textDecode = eitherToMaybe . strDecode . encodeUtf8

instance TextEncoding ACMEventTag where
  textEncode (ACMEventTag _ t) = textEncode t
  textDecode = eitherToMaybe . strDecode . encodeUtf8

instance (MsgEncodingI e, Typeable e) => FromField (CMEventTag e) where fromField = fromTextField_ textDecode

instance MsgEncodingI e => ToField (CMEventTag e) where toField = toField . textEncode

instance FromField ACMEventTag where fromField = fromTextField_ textDecode

instance ToField ACMEventTag where toField = toField . textEncode

hasNotification :: CMEventTag e -> Bool
hasNotification = \case
  XMsgNew_ -> True
  XFile_ -> True
  XContact_ -> True
  XGrpInv_ -> True
  XGrpMemFwd_ -> True
  XGrpDel_ -> True
  XCallInv_ -> True
  _ -> False

hasDeliveryReceipt :: CMEventTag e -> Bool
hasDeliveryReceipt = \case
  XMsgNew_ -> True
  XGrpInv_ -> True
  XCallInv_ -> True
  _ -> False

-- | Events that must have a valid signature in relay groups.
requiresSignature :: CMEventTag e -> Bool
requiresSignature = \case
  XGrpDel_ -> True
  XGrpInfo_ -> True
  XGrpPrefs_ -> True
  XGrpMemDel_ -> True
  XGrpMemRole_ -> True
  XGrpMemRestrict_ -> True
  XGrpLeave_ -> True
  XGrpRelayNew_ -> True
  XInfo_ -> True
  _ -> False

-- TODO [relays] can be tightened — sender keys are now disseminated via
-- TODO   prepended XGrpMemNew before forwarded XInfo/XGrpLeave reach the recipient.
-- Allow signed but unverified XGrpLeave/XInfo between subscribers when sender's key is unknown.
-- Owner keys are always known, so subscribers are required to verify from owners.
-- Likewise, subscriber keys are always known to owners, so owners are required to verify from subscribers.
unverifiedAllowed :: GroupMember -> GroupMember -> CMEventTag e -> Bool
unverifiedAllowed membership member = \case
  XGrpLeave_ -> membersNoKey
  XInfo_ -> membersNoKey
  _ -> False
  where
    membersNoKey =
      memberRole' membership < GRModerator
        && memberRole' member < GRModerator
        && isNothing (memberPubKey member)

appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary)
appBinaryToCM AppMessageBinary {msgId, tag, body} = do
  eventTag <- strDecode $ B.singleton tag
  chatMsgEvent <- parseAll (msg eventTag) body
  pure ChatMessage {chatVRange = chatInitialVRange, msgId, chatMsgEvent}
  where
    msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary)
    msg = \case
      BFileChunk_ -> BFileChunk <$> (SharedMsgId <$> smpP) <*> (unIFC <$> smpP)

appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json)
appJsonToCM AppMessageJson {v, msgId, event, params} = do
  eventTag <- strDecode $ encodeUtf8 event
  chatMsgEvent <- msg eventTag
  pure ChatMessage {chatVRange = maybe chatInitialVRange fromChatVRange v, msgId, chatMsgEvent}
  where
    p :: FromJSON a => J.Key -> Either String a
    p key = JT.parseEither (.: key) params
    opt :: FromJSON a => J.Key -> Either String (Maybe a)
    opt key = JT.parseEither (.:? key) params
    msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
    msg = \case
      XMsgNew_ -> XMsgNew <$> JT.parseEither parseJSON (J.Object params)
      XMsgFileDescr_ -> XMsgFileDescr <$> p "msgId" <*> p "fileDescr"
      XMsgUpdate_ -> do
        msgId' <- p "msgId"
        content <- p "content"
        mentions <- fromMaybe M.empty <$> opt "mentions"
        ttl <- opt "ttl"
        live <- opt "live"
        scope <- opt "scope"
        asGroup <- opt "asGroup"
        pure XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup}
      XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" <*> opt "scope" <*> (fromMaybe False <$> opt "onlyHistory")
      XMsgDeleted_ -> pure XMsgDeleted
      XMsgReact_ -> XMsgReact <$> p "msgId" <*> opt "memberId" <*> opt "scope" <*> p "reaction" <*> p "add"
      XFile_ -> XFile <$> p "file"
      XFileAcpt_ -> XFileAcpt <$> p "fileName"
      XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
      XFileCancel_ -> XFileCancel <$> p "msgId"
      XInfo_ -> XInfo <$> p "profile"
      XContact_ -> do
        profile <- p "profile"
        contactReqId <- opt "contactReqId"
        welcomeMsgId <- opt "welcomeMsgId"
        reqMsgId <- opt "msgId"
        reqContent <- opt "content"
        let requestMsg = (,) <$> reqMsgId <*> reqContent
        pure XContact {profile, contactReqId, welcomeMsgId, requestMsg}
      XMember_ -> XMember <$> p "profile" <*> p "newMemberId" <*> p "newMemberKey"
      XDirectDel_ -> pure XDirectDel
      XGrpInv_ -> XGrpInv <$> p "groupInvitation"
      XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
      XGrpLinkInv_ -> XGrpLinkInv <$> p "groupLinkInvitation"
      XGrpLinkReject_ -> XGrpLinkReject <$> p "groupLinkRejection"
      XGrpLinkMem_ -> XGrpLinkMem <$> p "profile"
      XGrpLinkAcpt_ -> XGrpLinkAcpt <$> p "acceptance" <*> p "role" <*> p "memberId"
      XGrpRelayInv_ -> XGrpRelayInv <$> p "groupRelayInvitation"
      XGrpRelayAcpt_ -> XGrpRelayAcpt <$> p "relayLink"
      XGrpRelayTest_ -> do
        B64UrlByteString challenge <- p "challenge"
        sig_ <- fmap (\(B64UrlByteString s) -> s) <$> opt "signature"
        pure $ XGrpRelayTest challenge sig_
      XGrpRelayNew_ -> XGrpRelayNew <$> p "relayLink"
      XGrpRelayReject_ -> XGrpRelayReject <$> p "reason"
      XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" <*> opt "scope"
      XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions"
      XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro"
      XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro"
      XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile"
      XGrpMemRole_ -> XGrpMemRole <$> p "memberId" <*> p "role"
      XGrpMemRestrict_ -> XGrpMemRestrict <$> p "memberId" <*> p "memberRestrictions"
      XGrpMemCon_ -> XGrpMemCon <$> p "memberId"
      XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId"
      XGrpMemDel_ -> XGrpMemDel <$> p "memberId" <*> Right (fromRight False $ p "messages")
      XGrpLeave_ -> pure XGrpLeave
      XGrpDel_ -> pure XGrpDel
      XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
      XGrpPrefs_ -> XGrpPrefs <$> p "groupPreferences"
      XGrpDirectInv_ -> XGrpDirectInv <$> p "connReq" <*> opt "content" <*> opt "scope"
      XGrpMsgForward_ -> do
        fwdSender <- opt "memberId" >>= \case
          Just memberId -> FwdMember memberId . fromMaybe "" <$> opt "memberName"
          Nothing -> pure FwdChannel
        fwdBrokerTs <- p "msgTs"
        XGrpMsgForward (GrpMsgForward {fwdSender, fwdBrokerTs}) <$> p "msg"
      XInfoProbe_ -> XInfoProbe <$> p "probe"
      XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
      XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
      XCallInv_ -> XCallInv <$> p "callId" <*> p "invitation"
      XCallOffer_ -> XCallOffer <$> p "callId" <*> p "offer"
      XCallAnswer_ -> XCallAnswer <$> p "callId" <*> p "answer"
      XCallExtra_ -> XCallExtra <$> p "callId" <*> p "extra"
      XCallEnd_ -> XCallEnd <$> p "callId"
      XOk_ -> pure XOk
      XUnknown_ t -> pure $ XUnknown t params

chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of
  SBinary -> AMBinary AppMessageBinary {msgId = Nothing, tag = B.head $ strEncode tag, body = chatMsgBinaryToBody chatMsg}
  SJson -> AMJson AppMessageJson {v = Just $ ChatVersionRange chatVRange, msgId, event = textEncode tag, params = params chatMsgEvent}
  where
    tag = toCMEventTag chatMsgEvent
    o :: [(J.Key, J.Value)] -> J.Object
    o = JM.fromList
    params :: ChatMsgEvent 'Json -> J.Object
    params = \case
      XMsgNew mc -> case toJSON mc of
        J.Object obj -> obj
        _ -> JM.empty
      XMsgFileDescr msgId' fileDescr -> o ["msgId" .= msgId', "fileDescr" .= fileDescr]
      XMsgUpdate {msgId = msgId', content, mentions, ttl, live, scope, asGroup} -> o $ ("asGroup" .=? asGroup) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) $ ("mentions" .=? nonEmptyMap mentions) ["msgId" .= msgId', "content" .= content]
      XMsgDel msgId' memberId scope onlyHistory -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) $ ("onlyHistory" .=? justTrue onlyHistory) ["msgId" .= msgId']
      XMsgDeleted -> JM.empty
      XMsgReact msgId' memberId scope reaction add -> o $ ("memberId" .=? memberId) $ ("scope" .=? scope) ["msgId" .= msgId', "reaction" .= reaction, "add" .= add]
      XFile fileInv -> o ["file" .= fileInv]
      XFileAcpt fileName -> o ["fileName" .= fileName]
      XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
      XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
      XInfo profile -> o ["profile" .= profile]
      XContact {profile, contactReqId, welcomeMsgId, requestMsg} -> o $ ("contactReqId" .=? contactReqId) $ ("welcomeMsgId" .=? welcomeMsgId) $ ("msgId" .=? (fst <$> requestMsg)) $ ("content" .=? (snd <$> requestMsg)) $ ["profile" .= profile]
      XMember {profile, newMemberId, newMemberKey} -> o ["profile" .= profile, "newMemberId" .= newMemberId, "newMemberKey" .= newMemberKey]
      XDirectDel -> JM.empty
      XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
      XGrpAcpt memId -> o ["memberId" .= memId]
      XGrpLinkInv groupLinkInv -> o ["groupLinkInvitation" .= groupLinkInv]
      XGrpLinkReject groupLinkRjct -> o ["groupLinkRejection" .= groupLinkRjct]
      XGrpLinkMem profile -> o ["profile" .= profile]
      XGrpLinkAcpt acceptance role memberId -> o ["acceptance" .= acceptance, "role" .= role, "memberId" .= memberId]
      XGrpRelayInv groupRelayInv -> o ["groupRelayInvitation" .= groupRelayInv]
      XGrpRelayAcpt relayLink -> o ["relayLink" .= relayLink]
      XGrpRelayTest challenge sig_ -> o $
        ("signature" .=? (B64UrlByteString <$> sig_))
        ["challenge" .= B64UrlByteString challenge]
      XGrpRelayNew relayLink -> o ["relayLink" .= relayLink]
      XGrpRelayReject reason -> o ["reason" .= reason]
      XGrpMemNew memInfo scope -> o $ ("scope" .=? scope) ["memberInfo" .= memInfo]
      XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo]
      XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro]
      XGrpMemFwd memInfo memIntro -> o ["memberInfo" .= memInfo, "memberIntro" .= memIntro]
      XGrpMemInfo memId profile -> o ["memberId" .= memId, "profile" .= profile]
      XGrpMemRole memId role -> o ["memberId" .= memId, "role" .= role]
      XGrpMemRestrict memId memRestrictions -> o ["memberId" .= memId, "memberRestrictions" .= memRestrictions]
      XGrpMemCon memId -> o ["memberId" .= memId]
      XGrpMemConAll memId -> o ["memberId" .= memId]
      XGrpMemDel memId messages -> o $ ("messages" .=? if messages then Just True else Nothing) ["memberId" .= memId]
      XGrpLeave -> JM.empty
      XGrpDel -> JM.empty
      XGrpInfo p -> o ["groupProfile" .= p]
      XGrpPrefs p -> o ["groupPreferences" .= p]
      XGrpDirectInv connReq content scope -> o $ ("content" .=? content) $ ("scope" .=? scope) ["connReq" .= connReq]
      XGrpMsgForward GrpMsgForward {fwdSender, fwdBrokerTs} msg -> o $ encodeFwdSender fwdSender ["msg" .= msg, "msgTs" .= fwdBrokerTs]
        where
          encodeFwdSender = \case
            FwdMember memberId memberName -> (["memberId" .= memberId, "memberName" .= memberName] ++)
            FwdChannel -> id
      XInfoProbe probe -> o ["probe" .= probe]
      XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
      XInfoProbeOk probe -> o ["probe" .= probe]
      XCallInv callId inv -> o ["callId" .= callId, "invitation" .= inv]
      XCallOffer callId offer -> o ["callId" .= callId, "offer" .= offer]
      XCallAnswer callId answer -> o ["callId" .= callId, "answer" .= answer]
      XCallExtra callId extra -> o ["callId" .= callId, "extra" .= extra]
      XCallEnd callId -> o ["callId" .= callId]
      XOk -> JM.empty
      XUnknown _ ps -> ps

chatMsgBinaryToBody :: ChatMessage 'Binary -> ByteString
chatMsgBinaryToBody ChatMessage {chatMsgEvent} = case chatMsgEvent of
  BFileChunk (SharedMsgId msgId) chunk -> smpEncode (msgId, IFC chunk)

chatMsgToBody :: forall e. MsgEncodingI e => ChatMessage e -> ByteString
chatMsgToBody chatMsg = case encoding @e of
  SBinary -> chatMsgBinaryToBody chatMsg
  SJson -> LB.toStrict $ J.encode chatMsg

verifiedChatMsg :: VerifiedMsg e -> ChatMessage e
verifiedChatMsg = \case
  VMUnsigned cm -> cm
  VMSigned _ _ cm -> cm

-- | Canonical bytes to store/forward, with optional signature.
-- Signed: original bytes (re-encoding would invalidate signature).
-- Unsigned: re-encoded from parsed ChatMessage (sanitizes stored content).
verifiedMsgParts :: MsgEncodingI e => VerifiedMsg e -> (Maybe MsgSigStatus, Maybe SignedMsg, ByteString)
verifiedMsgParts = \case
  VMUnsigned chatMsg -> (Nothing, Nothing, chatMsgToBody chatMsg)
  VMSigned s sm@SignedMsg {signedBody} _ -> (Just s, Just sm, signedBody)


instance ToJSON (ChatMessage 'Json) where
  toJSON = (\(AMJson msg) -> toJSON msg) . chatToAppMessage

instance FromJSON (ChatMessage 'Json) where
  parseJSON v = appJsonToCM <$?> parseJSON v

instance FromField (ChatMessage 'Json) where
  fromField = blobFieldDecoder J.eitherDecodeStrict'

data ContactShortLinkData = ContactShortLinkData
  { profile :: Profile,
    message :: Maybe MsgContent,
    business :: Bool
  }
  deriving (Show)

data PublicGroupData = PublicGroupData
  { publicMemberCount :: Int64
  }
  deriving (Eq, Show)

data GroupShortLinkData = GroupShortLinkData
  { groupProfile :: GroupProfile,
    publicGroupData :: Maybe PublicGroupData
  }
  deriving (Show)

$(JQ.deriveJSON defaultJSON ''ContactShortLinkData)

$(JQ.deriveJSON defaultJSON ''PublicGroupData)

$(JQ.deriveJSON defaultJSON ''GroupShortLinkData)

data RelayShortLinkData = RelayShortLinkData
  { relayProfile :: Profile
  }
  deriving (Show)

$(JQ.deriveJSON defaultJSON ''RelayShortLinkData)

data RelayProfile = RelayProfile
  { displayName :: ContactName,
    fullName :: Text,
    shortDescr :: Maybe Text,
    image :: Maybe ImageData
  }
  deriving (Eq, Show)

$(JQ.deriveJSON defaultJSON ''RelayProfile)

toRelayProfile :: (ContactName, Text, Maybe Text, Maybe ImageData) -> RelayProfile
toRelayProfile (displayName, fullName, shortDescr, image) = RelayProfile {displayName, fullName, shortDescr, image}

mkRelayProfile :: ContactName -> Maybe ImageData -> RelayProfile
mkRelayProfile displayName image = RelayProfile {displayName, fullName = "", shortDescr = Nothing, image}

data RelayAddressLinkData = RelayAddressLinkData {relayProfile :: RelayProfile}
  deriving (Show)

$(JQ.deriveJSON defaultJSON ''RelayAddressLinkData)