-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Wire.API.MLS.Validation
  ( -- * Main key package validation function
    validateKeyPackage,
    validateLeafNode,
  )
where

import Control.Applicative
import Control.Error.Util
import Data.ByteArray qualified as BA
import Data.Text qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Builder qualified as LT
import Data.Text.Lazy.Builder.Int qualified as LT
import Data.X509 qualified as X509
import Imports
import Wire.API.MLS.Capabilities
import Wire.API.MLS.CipherSuite
import Wire.API.MLS.Credential
import Wire.API.MLS.KeyPackage
import Wire.API.MLS.LeafNode
import Wire.API.MLS.Lifetime
import Wire.API.MLS.ProtocolVersion
import Wire.API.MLS.Serialisation

validateKeyPackage ::
  Maybe ClientIdentity ->
  KeyPackage ->
  Either Text (CipherSuiteTag, Lifetime)
validateKeyPackage :: Maybe ClientIdentity
-> KeyPackage -> Either Text (CipherSuiteTag, Lifetime)
validateKeyPackage Maybe ClientIdentity
mIdentity KeyPackage
kp = do
  -- get ciphersuite
  CipherSuiteTag
cs <-
    Either Text CipherSuiteTag
-> (CipherSuiteTag -> Either Text CipherSuiteTag)
-> Maybe CipherSuiteTag
-> Either Text CipherSuiteTag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      ( Text -> Either Text CipherSuiteTag
forall a b. a -> Either a b
Left
          ( Text
"Unsupported ciphersuite 0x"
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
LT.toStrict (Builder -> Text
LT.toLazyText (Word16 -> Builder
forall a. Integral a => a -> Builder
LT.hexadecimal KeyPackage
kp.cipherSuite.cipherSuiteNumber))
          )
      )
      CipherSuiteTag -> Either Text CipherSuiteTag
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Maybe CipherSuiteTag -> Either Text CipherSuiteTag)
-> Maybe CipherSuiteTag -> Either Text CipherSuiteTag
forall a b. (a -> b) -> a -> b
$ CipherSuite -> Maybe CipherSuiteTag
cipherSuiteTag KeyPackage
kp.cipherSuite

  -- validate signature
  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    ( CipherSuiteTag
-> ByteString
-> ByteString
-> RawMLS KeyPackageTBS
-> ByteString
-> Bool
forall a.
CipherSuiteTag
-> ByteString -> ByteString -> RawMLS a -> ByteString -> Bool
csVerifySignatureWithLabel
        CipherSuiteTag
cs
        KeyPackage
kp.leafNode.signatureKey
        ByteString
"KeyPackageTBS"
        KeyPackage
kp.tbs
        KeyPackage
kp.signature_
    )
    (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Invalid KeyPackage signature"

  -- validate protocol version
  Either Text ()
-> (() -> Either Text ()) -> Maybe () -> Either Text ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Unsupported protocol version")
    () -> Either Text ()
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (ProtocolVersion -> Maybe ProtocolVersionTag
pvTag (KeyPackage
kp.protocolVersion) Maybe ProtocolVersionTag
-> (ProtocolVersionTag -> Maybe ()) -> Maybe ()
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> (ProtocolVersionTag -> Bool) -> ProtocolVersionTag -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtocolVersionTag -> ProtocolVersionTag -> Bool
forall a. Eq a => a -> a -> Bool
== ProtocolVersionTag
ProtocolMLS10))

  -- validate credential, lifetime and capabilities
  CipherSuiteTag
-> Maybe ClientIdentity
-> LeafNodeTBSExtra
-> LeafNode
-> Either Text ()
validateLeafNode CipherSuiteTag
cs Maybe ClientIdentity
mIdentity LeafNodeTBSExtra
LeafNodeTBSExtraKeyPackage KeyPackage
kp.leafNode

  Lifetime
lt <- case KeyPackage
kp.leafNode.source of
    LeafNodeSourceKeyPackage Lifetime
lt -> Lifetime -> Either Text Lifetime
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lifetime
lt
    -- unreachable
    LeafNodeSource
