content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Simplex.RemoteControl.Invitation
    ( RCInvitation (..)
    , signInvitation
    , RCSignedInvitation (..)
    , verifySignedInvitation
    , RCVerifiedInvitation (..)
    , RCEncInvitation (..)
    ) where
  
  import qualified Data.Aeson as J
  import qualified Data.Attoparsec.ByteString.Char8 as A
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as LB
  import Data.Time.Clock.System (SystemTime)
  import Data.Word (Word16)
  import Network.HTTP.Types (parseSimpleQuery)
  import Network.HTTP.Types.URI (SimpleQuery, renderSimpleQuery, urlDecode)
  import qualified Simplex.Messaging.Crypto as C
  import Simplex.Messaging.Encoding
  import Simplex.Messaging.Encoding.String
  import Simplex.Messaging.Parsers (parseAll)
  import Simplex.Messaging.Transport.Client (TransportHost)
  import Simplex.RemoteControl.Types (VersionRangeRCP)
  
  data RCInvitation = RCInvitation
    { -- | CA TLS certificate fingerprint of the controller.
      --
      -- This is part of long term identity of the controller established during the first session, and repeated in the subsequent session announcements.
      ca :: C.KeyHash,
      host :: TransportHost,
      port :: Word16,
      -- | Supported version range for remote control protocol
      v :: VersionRangeRCP,
      -- | Application information
      app :: J.Value,
      -- | Session start time in seconds since epoch
      ts :: SystemTime,
      -- | Session Ed25519 public key used to verify the announcement and commands
      --
      -- This mitigates the compromise of the long term signature key, as the controller will have to sign each command with this key first.
      skey :: C.PublicKeyEd25519,
      -- | Long-term Ed25519 public key used to verify the announcement and commands.
      --
      -- Is apart of the long term controller identity.
      idkey :: C.PublicKeyEd25519,
      -- | Session X25519 DH key
      dh :: C.PublicKeyX25519
    }
    deriving (Show)
  
  instance StrEncoding RCInvitation where
    strEncode RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh} =
      mconcat
        [ "xrcp:/",
          strEncode ca,
          "@",
          strEncode host,
          ":",
          strEncode port,
          "#/?",
          renderSimpleQuery False query
        ]
      where
        query =
          [ ("v", strEncode v),
            ("app", LB.toStrict $ J.encode app),
            ("ts", strEncode ts),
            ("skey", strEncode skey),
            ("idkey", strEncode idkey),
            ("dh", strEncode dh)
          ]
  
    strP = do
      _ <- A.string "xrcp:/"
      ca <- strP
      _ <- A.char '@'
      host <- A.takeWhile (/= ':') >>= either fail pure . strDecode . urlDecode True
      _ <- A.char ':'
      port <- strP
      _ <- A.string "#/?"
  
      q <- parseSimpleQuery <$> A.takeWhile (/= ' ')
      v <- requiredP q "v" strDecode
      app <- requiredP q "app" $ J.eitherDecodeStrict . urlDecode True
      ts <- requiredP q "ts" $ strDecode . urlDecode True
      skey <- requiredP q "skey" $ parseAll strP
      idkey <- requiredP q "idkey" $ parseAll strP
      dh <- requiredP q "dh" $ parseAll strP
      pure RCInvitation {ca, host, port, v, app, ts, skey, idkey, dh}
  
  data RCSignedInvitation = RCSignedInvitation
    { invitation :: RCInvitation,
      ssig :: C.Signature 'C.Ed25519,
      idsig :: C.Signature 'C.Ed25519
    }
    deriving (Show)
  
  -- | URL-encoded and signed for showing in QR code
  instance StrEncoding RCSignedInvitation where
    strEncode RCSignedInvitation {invitation, ssig, idsig} =
      mconcat
        [ strEncode invitation,
          "&ssig=",
          strEncode $ C.signatureBytes ssig,
          "&idsig=",
          strEncode $ C.signatureBytes idsig
        ]
  
    strP = do
      -- TODO this assumes some order or parameters, can be made independent
      (url, invitation) <- A.match strP
      sigs <- case B.breakSubstring "&ssig=" url of
        (_, sigs) | B.null sigs -> fail "missing signatures"
        (_, sigs) -> pure $ parseSimpleQuery $ B.drop 1 sigs
      ssig <- requiredP sigs "ssig" $ parseAll strP
      idsig <- requiredP sigs "idsig" $ parseAll strP
      pure RCSignedInvitation {invitation, ssig, idsig}
  
  signInvitation :: C.PrivateKey 'C.Ed25519 -> C.PrivateKey 'C.Ed25519 -> RCInvitation -> RCSignedInvitation
  signInvitation sKey idKey invitation = RCSignedInvitation {invitation, ssig, idsig}
    where
      uri = strEncode invitation
      ssig =
        case C.sign (C.APrivateSignKey C.SEd25519 sKey) uri of
          C.ASignature C.SEd25519 s -> s
          _ -> error "signing with ed25519"
      inviteUrlSigned = mconcat [uri, "&ssig=", strEncode ssig]
      idsig =
        case C.sign (C.APrivateSignKey C.SEd25519 idKey) inviteUrlSigned of
          C.ASignature C.SEd25519 s -> s
          _ -> error "signing with ed25519"
  
  newtype RCVerifiedInvitation = RCVerifiedInvitation RCInvitation
    deriving (Show)
  
  verifySignedInvitation :: RCSignedInvitation -> Maybe RCVerifiedInvitation
  verifySignedInvitation RCSignedInvitation {invitation, ssig, idsig} =
    if C.verify' skey ssig inviteURL && C.verify' idkey idsig inviteURLS
      then Just $ RCVerifiedInvitation invitation
      else Nothing
    where
      RCInvitation {skey, idkey} = invitation
      inviteURL = strEncode invitation
      inviteURLS = mconcat [inviteURL, "&ssig=", strEncode ssig]
  
  data RCEncInvitation = RCEncInvitation
    { dhPubKey :: C.PublicKeyX25519,
      nonce :: C.CbNonce,
      encInvitation :: ByteString
    }
  
  instance Encoding RCEncInvitation where
    smpEncode RCEncInvitation {dhPubKey, nonce, encInvitation} =
      smpEncode (dhPubKey, nonce, Tail encInvitation)
    smpP = do
      (dhPubKey, nonce, Tail encInvitation) <- smpP
      pure RCEncInvitation {dhPubKey, nonce, encInvitation}
  
  -- * Utils
  
  requiredP :: MonadFail m => SimpleQuery -> ByteString -> (ByteString -> Either String a) -> m a
  requiredP q k f = maybe (fail $ "missing " <> show k) (either fail pure . f) $ lookup k q
  