TLS 1.3 client authentication in the client side

core/Network/TLS/Extension.hs

@@ -46,7 +46,7 @@ module Network.TLS.Extension
     , HeartBeat(..)
     , HeartBeatMode(..)
     , SignatureAlgorithms(..)
-    , SignatureAlgorithmsCert
+    , SignatureAlgorithmsCert(..)
     , SupportedVersions(..)
     , KeyShare(..)
     , KeyShareEntry(..)
@@ -57,18 +57,29 @@ module Network.TLS.Extension
     , PreSharedKey(..)
     , EarlyDataIndication(..)
     , Cookie(..)
+    , CertificateAuthorities(..)
     ) where
 
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BC
 
-import Network.TLS.Struct (ExtensionID, EnumSafe8(..), EnumSafe16(..), HashAndSignatureAlgorithm)
+import Network.TLS.Struct ( DistinguishedName
+                          , ExtensionID
+                          , EnumSafe8(..)
+                          , EnumSafe16(..)
+                          , HashAndSignatureAlgorithm )
 import Network.TLS.Crypto.Types
 import Network.TLS.Types (Version(..))
 
 import Network.TLS.Wire
 import Network.TLS.Imports
-import Network.TLS.Packet (putSignatureHashAlgorithm, getSignatureHashAlgorithm, putBinaryVersion, getBinaryVersion)
+import Network.TLS.Packet ( putDNames
+                          , getDNames
+                          , putSignatureHashAlgorithm
+                          , getSignatureHashAlgorithm
+                          , putBinaryVersion
+                          , getBinaryVersion
+                          )
 
 type HostName = String
 
@@ -175,6 +186,14 @@ definedExtensions =
     , extensionID_EncryptThenMAC
     , extensionID_ExtendedMasterSecret
     , extensionID_SessionTicket
+    , extensionID_PreSharedKey
+    , extensionID_EarlyData
+    , extensionID_SupportedVersions
+    , extensionID_Cookie
+    , extensionID_PskKeyExchangeModes
+    , extensionID_KeyShare
+    , extensionID_SignatureAlgorithmsCert
+    , extensionID_CertificateAuthorities
     , extensionID_SecureRenegotiation
     ]
 
@@ -187,19 +206,22 @@ supportedExtensions = [ extensionID_ServerName
                       , extensionID_NegotiatedGroups
                       , extensionID_EcPointFormats
                       , extensionID_SignatureAlgorithms
+                      , extensionID_SignatureAlgorithmsCert
                       , extensionID_KeyShare
                       , extensionID_PreSharedKey
                       , extensionID_EarlyData
                       , extensionID_SupportedVersions
                       , extensionID_Cookie
                       , extensionID_PskKeyExchangeModes
+                      , extensionID_CertificateAuthorities
                       ]
 
 data MessageType = MsgTClientHello
                  | MsgTServerHello
                  | MsgTHelloRetryRequest
                  | MsgTEncryptedExtensions
                  | MsgTNewSessionTicket
+                 | MsgTCertificateRequest
                  deriving (Eq,Show)
 
 -- | Extension class to transform bytes to and from a high level Extension type.
@@ -514,9 +536,25 @@ instance Extension EarlyDataIndication where
         return (EarlyDataIndication (Just w32))
     extensionDecode _                       = fail "extensionDecode: EarlyDataIndication"
 
+------------------------------------------------------------
+
 newtype Cookie = Cookie ByteString deriving (Eq, Show)
 
 instance Extension Cookie where
     extensionID _ = extensionID_Cookie
     extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque
     extensionDecode _ = runGetMaybe (Cookie <$> getOpaque16)
+
+------------------------------------------------------------
+
+newtype CertificateAuthorities = CertificateAuthorities [DistinguishedName]
+    deriving (Eq, Show)
+
+instance Extension CertificateAuthorities where
+    extensionID _ = extensionID_CertificateAuthorities
+    extensionEncode (CertificateAuthorities names) = runPut $
+        putDNames names
+    extensionDecode MsgTCertificateRequest =
+       runGetMaybe (CertificateAuthorities <$> getDNames)
+    extensionDecode msgt =
+        fail $ "unexpected CertificateAuthorities extension in: " ++ show msgt

core/Network/TLS/Packet.hs

@@ -63,6 +63,8 @@ module Network.TLS.Packet
     , putExtension
     , getExtensions
     , putSession
+    , putDNames
+    , getDNames
     ) where
 
 import Network.TLS.Imports
@@ -262,21 +264,27 @@ decodeCertRequest cp = do
     sigHashAlgs <- if cParamsVersion cp >= TLS12
                        then Just <$> (getWord16 >>= getSignatureHashAlgorithms)
                        else return Nothing
+    dNames <- getDNames
+    return $ CertRequest certTypes sigHashAlgs dNames
+  where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))
+
+-- | Decode a list CA distinguished names
+getDNames :: Get [DistinguishedName]
+getDNames = do
     dNameLen <- getWord16
     -- FIXME: Decide whether to remove this check completely or to make it an option.
     -- when (cParamsVersion cp < TLS12 && dNameLen < 3) $ fail "certrequest distinguishname not of the correct size"
