{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}

module Simplex.Messaging.Transport.Credentials
  ( tlsCredentials,
    Credentials,
    genCredentials,
    C.signCertificate,
  )
where

import Control.Concurrent.STM
import Crypto.Random (ChaChaDRG)
import Data.ASN1.Types (getObjectID)
import Data.ASN1.Types.String (ASN1StringEncoding (UTF8))
import Data.Hourglass (Hours (..), timeAdd)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as L
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.X509 as X509
import Data.X509.Validation (Fingerprint (..), getFingerprint)
import qualified Network.TLS as TLS
import qualified Simplex.Messaging.Crypto as C
import qualified Time.System as Hourglass
import qualified Time.Types as HT

tlsCredentials :: NonEmpty Credentials -> (C.KeyHash, TLS.Credential)
tlsCredentials :: NonEmpty Credentials -> (KeyHash, Credential)
tlsCredentials NonEmpty Credentials
credentials = (ByteString -> KeyHash
C.KeyHash ByteString
rootFP, ([SignedExact Certificate] -> CertificateChain
X509.CertificateChain [SignedExact Certificate]
certs, APrivateSignKey -> PrivKey
privateToTls (APrivateSignKey -> PrivKey) -> APrivateSignKey -> PrivKey
forall a b. (a -> b) -> a -> b
$ (APublicVerifyKey, APrivateSignKey) -> APrivateSignKey
forall a b. (a, b) -> b
snd (APublicVerifyKey, APrivateSignKey)
leafKey))
  where
    Fingerprint ByteString
rootFP = SignedExact Certificate -> HashALG -> Fingerprint
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> HashALG -> Fingerprint
getFingerprint SignedExact Certificate
root HashALG
X509.HashSHA256
    leafKey :: (APublicVerifyKey, APrivateSignKey)
