-- | libp2p identity certificates for QUIC's mutual TLS handshake.
module LibP2P.Transport.QUIC.Certificate
  ( newQUICCredential
  , verifyQUICCertificate
  , verifyQUICCertificateAt
  , libp2pExtensionOID
  ) where

import qualified Crypto.Error as CE
import qualified Crypto.PubKey.Ed25519 as Ed25519
import Crypto.Random (getRandomBytes)
import Data.ASN1.BinaryEncoding (DER (..))
import Data.ASN1.Encoding (decodeASN1', encodeASN1')
import Data.ASN1.Types (ASN1 (..), ASN1ConstructionType (..), OID, toASN1)
import Data.ByteArray (convert)
import Data.ByteString (ByteString)
import Data.Hourglass (Date (..), DateTime (..), Month (..), TimeOfDay (..), timeConvert)
import Data.X509
  ( Certificate (..)
  , CertificateChain (..)
  , DistinguishedName (..)
  , ExtensionRaw (..)
  , Extensions (..)
  , PrivKey (..)
  , PubKey (..)
  , PubKeyALG (..)
  , SignatureALG (..)
  , SignedCertificate
  , getSigned
  , objectToSignedExact
  , signedObject
  )
import Data.X509.Validation
  ( SignatureVerification (..)
  , verifySignedSignature
  )
import LibP2P.Crypto.Key (KeyPair (..), sign, verify)
import LibP2P.Crypto.PeerId (PeerId, fromPublicKey)
import qualified LibP2P.Crypto.Protobuf as Protobuf
import Network.TLS (Credential)
import Time.System (timeCurrent)

-- | IANA private enterprise extension assigned to libp2p.
libp2pExtensionOID :: OID
libp2pExtensionOID :: OID
libp2pExtensionOID = [Integer
1, Integer
3, Integer
6, Integer
1, Integer
4, Integer
1, Integer
53594, Integer
1, Integer
1]

identitySignaturePrefix :: ByteString
identitySignaturePrefix :: ByteString
identitySignaturePrefix = ByteString
"libp2p-tls-handshake:"

certificateSignatureAlgorithm :: SignatureALG
certificateSignatureAlgorithm :: SignatureALG
certificateSignatureAlgorithm = PubKeyALG -> SignatureALG
SignatureALG_IntrinsicHash PubKeyALG
PubKeyALG_Ed25519

-- | Generate an ephemeral self-signed Ed25519 certificate bound to a host key.
newQUICCredential :: KeyPair -> IO Credential
newQUICCredential :: KeyPair -> IO Credential
newQUICCredential KeyPair
identity = do
  seed <- Int -> IO ByteString
forall byteArray. ByteArray byteArray => Int -> IO byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
32 :: IO ByteString
  tlsSecret <- case CE.eitherCryptoError (Ed25519.secretKey seed) of
    Left CryptoError
err -> String -> IO SecretKey
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO SecretKey) -> String -> IO SecretKey
forall a b. (a -> b) -> a -> b
$ String
"newQUICCredential: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> CryptoError -> String
forall a. Show a => a -> String
show CryptoError
err
    Right SecretKey
key -> SecretKey -> IO SecretKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SecretKey
key
  let tlsPublic = SecretKey -> PublicKey
Ed25519.toPublic SecretKey
tlsSecret
      certificatePublic = PublicKey -> PubKey
PubKeyEd25519 PublicKey
tlsPublic
      spki = DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER (PubKey -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 PubKey
certificatePublic [])
  identitySignature <- either fail pure $
    sign (kpPrivate identity) (identitySignaturePrefix <> spki)
  let extension = ExtensionRaw
        { extRawOID :: OID
extRawOID = OID
libp2pExtensionOID
        , extRawCritical :: Bool
extRawCritical = Bool
True
        , extRawContent :: ByteString
extRawContent = ByteString -> ByteString -> ByteString
encodeSignedKey (PublicKey -> ByteString
Protobuf.encodePublicKey (KeyPair -> PublicKey
kpPublic KeyPair
identity)) ByteString
identitySignature
        }
      certificate = PubKey -> ExtensionRaw -> Certificate
makeCertificate PubKey
certificatePublic ExtensionRaw
extension
      signCertificate ba
bytes =
        ( Signature -> a
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (SecretKey -> PublicKey -> ba -> Signature
forall ba.
ByteArrayAccess ba =>
SecretKey -> PublicKey -> ba -> Signature
Ed25519.sign SecretKey
tlsSecret PublicKey
tlsPublic ba
bytes)
        , SignatureALG
certificateSignatureAlgorithm
        , ()
        )
      (signedCertificate, ()) = objectToSignedExact signCertificate certificate
  pure (CertificateChain [signedCertificate], PrivKeyEd25519 tlsSecret)

-- | Verify a peer's one-certificate chain against the current time and
-- recover its authenticated Peer ID.
verifyQUICCertificate :: CertificateChain -> IO (Either String PeerId)
verifyQUICCertificate :: CertificateChain -> IO (Either String PeerId)
verifyQUICCertificate CertificateChain
chain = do
  now <- IO Elapsed
