module Wire.API.MLS.Validation
(
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
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
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"
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))
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
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
(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"