leafKey = ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> (APublicVerifyKey, APrivateSignKey)
forall a b. (a, b) -> a
fst (((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
 -> (APublicVerifyKey, APrivateSignKey))
-> ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> (APublicVerifyKey, APrivateSignKey)
forall a b. (a -> b) -> a -> b
$ NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
forall a. NonEmpty a -> a
L.head NonEmpty Credentials
NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
credentials
    root :: SignedExact Certificate
root = ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> SignedExact Certificate
forall a b. (a, b) -> b
snd (((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
 -> SignedExact Certificate)
-> ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> SignedExact Certificate
forall a b. (a -> b) -> a -> b
$ NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
forall a. NonEmpty a -> a
L.last NonEmpty Credentials
NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
credentials
    certs :: [SignedExact Certificate]
certs = (((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
 -> SignedExact Certificate)
-> [((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)]
-> [SignedExact Certificate]
forall a b. (a -> b) -> [a] -> [b]
map ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> SignedExact Certificate
forall a b. (a, b) -> b
snd ([((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)]
 -> [SignedExact Certificate])
-> [((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)]
-> [SignedExact Certificate]
forall a b. (a -> b) -> a -> b
$ NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> [((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)]
forall a. NonEmpty a -> [a]
L.toList NonEmpty Credentials
NonEmpty
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
credentials

privateToTls :: C.APrivateSignKey -> TLS.PrivKey
privateToTls :: APrivateSignKey -> PrivKey
privateToTls (C.APrivateSignKey SAlgorithm a
_ PrivateKey a
k) = case PrivateKey a
k of
  C.PrivateKeyEd25519 SecretKey
pk -> SecretKey -> PrivKey
TLS.PrivKeyEd25519 SecretKey
pk
  C.PrivateKeyEd448 SecretKey
pk -> SecretKey -> PrivKey
TLS.PrivKeyEd448 SecretKey
pk

type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)

genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
genCredentials :: TVar ChaChaDRG
-> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
genCredentials TVar ChaChaDRG
g Maybe Credentials
parent (Hours
before, Hours
after) Text
subjectName = do
  (APublicVerifyKey, APrivateSignKey)
subjectKeys <- STM ASignatureKeyPair -> IO ASignatureKeyPair
forall a. STM a -> IO a
atomically (STM ASignatureKeyPair -> IO ASignatureKeyPair)
-> STM ASignatureKeyPair -> IO ASignatureKeyPair
forall a b. (a -> b) -> a -> b
$ SAlgorithm 'Ed25519 -> TVar ChaChaDRG -> STM ASignatureKeyPair
forall (a :: Algorithm).
(AlgorithmI a, SignatureAlgorithm a) =>
SAlgorithm a -> TVar ChaChaDRG -> STM ASignatureKeyPair
C.generateSignatureKeyPair SAlgorithm 'Ed25519
C.SEd25519 TVar ChaChaDRG
g
  let ((APublicVerifyKey, APrivateSignKey)
issuerKeys, DistinguishedName
issuer) = case Maybe Credentials
parent of
        Maybe Credentials
Nothing -> ((APublicVerifyKey, APrivateSignKey)
subjectKeys, DistinguishedName
subject) -- self-signed
        Just (ASignatureKeyPair
keys, SignedExact Certificate
cert) -> (ASignatureKeyPair
(APublicVerifyKey, APrivateSignKey)
keys, Certificate -> DistinguishedName
X509.certSubjectDN (Certificate -> DistinguishedName)
-> (Signed Certificate -> Certificate)
-> Signed Certificate
-> DistinguishedName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signed Certificate -> Certificate
forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X509.signedObject (Signed Certificate -> DistinguishedName)
-> Signed Certificate -> DistinguishedName
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Signed Certificate
forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned SignedExact Certificate
cert)
  DateTime
today <- IO DateTime
Hourglass.dateCurrent
  -- remove nanoseconds from time - certificate encoding/decoding removes them.
  let today' :: DateTime
today' = DateTime
today {HT.dtTime = (HT.dtTime today) {HT.todNSec = 0}}
      signed :: SignedExact Certificate
signed =
        APrivateSignKey -> Certificate -> SignedExact Certificate
C.signCertificate
          ((APublicVerifyKey, APrivateSignKey) -> APrivateSignKey
forall a b. (a, b) -> b
snd (APublicVerifyKey, APrivateSignKey)
issuerKeys)
          X509.Certificate
            { certVersion :: Int
certVersion = Int
2,
              certSerial :: Integer
certSerial = Integer
1,
              certSignatureAlg :: SignatureALG
certSignatureAlg = (APublicVerifyKey, APrivateSignKey) -> SignatureALG
forall a. SignatureAlgorithmX509 a => a -> SignatureALG
C.signatureAlgorithmX509 (APublicVerifyKey, APrivateSignKey)
issuerKeys,
              certIssuerDN :: DistinguishedName
certIssuerDN = DistinguishedName
issuer,
              certValidity :: (DateTime, DateTime)
certValidity = (DateTime -> Hours -> DateTime
forall t ti. (Time t, TimeInterval ti) => t -> ti -> t
timeAdd DateTime
today' (-Hours
before), DateTime -> Hours -> DateTime
forall t ti. (Time t, TimeInterval ti) => t -> ti -> t
timeAdd DateTime
today' Hours
after),
              certSubjectDN :: DistinguishedName
certSubjectDN = DistinguishedName
subject,
              certPubKey :: PubKey
certPubKey = (forall (a :: Algorithm). AlgorithmI a => PublicKey a -> PubKey)
-> APublicVerifyKey -> PubKey
forall k b.
CryptoPublicKey k =>
(forall (a :: Algorithm). AlgorithmI a => PublicKey a -> b)
-> k -> b
forall b.
(forall (a :: Algorithm). AlgorithmI a => PublicKey a -> b)
-> APublicVerifyKey -> b
C.toPubKey PublicKey a -> PubKey
forall (a :: Algorithm). PublicKey a -> PubKey
forall (a :: Algorithm). AlgorithmI a => PublicKey a -> PubKey
C.publicToX509 (APublicVerifyKey -> PubKey) -> APublicVerifyKey -> PubKey
forall a b. (a -> b) -> a -> b
$ (APublicVerifyKey, APrivateSignKey) -> APublicVerifyKey
forall a b. (a, b) -> a
fst (APublicVerifyKey, APrivateSignKey)
subjectKeys,
              certExtensions :: Extensions
certExtensions = Maybe [ExtensionRaw] -> Extensions
X509.Extensions Maybe [ExtensionRaw]
forall a. Maybe a
Nothing
            }
  ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
-> IO
     ((APublicVerifyKey, APrivateSignKey), SignedExact Certificate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((APublicVerifyKey, APrivateSignKey)
subjectKeys, SignedExact Certificate
signed)
  where
    subject :: DistinguishedName
subject = ASN1CharacterString -> DistinguishedName
dn (ASN1CharacterString -> DistinguishedName)
-> ASN1CharacterString -> DistinguishedName
forall a b. (a -> b) -> a -> b
$ X509.ASN1CharacterString {characterEncoding :: ASN1StringEncoding
characterEncoding = ASN1StringEncoding
UTF8, getCharacterStringRawData :: ByteString
getCharacterStringRawData = Text -> ByteString
encodeUtf8 Text
subjectName}
    dn :: ASN1CharacterString -> DistinguishedName
dn ASN1CharacterString
dnCommonName = [(OID, ASN1CharacterString)] -> DistinguishedName
X509.DistinguishedName [(DnElement -> OID
forall a. OIDable a => a -> OID
getObjectID DnElement
X509.DnCommonName, ASN1CharacterString
dnCommonName)]