mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-06-07 19:42:13 +00:00
Evgeny @ SimpleX Chat
70 lines
2.8 KiB
Haskell
70 lines
2.8 KiB
Haskell
{-# 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 credentials = (C.KeyHash rootFP, (X509.CertificateChain certs, privateToTls $ snd leafKey))
|
|
where
|
|
Fingerprint rootFP = getFingerprint root X509.HashSHA256
|
|
leafKey = fst $ L.head credentials
|
|
root = snd $ L.last credentials
|
|
certs = map snd $ L.toList credentials
|
|
|
|
privateToTls :: C.APrivateSignKey -> TLS.PrivKey
|
|
privateToTls (C.APrivateSignKey _ k) = case k of
|
|
C.PrivateKeyEd25519 pk -> TLS.PrivKeyEd25519 pk
|
|
C.PrivateKeyEd448 pk -> TLS.PrivKeyEd448 pk
|
|
|
|
type Credentials = (C.ASignatureKeyPair, X509.SignedCertificate)
|
|
|
|
-- spec: spec/modules/Simplex/Messaging/Transport/Credentials.md#gencredentials--nanosecond-stripping
|
|
genCredentials :: TVar ChaChaDRG -> Maybe Credentials -> (Hours, Hours) -> Text -> IO Credentials
|
|
genCredentials g parent (before, after) subjectName = do
|
|
subjectKeys <- atomically $ C.generateSignatureKeyPair C.SEd25519 g
|
|
let (issuerKeys, issuer) = case parent of
|
|
Nothing -> (subjectKeys, subject) -- self-signed
|
|
Just (keys, cert) -> (keys, X509.certSubjectDN . X509.signedObject $ X509.getSigned cert)
|
|
today <- Hourglass.dateCurrent
|
|
-- remove nanoseconds from time - certificate encoding/decoding removes them.
|
|
let today' = today {HT.dtTime = (HT.dtTime today) {HT.todNSec = 0}}
|
|
signed =
|
|
C.signCertificate
|
|
(snd issuerKeys)
|
|
X509.Certificate
|
|
{ certVersion = 2,
|
|
certSerial = 1,
|
|
certSignatureAlg = C.signatureAlgorithmX509 issuerKeys,
|
|
certIssuerDN = issuer,
|
|
certValidity = (timeAdd today' (-before), timeAdd today' after),
|
|
certSubjectDN = subject,
|
|
certPubKey = C.toPubKey C.publicToX509 $ fst subjectKeys,
|
|
certExtensions = X509.Extensions Nothing
|
|
}
|
|
pure (subjectKeys, signed)
|
|
where
|
|
subject = dn $ X509.ASN1CharacterString {characterEncoding = UTF8, getCharacterStringRawData = encodeUtf8 subjectName}
|
|
dn dnCommonName = X509.DistinguishedName [(getObjectID X509.DnCommonName, dnCommonName)]
|