timeCurrent
  pure $ verifyQUICCertificateAt (timeConvert now) chain

-- | Verify a peer's one-certificate chain as of the given UTC time.
verifyQUICCertificateAt :: DateTime -> CertificateChain -> Either String PeerId
verifyQUICCertificateAt :: DateTime -> CertificateChain -> Either String PeerId
verifyQUICCertificateAt DateTime
now (CertificateChain [SignedExact Certificate
signedCertificate]) =
  DateTime -> SignedExact Certificate -> Either String PeerId
verifyCertificate DateTime
now SignedExact Certificate
signedCertificate
verifyQUICCertificateAt DateTime
_ CertificateChain
_ =
  String -> Either String PeerId
forall a b. a -> Either a b
Left String
"QUIC certificate chain must contain exactly one certificate"

verifyCertificate :: DateTime -> SignedCertificate -> Either String PeerId
verifyCertificate :: DateTime -> SignedExact Certificate -> Either String PeerId
verifyCertificate DateTime
now SignedExact Certificate
signedCertificate = do
  let certificate :: Certificate
certificate = Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
signedObject (SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
getSigned SignedExact Certificate
signedCertificate)
  Bool -> String -> Either String ()
require (Certificate -> DistinguishedName
certIssuerDN Certificate
certificate DistinguishedName -> DistinguishedName -> Bool
forall a. Eq a => a -> a -> Bool
== Certificate -> DistinguishedName
certSubjectDN Certificate
certificate)
    String
"QUIC certificate is not self-signed"
  case SignedExact Certificate -> PubKey -> SignatureVerification
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> PubKey -> SignatureVerification
verifySignedSignature SignedExact Certificate
signedCertificate (Certificate -> PubKey
certPubKey Certificate
certificate) of
    SignatureVerification
SignaturePass -> () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SignatureFailed SignatureFailure
_ -> String -> Either String ()
forall a b. a -> Either a b
Left String
"QUIC certificate self-signature verification failed"
  -- The TLS spec requires the certificate to be valid when it is received.
  let (DateTime
notBefore, DateTime
notAfter) = Certificate -> (DateTime, DateTime)
certValidity Certificate
certificate
  Bool -> String -> Either String ()
require (DateTime
now DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DateTime
notBefore) String
"QUIC certificate is not yet valid"
  Bool -> String -> Either String ()
require (DateTime
now DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
<= DateTime
notAfter) String
"QUIC certificate has expired"
  -- The TLS spec permits this extension to be critical or non-critical.
  extension <- Extensions -> Either String ExtensionRaw
findIdentityExtension (Certificate -> Extensions
certExtensions Certificate
certificate)
  (encodedHostKey, identitySignature) <- decodeSignedKey (extRawContent extension)
  hostKey <- Protobuf.decodePublicKey encodedHostKey
  let spki = DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER (PubKey -> ASN1S
forall a. ASN1Object a => a -> ASN1S
toASN1 (Certificate -> PubKey
certPubKey Certificate
certificate) [])
  require (verify hostKey (identitySignaturePrefix <> spki) identitySignature)
    "QUIC certificate host-key signature verification failed"
  pure (fromPublicKey hostKey)

findIdentityExtension :: Extensions -> Either String ExtensionRaw
findIdentityExtension :: Extensions -> Either String ExtensionRaw
findIdentityExtension (Extensions Maybe [ExtensionRaw]
maybeExtensions) = do
  let extensions :: [ExtensionRaw]
extensions = [ExtensionRaw]
-> ([ExtensionRaw] -> [ExtensionRaw])
-> Maybe [ExtensionRaw]
-> [ExtensionRaw]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> a
id Maybe [ExtensionRaw]
maybeExtensions
      unknownCritical :: [ExtensionRaw]
unknownCritical = (ExtensionRaw -> Bool) -> [ExtensionRaw] -> [ExtensionRaw]
forall a. (a -> Bool) -> [a] -> [a]
filter ExtensionRaw -> Bool
isUnknownCritical [ExtensionRaw]
extensions
      identities :: [ExtensionRaw]
identities = (ExtensionRaw -> Bool) -> [ExtensionRaw] -> [ExtensionRaw]
forall a. (a -> Bool) -> [a] -> [a]
filter ((OID -> OID -> Bool
forall a. Eq a => a -> a -> Bool
== OID
libp2pExtensionOID) (OID -> Bool) -> (ExtensionRaw -> OID) -> ExtensionRaw -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtensionRaw -> OID
extRawOID) [ExtensionRaw]
extensions
  Bool -> String -> Either String ()
require ([ExtensionRaw] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ExtensionRaw]
unknownCritical) String
"QUIC certificate contains an unknown critical extension"
  case [ExtensionRaw]
identities of
    [ExtensionRaw
extension] -> ExtensionRaw -> Either String ExtensionRaw
forall a b. b -> Either a b
Right ExtensionRaw
extension
    [] -> String -> Either String ExtensionRaw
forall a b. a -> Either a b
Left String
"QUIC certificate is missing the libp2p identity extension"
    [ExtensionRaw]
