ClientCert.hs

   1 -- This file is part of Diohsc
   2 -- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP               #-}
  12 {-# LANGUAGE LambdaCase        #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14
  15 module ClientCert where
  16
  17 import           Control.Applicative      (liftA2)
  18 import           Crypto.Hash.Algorithms   (SHA256 (..))
  19 import           Crypto.PubKey.RSA
  20 import           Crypto.PubKey.RSA.PKCS15
  21 import           Data.ASN1.OID
  22 import           Data.ASN1.Types.String   (ASN1StringEncoding (UTF8))
  23 import           Data.Either              (fromRight)
  24 import           Data.Hourglass
  25 import           Data.PEM
  26 import           Data.X509
  27 import           Network.TLS              (PrivKey (PrivKeyRSA))
  28 import           Safe
  29 import           System.FilePath
  30 import           Time.System
  31
  32 import qualified Data.ByteString          as BS
  33 import qualified Data.Text                as TS
  34 import qualified Data.Text.Encoding       as TS
  35
  36 import           Fingerprint
  37 import           Mundanities
  38 import           Util
  39
  40 #ifndef WINDOWS
  41 import           System.Posix.Files
  42 #endif
  43
  44 -- |Certificate chain with secret key for tail cert
  45 data ClientCert = ClientCert CertificateChain PrivKey
  46     deriving (Eq,Show)
  47
  48 clientCertFingerprint :: ClientCert -> Fingerprint
  49 clientCertFingerprint (ClientCert (CertificateChain chain) _) =
  50     fingerprint $ head chain
  51
  52 loadClientCert :: FilePath -> String -> IO (Maybe ClientCert)
  53 loadClientCert path name =
  54     let certpath = path </> name <.> "crt"
  55         keypath = path </> name <.> "rsa"
  56     in ignoreIOErrAlt $ do
  57         chain <- (\case
  58             Right pems -> case decodeCertificateChain . CertificateChainRaw $ map pemContent pems of
  59                 Right chain -> Just chain
  60                 _           -> Nothing
  61             _ -> Nothing) . pemParseBS <$> BS.readFile certpath
  62         key <- (PrivKeyRSA <$>) . readMay <$> readFile keypath
  63         return $ liftA2 ClientCert chain key
  64
  65 saveClientCert :: FilePath -> String -> ClientCert -> IO ()
  66 saveClientCert path name (ClientCert chain (PrivKeyRSA key)) =
  67     let filepath = path </> name
  68         certpath = filepath <.> "crt"
  69         keypath = filepath <.> "rsa"
  70     in isSubPath path filepath >>? ignoreIOErr $ do
  71         let CertificateChainRaw rawCerts = encodeCertificateChain chain
  72             chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts
  73         BS.writeFile certpath $ BS.intercalate "\n" chainPEMs
  74         writeFile keypath $ show key
  75 #ifndef WINDOWS
  76         setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
  77 #endif
  78 saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type"
  79
  80 -- |generate 2048bit RSA key with (-1y,+2y) validity
  81 -- FIXME: these choices fingerprint the client
  82 generateSelfSigned :: String -> IO ClientCert
  83 generateSelfSigned cn = do
  84     (pubKey, secKey) <- generate 256 65537
  85     blinder <- generateBlinder $ public_n pubKey
  86     currentTime <- timeConvert <$> timeCurrent
  87     let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
  88         sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA
  89         to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 2, periodMonths = 0, periodDays = 0}
  90         from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0}
  91         cert = Certificate
  92             { certVersion = 3
  93             , certSerial = 0
  94             , certSignatureAlg = sigAlg
  95             , certIssuerDN = dn
  96             , certSubjectDN = dn
  97             , certValidity = (from, to)
  98             , certPubKey = PubKeyRSA pubKey
  99             , certExtensions = Extensions Nothing
 100             }
 101         signed = fst $ objectToSignedExact
 102             (\b -> (fromRight BS.empty $ sign (Just blinder) (Just SHA256) secKey b, sigAlg, ()))
 103             cert
 104     return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey)
 105
 106 {- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for
 107 -- gemini, we should use this?
 108 import qualified Data.ByteArray as BA
 109
 110 generateSelfSigned :: String -> IO ClientCert
 111 generateSelfSigned cn = do
 112     secKey <- generateSecretKey
 113     currentTime <- timeConvert <$> timeCurrent
 114     let pubKey = toPublic secKey
 115         dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
 116         sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
 117         -- TODO: think about correct validity dates
 118         to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 1, periodMonths = 0, periodDays = 0}
 119         from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0}
 120         cert = Certificate
 121             { certVersion = 3
 122             , certSerial = 0
 123             , certSignatureAlg = sigAlg
 124             , certIssuerDN = dn
 125             , certSubjectDN = dn
 126             , certValidity = (from, to)
 127             , certPubKey = PubKeyEd25519 pubKey
 128             , certExtensions = Extensions Nothing
 129             }
 130         signed = fst $ objectToSignedExact
 131             (\b -> (BS.pack . BA.unpack $ sign secKey pubKey b, sigAlg, ()))
 132             cert
 133     return (CertificateChain [signed], PrivKeyEd25519 secKey)
 134 -}