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 OverloadedStrings #-}
  13
  14 module ClientCert where
  15
  16 import           Control.Monad             ((<=<))
  17 import           Control.Monad.Trans       (lift)
  18 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
  19 import           Crypto.Hash.Algorithms    (SHA256 (..))
  20 import           Crypto.PubKey.RSA
  21 import           Data.ASN1.BinaryEncoding  (DER (..))
  22 import           Data.ASN1.Encoding        (decodeASN1', encodeASN1')
  23 import           Data.ASN1.OID
  24 import           Data.ASN1.Types           (ASN1Object (..))
  25 import           Data.ASN1.Types.String    (ASN1StringEncoding (UTF8))
  26 import           Data.Either               (fromRight)
  27 import           Data.Foldable             (msum)
  28 import           Data.Hourglass
  29 import           Data.PEM
  30 import           Data.X509
  31 import           Safe
  32 import           System.FilePath
  33
  34 import qualified Crypto.PubKey.Ed25519     as Ed25519
  35 import qualified Crypto.PubKey.RSA.PKCS15  as PKCS15
  36 import qualified Data.ByteArray            as BA
  37 import qualified Data.ByteString           as BS
  38 import qualified Data.Text                 as TS
  39 import qualified Data.Text.Encoding        as TS
  40
  41 import           Fingerprint
  42 import           Mundanities
  43 import           Util
  44
  45 #ifndef WINDOWS
  46 import           System.Posix.Files
  47 #endif
  48
  49 -- |Certificate chain with secret key for tail cert
  50 data ClientCert = ClientCert CertificateChain PrivKey
  51     deriving (Eq,Show)
  52
  53 clientCertFingerprint :: ClientCert -> Fingerprint
  54 clientCertFingerprint (ClientCert (CertificateChain chain) _) =
  55     fingerprint $ head chain
  56
  57 maybeRight :: Either a b -> Maybe b
  58 maybeRight (Left _)  = Nothing
  59 maybeRight (Right b) = Just b
  60
  61 loadClientCert :: FilePath -> String -> IO (Maybe ClientCert)
  62 loadClientCert path name =
  63     let certpath = path </> name <.> "crt"
  64         legacyKeypath = path </> name <.> "rsa"
  65         keypath = path </> name <.> "key"
  66     in ignoreIOErrAlt . runMaybeT $ do
  67         chain <- MaybeT $
  68             (maybeRight . decodeCertificateChain . CertificateChainRaw . map pemContent
  69                 <=< maybeRight . pemParseBS)
  70             <$> BS.readFile certpath
  71         key <- msum
  72             [ MaybeT $ (maybeRight . (fst <$>) . fromASN1
  73                     <=< maybeRight . decodeASN1' DER . pemContent
  74                     <=< headMay
  75                     <=< maybeRight . pemParseBS)
  76                 <$> ignoreIOErr (BS.readFile keypath)
  77             , do
  78                 -- Legacy private rsa key format: Show instance of PrivateKey
  79                 key <- MaybeT $ (PrivKeyRSA <$>) . readMay <$> ignoreIOErr (readFile legacyKeypath)
  80                 -- Upgrade to standard format
  81                 lift . saveClientCert path name $ ClientCert chain key
  82                 return key
  83             ]
  84         return $ ClientCert chain key
  85
  86 saveClientCert :: FilePath -> String -> ClientCert -> IO ()
  87 saveClientCert path name (ClientCert chain key) =
  88     let filepath = path </> name
  89         certpath = filepath <.> "crt"
  90         keypath = filepath <.> "key"
  91     in isSubPath path filepath >>? ignoreIOErr $ do
  92         let CertificateChainRaw rawCerts = encodeCertificateChain chain
  93             chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts
  94         BS.writeFile certpath $ BS.intercalate "\n" chainPEMs
  95         let header = case key of
  96                 -- Use the header string the openssl commandline tool expects:
  97                 PrivKeyRSA _ -> "RSA PRIVATE KEY"
  98                 _            -> "PRIVATE KEY"
  99         BS.writeFile keypath . pemWriteBS . PEM header [] . encodeDER $ key
 100 #ifndef WINDOWS
 101         setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
 102 #endif
 103     where
 104     encodeDER :: ASN1Object o => o -> BS.ByteString
 105     encodeDER = encodeASN1' DER . (`toASN1` [])
 106
 107 -- RFC5280: To indicate that a certificate has no well-defined expiration
 108 -- date, the notAfter SHOULD be assigned the GeneralizedTime value of
 109 -- 99991231235959Z.
 110 notAfterMax :: DateTime
 111 notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0)
 112
 113 -- RFC5280 has no corresponding prescription for notBefore, but
 114 -- 19500101000000Z seems the canonical choice.
 115 notBeforeMin :: DateTime
 116 notBeforeMin = DateTime (Date 1950 January 1) (TimeOfDay 0 0 0 0)
 117
 118 data KeyType = KeyRSA | KeyEd25519
 119
 120 generateSelfSigned :: KeyType -> String -> IO ClientCert
 121 generateSelfSigned tp cn =
 122     let dn = DistinguishedName [(getObjectID DnCommonName,
 123             ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
 124         sigAlg = case tp of
 125             KeyRSA     -> SignatureALG HashSHA256 PubKeyALG_RSA
 126             KeyEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
 127         to = timeConvert notAfterMax
 128         from = timeConvert notBeforeMin
 129         cert pubKey = Certificate
 130             { certVersion = 2
 131             , certSerial = 0
 132             , certSignatureAlg = sigAlg
 133             , certIssuerDN = dn
 134             , certSubjectDN = dn
 135             , certValidity = (from, to)
 136             , certPubKey = pubKey
 137             , certExtensions = Extensions Nothing
 138             }
 139     in case tp of
 140     KeyRSA -> do
 141         -- generate 2048bit RSA self-signed cert with maximum validity
 142         (pubKey, secKey) <- generate 256 65537
 143         blinder <- generateBlinder $ public_n pubKey
 144         let signed = fst $ objectToSignedExact
 145                 (\b -> (fromRight BS.empty $
 146                     PKCS15.sign (Just blinder) (Just SHA256) secKey b, sigAlg, ()))
 147                 (cert $ PubKeyRSA pubKey)
 148         return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey)
 149     KeyEd25519 -> do
 150         secKey <- Ed25519.generateSecretKey
 151         let pubKey = Ed25519.toPublic secKey
 152         let signed = fst $ objectToSignedExact
 153                 (\b -> (BS.pack . BA.unpack $ Ed25519.sign secKey pubKey b, sigAlg, ()))
 154                 (cert $ PubKeyEd25519 pubKey)
 155         return $ ClientCert (CertificateChain [signed]) (PrivKeyEd25519 secKey)