_ -> Text -> Either Text Lifetime
forall a b. a -> Either a b
Left Text
"Unexpected leaf node source"

  (CipherSuiteTag, Lifetime)
-> Either Text (CipherSuiteTag, Lifetime)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CipherSuiteTag
cs, Lifetime
lt)

validateLeafNode ::
  CipherSuiteTag ->
  Maybe ClientIdentity ->
  LeafNodeTBSExtra ->
  LeafNode ->
  Either Text ()
validateLeafNode :: CipherSuiteTag
-> Maybe ClientIdentity
-> LeafNodeTBSExtra
-> LeafNode
-> Either Text ()
validateLeafNode CipherSuiteTag
cs Maybe ClientIdentity
mIdentity LeafNodeTBSExtra
extra LeafNode
leafNode = do
  let tbs :: LeafNodeTBS
tbs = RawMLS LeafNodeCore -> LeafNodeTBSExtra -> LeafNodeTBS
LeafNodeTBS LeafNode
leafNode.core LeafNodeTBSExtra
extra
  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    ( CipherSuiteTag
-> ByteString
-> ByteString
-> RawMLS LeafNodeTBS
-> ByteString
-> Bool
forall a.
CipherSuiteTag
-> ByteString -> ByteString -> RawMLS a -> ByteString -> Bool
csVerifySignatureWithLabel
        CipherSuiteTag
cs
        LeafNode
leafNode.signatureKey
        ByteString
"LeafNodeTBS"
        (LeafNodeTBS -> RawMLS LeafNodeTBS
forall a. SerialiseMLS a => a -> RawMLS a
mkRawMLS LeafNodeTBS
tbs)
        LeafNode
leafNode.signature_
    )
    (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Invalid LeafNode signature"

  CipherSuiteTag
-> ByteString
-> Maybe ClientIdentity
-> Credential
-> Either Text ()
validateCredential CipherSuiteTag
cs LeafNode
leafNode.signatureKey Maybe ClientIdentity
mIdentity LeafNode
leafNode.credential
  LeafNodeSourceTag -> LeafNodeSource -> Either Text ()
validateSource LeafNodeTBSExtra
extra.tag LeafNode
leafNode.source
  CredentialTag -> Capabilities -> Either Text ()
validateCapabilities (Credential -> CredentialTag
credentialTag LeafNode
leafNode.credential) LeafNode
leafNode.capabilities

validateCredential :: CipherSuiteTag -> ByteString -> Maybe ClientIdentity -> Credential -> Either Text ()
validateCredential :: CipherSuiteTag
-> ByteString
-> Maybe ClientIdentity
-> Credential
-> Either Text ()
validateCredential CipherSuiteTag
cs ByteString
pkey Maybe ClientIdentity
mIdentity Credential
cred = do
  -- FUTUREWORK: check signature in the case of an x509 credential
  (ClientIdentity
identity, Maybe PubKey
mkey) <-
    (Text -> Either Text (ClientIdentity, Maybe PubKey))
-> ((ClientIdentity, Maybe PubKey)
    -> Either Text (ClientIdentity, Maybe PubKey))
-> Either Text (ClientIdentity, Maybe PubKey)
-> Either Text (ClientIdentity, Maybe PubKey)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Either Text (ClientIdentity, Maybe PubKey)
forall {a} {b}. (Semigroup a, IsString a) => a -> Either a b
credentialError (ClientIdentity, Maybe PubKey)
-> Either Text (ClientIdentity, Maybe PubKey)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (ClientIdentity, Maybe PubKey)
 -> Either Text (ClientIdentity, Maybe PubKey))
-> Either Text (ClientIdentity, Maybe PubKey)
-> Either Text (ClientIdentity, Maybe PubKey)
forall a b. (a -> b) -> a -> b
$
      Credential -> Either Text (ClientIdentity, Maybe PubKey)
credentialIdentityAndKey Credential
cred
  (PubKey -> Either Text ()) -> Maybe PubKey -> Either Text ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (SignatureSchemeTag -> ByteString -> PubKey -> Either Text ()
validateCredentialKey (CipherSuiteTag -> SignatureSchemeTag
csSignatureScheme CipherSuiteTag
cs) ByteString
pkey) Maybe PubKey
mkey
  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (ClientIdentity -> Bool) -> Maybe ClientIdentity -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ClientIdentity
