diohsc-0.1.6.1: ClientCert.hs

-- This file is part of Diohsc
-- Copyright (C) 2020 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

{-# LANGUAGE CPP               #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module ClientCert where

import           Control.Applicative      (liftA2)
import           Crypto.Hash.Algorithms   (SHA256 (..))
import           Crypto.PubKey.RSA
import           Crypto.PubKey.RSA.PKCS15
import           Data.ASN1.OID
import           Data.ASN1.Types.String   (ASN1StringEncoding (UTF8))
import           Data.Either              (fromRight)
import           Data.Hourglass
import           Data.PEM
import           Data.X509
import           Network.TLS              (PrivKey (PrivKeyRSA))
import           Safe
import           System.FilePath
import           Time.System

import qualified Data.ByteString          as BS
import qualified Data.Text                as TS
import qualified Data.Text.Encoding       as TS

import           Fingerprint
import           Mundanities
import           Util

#ifndef WINDOWS
import           System.Posix.Files
#endif

-- |Certificate chain with secret key for tail cert
data ClientCert = ClientCert CertificateChain PrivKey
    deriving (Eq,Show)

clientCertFingerprint :: ClientCert -> Fingerprint
clientCertFingerprint (ClientCert (CertificateChain chain) _) =
    fingerprint $ head chain

loadClientCert :: FilePath -> String -> IO (Maybe ClientCert)
loadClientCert path name =
    let certpath = path </> name <.> "crt"
        keypath = path </> name <.> "rsa"
    in ignoreIOErrAlt $ do
        chain <- (\case
            Right pems -> case decodeCertificateChain . CertificateChainRaw $ map pemContent pems of
                Right chain -> Just chain
                _           -> Nothing
            _ -> Nothing) . pemParseBS <$> BS.readFile certpath
        key <- (PrivKeyRSA <$>) . readMay <$> readFile keypath
        return $ liftA2 ClientCert chain key

saveClientCert :: FilePath -> String -> ClientCert -> IO ()
saveClientCert path name (ClientCert chain (PrivKeyRSA key)) =
    let filepath = path </> name
        certpath = filepath <.> "crt"
        keypath = filepath <.> "rsa"
    in isSubPath path filepath >>? ignoreIOErr $ do
        let CertificateChainRaw rawCerts = encodeCertificateChain chain
            chainPEMs = map (pemWriteBS . PEM "CERTIFICATE" []) rawCerts
        BS.writeFile certpath $ BS.intercalate "\n" chainPEMs
        writeFile keypath $ show key
#ifndef WINDOWS
        setFileMode keypath $ unionFileModes ownerReadMode ownerWriteMode -- chmod 600
#endif
saveClientCert _ _ _ = putStrLn "! Error: can't save key of this type"

-- RFC5280: To indicate that a certificate has no well-defined expiration
-- date, the notAfter SHOULD be assigned the GeneralizedTime value of
-- 99991231235959Z.
notAfterMax :: DateTime
notAfterMax = DateTime (Date 9999 December 31) (TimeOfDay 23 59 59 0)

-- RFC5280 has no corresponding prescription for notBefore, but
-- 19500101000000Z seems the canonical choice.
notBeforeMin :: DateTime
notBeforeMin = DateTime (Date 1950 January 1) (TimeOfDay 0 0 0 0)

-- |generate 2048bit RSA key with maximum validity
generateSelfSigned :: String -> IO ClientCert
generateSelfSigned cn = do
    (pubKey, secKey) <- generate 256 65537
    blinder <- generateBlinder $ public_n pubKey
    let dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
        sigAlg = SignatureALG HashSHA256 PubKeyALG_RSA
        to = timeConvert notAfterMax
        from = timeConvert notBeforeMin
        cert = Certificate
            { certVersion = 2
            , certSerial = 0
            , certSignatureAlg = sigAlg
            , certIssuerDN = dn
            , certSubjectDN = dn
            , certValidity = (from, to)
            , certPubKey = PubKeyRSA pubKey
            , certExtensions = Extensions Nothing
            }
        signed = fst $ objectToSignedExact
            (\b -> (fromRight BS.empty $ sign (Just blinder) (Just SHA256) secKey b, sigAlg, ()))
            cert
    return $ ClientCert (CertificateChain [signed]) (PrivKeyRSA secKey)

{- Using Crypto.PubKey.Ed25519; perhaps if TLS1.3 becomes mandatory for
-- gemini, we should use this?
import qualified Data.ByteArray as BA

generateSelfSigned :: String -> IO ClientCert
generateSelfSigned cn = do
    secKey <- generateSecretKey
    currentTime <- timeConvert <$> timeCurrent
    let pubKey = toPublic secKey
        dn = DistinguishedName [(getObjectID DnCommonName, ASN1CharacterString UTF8 . TS.encodeUtf8 $ TS.pack cn)]
        sigAlg = SignatureALG_IntrinsicHash PubKeyALG_Ed25519
        -- TODO: think about correct validity dates
        to = timeConvert . dateAddPeriod currentTime $ Period {periodYears = 1, periodMonths = 0, periodDays = 0}
        from = timeConvert . dateAddPeriod currentTime $ Period {periodYears = -1, periodMonths = 0, periodDays = 0}
        cert = Certificate
            { certVersion = 3
            , certSerial = 0
            , certSignatureAlg = sigAlg
            , certIssuerDN = dn
            , certSubjectDN = dn
            , certValidity = (from, to)
            , certPubKey = PubKeyEd25519 pubKey
            , certExtensions = Extensions Nothing
            }
        signed = fst $ objectToSignedExact
            (\b -> (BS.pack . BA.unpack $ sign secKey pubKey b, sigAlg, ()))
            cert
    return (CertificateChain [signed], PrivKeyEd25519 secKey)
-}