-    dNames <- getList (fromIntegral dNameLen) getDName
-    return $ CertRequest certTypes sigHashAlgs dNames
-  where getSignatureHashAlgorithms len = getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))
-        getDName = do
-            dName <- getOpaque16
-            when (B.length dName == 0) $ fail "certrequest: invalid DN length"
-            dn <- case decodeASN1' DER dName of
-                    Left e      -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e)
-                    Right asn1s -> case fromASN1 asn1s of
-                                        Left e      -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e)
-                                        Right (d,_) -> return d
-            return (2 + B.length dName, dn)
+    getList (fromIntegral dNameLen) getDName
+  where
+    getDName = do
+        dName <- getOpaque16
+        when (B.length dName == 0) $ fail "certrequest: invalid DN length"
+        dn <- case decodeASN1' DER dName of
+                Left e      -> fail ("cert request decoding DistinguishedName ASN1 failed: " ++ show e)
+                Right asn1s -> case fromASN1 asn1s of
+                                    Left e      -> fail ("cert request parsing DistinguishedName ASN1 failed: " ++ show e)
+                                    Right (d,_) -> return d
+        return (2 + B.length dName, dn)
 
 decodeCertVerify :: CurrentParams -> Get Handshake
 decodeCertVerify cp = CertVerify <$> getDigitallySigned (cParamsVersion cp)
@@ -404,21 +412,25 @@ encodeHandshakeContent (CertRequest certTypes sigAlgs certAuthorities) = do
     case sigAlgs of
         Nothing -> return ()
         Just l  -> putWords16 $ map (\(x,y) -> fromIntegral (valOfType x) * 256 + fromIntegral (valOfType y)) l
-    encodeCertAuthorities certAuthorities
-  where -- Convert a distinguished name to its DER encoding.
-        encodeCA dn = return $ encodeASN1' DER (toASN1 dn []) --B.concat $ L.toChunks $ encodeDN dn
-
-        -- Encode a list of distinguished names.
-        encodeCertAuthorities certAuths = do
-            enc <- mapM encodeCA certAuths
-            let totLength = sum $ map ((+) 2 . B.length) enc
-            putWord16 (fromIntegral totLength)
-            mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc
+    putDNames certAuthorities
 
 encodeHandshakeContent (CertVerify digitallySigned) = putDigitallySigned digitallySigned
 
 encodeHandshakeContent (Finished opaque) = putBytes opaque
 
+------------------------------------------------------------
+
+-- | Encode a list of distinguished names.
+putDNames :: [DistinguishedName] -> Put
+putDNames dnames = do
+    enc <- mapM encodeCA dnames
+    let totLength = sum $ map ((+) 2 . B.length) enc
+    putWord16 (fromIntegral totLength)
+    mapM_ (\ b -> putWord16 (fromIntegral (B.length b)) >> putBytes b) enc
+  where
+    -- Convert a distinguished name to its DER encoding.
+    encodeCA dn = return $ encodeASN1' DER (toASN1 dn [])
+
 {- FIXME make sure it return error if not 32 available -}
 getRandom32 :: Get ByteString
 getRandom32 = getBytes 32

core/Network/TLS/Packet13.hs

@@ -50,6 +50,9 @@ encodeHandshake13' (ServerHello13 random session cipherId exts) = runPut $ do
     putWord8 0
     putExtensions exts
 encodeHandshake13' (EncryptedExtensions13 exts) = runPut $ putExtensions exts
+encodeHandshake13' (CertRequest13 reqctx exts) = runPut $ do
+    putOpaque8 reqctx
+    putExtensions exts
 encodeHandshake13' (Certificate13 reqctx cc ess) = runPut $ do
     putOpaque8 reqctx
     putOpaque24 (runPut $ mapM_ putCert $ zip certs ess)
@@ -95,6 +98,7 @@ decodeHandshake13 :: HandshakeType13 -> ByteString -> Either TLSError Handshake1
 decodeHandshake13 ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of
     HandshakeType_Finished13            -> decodeFinished13
     HandshakeType_EncryptedExtensions13 -> decodeEncryptedExtensions13
+    HandshakeType_CertRequest13         -> decodeCertRequest13
     HandshakeType_Certificate13         -> decodeCertificate13
     HandshakeType_CertVerify13          -> decodeCertVerify13
     HandshakeType_NewSessionTicket13    -> decodeNewSessionTicket13
@@ -109,6 +113,13 @@ decodeEncryptedExtensions13 = EncryptedExtensions13 <$> do
     len <- fromIntegral <$> getWord16
     getExtensions len
 
+decodeCertRequest13 :: Get Handshake13
+decodeCertRequest13 = do
+    reqctx <- getOpaque8
+    len <- fromIntegral <$> getWord16
+    exts <- getExtensions len
+    return $ CertRequest13 reqctx exts
+
 decodeCertificate13 :: Get Handshake13
 decodeCertificate13 = do
     reqctx <- getOpaque8