_ -> String -> Either String ExtensionRaw
forall a b. a -> Either a b
Left String
"QUIC certificate contains multiple libp2p identity extensions"

isUnknownCritical :: ExtensionRaw -> Bool
isUnknownCritical :: ExtensionRaw -> Bool
isUnknownCritical ExtensionRaw
extension =
  ExtensionRaw -> Bool
extRawCritical ExtensionRaw
extension Bool -> Bool -> Bool
&& ExtensionRaw -> OID
extRawOID ExtensionRaw
extension OID -> [OID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [OID]
recognizedCriticalOIDs

recognizedCriticalOIDs :: [OID]
recognizedCriticalOIDs :: [OID]
recognizedCriticalOIDs =
  [ OID
libp2pExtensionOID
  , [Integer
2, Integer
5, Integer
29, Integer
14] -- subject key identifier
  , [Integer
2, Integer
5, Integer
29, Integer
15] -- key usage
  , [Integer
2, Integer
5, Integer
29, Integer
17] -- subject alternative name
  , [Integer
2, Integer
5, Integer
29, Integer
19] -- basic constraints
  , [Integer
2, Integer
5, Integer
29, Integer
35] -- authority key identifier
  , [Integer
2, Integer
5, Integer
29, Integer
37] -- extended key usage
  ]

encodeSignedKey :: ByteString -> ByteString -> ByteString
encodeSignedKey :: ByteString -> ByteString -> ByteString
encodeSignedKey ByteString
publicKey ByteString
signature =
  DER -> [ASN1] -> ByteString
forall a. ASN1Encoding a => a -> [ASN1] -> ByteString
encodeASN1' DER
DER
    [ ASN1ConstructionType -> ASN1
Start ASN1ConstructionType
Sequence
    , ByteString -> ASN1
OctetString ByteString
publicKey
    , ByteString -> ASN1
OctetString ByteString
signature
    , ASN1ConstructionType -> ASN1
End ASN1ConstructionType
Sequence
    ]

decodeSignedKey :: ByteString -> Either String (ByteString, ByteString)
decodeSignedKey :: ByteString -> Either String (ByteString, ByteString)
decodeSignedKey ByteString
bytes = case DER -> ByteString -> Either ASN1Error [ASN1]
forall a.
ASN1Decoding a =>
a -> ByteString -> Either ASN1Error [ASN1]
decodeASN1' DER
DER ByteString
bytes of
  Left ASN1Error
err -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left (String -> Either String (ByteString, ByteString))
-> String -> Either String (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ String
"invalid libp2p certificate extension: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ASN1Error -> String
forall a. Show a => a -> String
show ASN1Error
err
  Right [Start ASN1ConstructionType
Sequence, OctetString ByteString
publicKey, OctetString ByteString
signature, End ASN1ConstructionType
Sequence] ->
    (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString
publicKey, ByteString
signature)
  Right [ASN1]
_ -> String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left String
"invalid libp2p certificate extension structure"

makeCertificate :: PubKey -> ExtensionRaw -> Certificate
makeCertificate :: PubKey -> ExtensionRaw -> Certificate
makeCertificate PubKey
publicKey ExtensionRaw
extension = Certificate
  { certVersion :: Int
certVersion = Int
2
  , certSerial :: Integer
certSerial = Integer
1
  , certSignatureAlg :: SignatureALG
certSignatureAlg = SignatureALG
certificateSignatureAlgorithm
  , certIssuerDN :: DistinguishedName
certIssuerDN = [(OID, ASN1CharacterString)] -> DistinguishedName
DistinguishedName []
  , certValidity :: (DateTime, DateTime)
certValidity = (DateTime
notBefore, DateTime
notAfter)
  , certSubjectDN :: DistinguishedName
certSubjectDN = [(OID, ASN1CharacterString)] -> DistinguishedName
DistinguishedName []
  , certPubKey :: PubKey
certPubKey = PubKey
publicKey
  , certExtensions :: Extensions
certExtensions = Maybe [ExtensionRaw] -> Extensions
Extensions ([ExtensionRaw] -> Maybe [ExtensionRaw]
forall a. a -> Maybe a
Just [ExtensionRaw
extension])
  }
  where
    notBefore :: DateTime
notBefore = Date -> TimeOfDay -> DateTime
DateTime (Int -> Month -> Int -> Date
Date Int
1970 Month
January Int
1) (Hours -> Minutes -> Seconds -> NanoSeconds -> TimeOfDay
TimeOfDay Hours
0 Minutes
0 Seconds
0 NanoSeconds
0)
    notAfter :: DateTime
notAfter = Date -> TimeOfDay -> DateTime
DateTime (Int -> Month -> Int -> Date
Date Int
4096 Month
January Int
1) (Hours -> Minutes -> Seconds -> NanoSeconds -> TimeOfDay
TimeOfDay Hours
0 Minutes
0 Seconds
0 NanoSeconds
0)

require :: Bool -> String -> Either String ()
require :: Bool -> String -> Either String ()
require Bool
True String
_ = () -> Either String ()
forall a b. b -> Either a b
Right ()
require Bool
False String
message = String -> Either String ()
forall a b. a -> Either a b
Left String
message