identity ==) Maybe ClientIdentity
mIdentity) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
    Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"client identity does not match credential identity"
  where
    credentialError :: a -> Either a b
credentialError a
e =
      a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> a -> Either a b
forall a b. (a -> b) -> a -> b
$
        a
"Failed to parse identity: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
e

validateCredentialKey :: SignatureSchemeTag -> ByteString -> X509.PubKey -> Either Text ()
validateCredentialKey :: SignatureSchemeTag -> ByteString -> PubKey -> Either Text ()
validateCredentialKey SignatureSchemeTag
Ed25519 ByteString
pk1 (X509.PubKeyEd25519 PublicKey
pk2) = ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS ByteString
pk1 (PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert PublicKey
pk2)
validateCredentialKey SignatureSchemeTag
Ecdsa_secp256r1_sha256 ByteString
pk1 (X509.PubKeyEC PubKeyEC
pk2) =
  case PubKeyEC
pk2.pubkeyEC_pub of
    X509.SerializedPoint ByteString
bs -> ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS ByteString
pk1 ByteString
bs
validateCredentialKey SignatureSchemeTag
Ecdsa_secp384r1_sha384 ByteString
pk1 (X509.PubKeyEC PubKeyEC
pk2) =
  case PubKeyEC
pk2.pubkeyEC_pub of
    X509.SerializedPoint ByteString
bs -> ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS ByteString
pk1 ByteString
bs
validateCredentialKey SignatureSchemeTag
Ecdsa_secp521r1_sha512 ByteString
pk1 (X509.PubKeyEC PubKeyEC
pk2) =
  case PubKeyEC
pk2.pubkeyEC_pub of
    X509.SerializedPoint ByteString
bs -> ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS ByteString
pk1 ByteString
bs
validateCredentialKey SignatureSchemeTag
ss ByteString
_ PubKey
_ =
  Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$
    Text
"Certificate signature scheme " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (SignatureSchemeTag -> String
forall a. Show a => a -> String
show SignatureSchemeTag
ss) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" does not match client's public key"

validateCredentialKeyBS :: ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS :: ByteString -> ByteString -> Either Text ()
validateCredentialKeyBS ByteString
pk1 ByteString
pk2 =
  Text -> Maybe () -> Either Text ()
forall a b. a -> Maybe b -> Either a b
note Text
"Certificate public key does not match client's" (Maybe () -> Either Text ()) -> Maybe () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString
pk1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pk2)

validateSource :: LeafNodeSourceTag -> LeafNodeSource -> Either Text ()
validateSource :: LeafNodeSourceTag -> LeafNodeSource -> Either Text ()
validateSource LeafNodeSourceTag
t LeafNodeSource
s = do
  let t' :: LeafNodeSourceTag
t' = LeafNodeSource -> LeafNodeSourceTag
leafNodeSourceTag LeafNodeSource
s
  if LeafNodeSourceTag
t LeafNodeSourceTag -> LeafNodeSourceTag -> Bool
forall a. Eq a => a -> a -> Bool
== LeafNodeSourceTag
t'
    then () -> Either Text ()
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    else
      Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$
        Text
"Expected '"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeafNodeSourceTag
t.name
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' source, got '"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeafNodeSourceTag
t'.name
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"

validateCapabilities :: CredentialTag -> Capabilities -> Either Text ()
validateCapabilities :: CredentialTag -> Capabilities -> Either Text ()
validateCapabilities CredentialTag
ctag Capabilities
caps =
  Bool -> Either Text () -> Either Text ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CredentialTag -> Word16
forall w a. (Integral w, Enum a) => a -> w
fromMLSEnum CredentialTag
ctag Word16 -> [Word16] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Capabilities
caps.credentials) (Either Text () -> Either Text ())
-> Either Text () -> Either Text ()
forall a b. (a -> b) -> a -> b
$
    Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"missing BasicCredential capability"