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         BS.writeFile keypath . pemWriteBS . PEM "PRIVATE KEY" [] . encodeDER $ key
  96 #ifndef WINDOWS
  97         setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
  98 #endif
  99     where
 100     encodeDER :: ASN1Object o => o -> BS.ByteString
 101     encodeDER = encodeASN1' DER . (`toASN1` [])
 102
 103 -- RFC5280: To indicate that a certificate has no well-defined expiration
 104 -- date, the notAfter SHOULD be assigned the GeneralizedTime value of
 105 -- 99991231235959Z.
 106 notAfterMax :: DateTime
 107 notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0)
 108
 109 -- RFC5280 has no corresponding prescription for notBefore, but
 110 -- 19500101000000Z seems the canonical choice.
 111 notBeforeMin :: DateTime
 112 notBeforeMin = DateTime (Date 1950 January 1) (TimeOfDay 0 0 0 0)
 113
 114 data KeyType = KeyRSA | KeyEd25519
 115
 116 generateSelfSigned :: KeyType -> String -> IO ClientCert
 117 generateSelfSigned tp cn =
 118     let dn = DistinguishedName [(getObjectID DnCommonName,
 119             ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
 120         sigAlg = case tp of
 121             KeyRSA     -> SignatureALG HashSHA256 PubKeyALG_RSA
 122             KeyEd25519 -> SignatureALG_IntrinsicHash PubKeyALG_Ed25519
 123         to = timeConvert notAfterMax
 124         from = timeConvert notBeforeMin
 125         cert pubKey = Certificate
 126             { certVersion = 2
 127             , certSerial = 0
 128             , certSignatureAlg = sigAlg
 129             , certIssuerDN = dn
 130             , certSubjectDN = dn
 131             , certValidity = (from, to)
 132             , certPubKey = pubKey
 133             , certExtensions = Extensions Nothing
 134             }
 135     in case tp of
 136     KeyRSA -> do
 137         -- generate 2048bit RSA self-signed cert with maximum validity
 138         (pubKey, secKey) <- generate 256 65537
 139         blinder <- generateBlinder $ public_n pubKey
 140         let signed = fst $ objectToSignedExact
 141                 (\b -> (fromRight BS.empty $
 142                     PKCS15.sign (Just blinder) (Just SHA256) secKey b, sigAlg, ()))
 143                 (cert $ PubKeyRSA pubKey)
 144         return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey)
 145     KeyEd25519 -> do
 146         secKey <- Ed25519.generateSecretKey
 147         let pubKey = Ed25519.toPublic secKey
 148         let signed = fst $ objectToSignedExact
 149                 (\b -> (BS.pack . BA.unpack $ Ed25519.sign secKey pubKey b, sigAlg, ()))
 150                 (cert $ PubKeyEd25519 pubKey)
 151         return $ ClientCert (CertificateChain [signed]) (PrivKeyEd25519 secKey)