From 5978351c55544b0ab72630ba70fec25825cad7b4 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Mon, 11 Apr 2016 01:39:16 -0400 Subject: Check existing certificate expiration This disables renewing the cert unless the existing cert will expire within 20 days. It doesn't check if the existing cert has the same names as the new cert would! This needs to be done. --- acme-certify.cabal | 2 +- acme-certify.hs | 77 +++++++++++++++++++++++++++++++++++++++--------------- 2 files changed, 57 insertions(+), 22 deletions(-) diff --git a/acme-certify.cabal b/acme-certify.cabal index ac6427a..9a67cb9 100644 --- a/acme-certify.cabal +++ b/acme-certify.cabal @@ -30,7 +30,7 @@ executable acme text, HsOpenSSL, optparse-applicative, time, email-validate, network-uri, directory, yaml-config, yaml, unordered-containers, lens, lens-aeson, process, - posix-escape, transformers, resourcet + posix-escape, transformers, resourcet, mtl default-language: Haskell2010 -- test-suite acme-certify-test diff --git a/acme-certify.hs b/acme-certify.hs index 1ae9dbf..ecddc99 100644 --- a/acme-certify.hs +++ b/acme-certify.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} @@ -16,13 +17,16 @@ module Main where import BasePrelude -import Control.Lens hiding ((&), argument) +import Control.Lens hiding (argument, (&)) import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import Control.Monad.Except import Control.Monad.Trans.Resource import Data.Aeson.Lens import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text, unpack, pack) +import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time.Clock import Data.Yaml (Object) import qualified Data.Yaml.Config as Config import Data.Yaml.Config.Internal (Config (..)) @@ -37,7 +41,7 @@ import OpenSSL import OpenSSL.DH import OpenSSL.PEM import OpenSSL.RSA -import OpenSSL.X509 (X509) +import OpenSSL.X509 (X509, getNotAfter) import Options.Applicative hiding (header) import qualified Options.Applicative as Opt import System.Directory @@ -89,12 +93,12 @@ data CertifyOpts = CertifyOpts { } data UpdateOpts = UpdateOpts { - updateConfigFile :: Maybe FilePath, - updateHosts :: [String], - updateStaging :: Bool, - updateDryRun :: Bool, + updateConfigFile :: Maybe FilePath, + updateHosts :: [String], + updateStaging :: Bool, + updateDryRun :: Bool, updateDoPrivisionCheck :: Bool, - updateTryVHosts :: [String] + updateTryVHosts :: [String] } updateOpts :: Parser Command @@ -183,6 +187,26 @@ data CertSpec = CertSpec { csUserKeys :: Keys } deriving Show +data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert deriving Show +fetchNeeded :: CertSpec -> IO (Either NeedCertReason ()) +fetchNeeded (domainCertFile -> certFile) = runExceptT $ do + exists <- liftIO $ doesFileExist certFile + unless exists $ throwError NoExistingCert + + cert <- liftIO $ readFile certFile >>= readX509 + expiration <- liftIO $ getNotAfter cert + now <- liftIO getCurrentTime + + -- TODO: check X509v3 subjectAltName list within certificate + -- Need to patch HsOpenSSL. Or use cryptonite. + + if | expiration < now -> throwError Expired + | expiration < addUTCTime graceTime now -> throwError NearExpiration + | otherwise -> return () + where + graceTime = days 20 + days = (*) (24 * 60 * 60) + runUpdate :: UpdateOpts -> IO () runUpdate UpdateOpts { .. } = do issuerCert <- readX509 letsEncryptX1CrossSigned @@ -194,7 +218,7 @@ runUpdate UpdateOpts { .. } = do return $ flip map (HashMap.keys hostParts) $ \domain -> (unpack host, domainName' $ unpack domain, combineSubdomains domain hostParts) - globalCertificateDir <- getHomeDirectory <&> ( if updateStaging then ".acme/test-certs" else ".acme/certs") + globalCertificateDir <- getHomeDirectory <&> ( if updateStaging then ".acme/fake-certs" else ".acme/certs") createDirectoryIfMissing True globalCertificateDir Just keys <- getOrCreateKeys $ globalCertificateDir "rsa.key" @@ -217,15 +241,17 @@ runUpdate UpdateOpts { .. } = do can <- uncurry canProvision csd unless can $ error "Error: cannot provision files to web server" - when (null updateTryVHosts) $ forM_ (view _3 <$> wantedCertSpecs) $ \spec -> do + when (null updateTryVHosts) $ forM_ wantedCertSpecs $ \(_, domain, spec) -> do let terms = defaultTerms directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec) - if updateDryRun - then putStrLn $ "Dry run; would have fetched certificate: " ++ show spec - else print =<< fetchCertificate directoryUrl terms email issuerCert spec + (fetchNeeded spec >>=) $ leftMapM_ $ \reason -> do + putStrLn $ concat ["New certificate needed (for domain ", domainToString domain, "): ", show reason] + if updateDryRun + then putStrLn "Dry run: nothing fetched, nothing saved." + else print =<< fetchCertificate directoryUrl terms email issuerCert spec where extractObject :: Config -> Object @@ -349,18 +375,24 @@ fetchCertificate directoryUrl terms email issuerCert cs@CertSpec{..} = do for certificate $ saveCertificate issuerCert dh domainKeys cs saveDhParams :: CertSpec -> IO (Maybe DHP) -saveDhParams CertSpec{csSkipDH, csCertificateDir} = do - let domainDhFile = csCertificateDir "dhparams.pem" - if csSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile +saveDhParams cs@CertSpec{csSkipDH} = + if csSkipDH then return Nothing else Just <$> getOrCreateDH (domainDhFile cs) saveCertificate :: X509 -> Maybe DHP -> Keys -> CertSpec -> X509 -> IO () -saveCertificate issuerCert dh domainKeys CertSpec{csCertificateDir} = saveBoth +saveCertificate issuerCert dh domainKeys cs = saveBoth where saveBoth x509 = savePEM x509 >> saveCombined x509 - saveCombined = combinedCert issuerCert dh domainKeys >=> writeFile domainCombinedFile - savePEM = writeX509 >=> writeFile domainCertFile - domainCombinedFile = csCertificateDir "cert.combined.pem" - domainCertFile = csCertificateDir "cert.pem" + saveCombined = combinedCert issuerCert dh domainKeys >=> writeFile (domainCombinedFile cs) + savePEM = writeX509 >=> writeFile (domainCertFile cs) + +domainDhFile :: CertSpec -> FilePath +domainDhFile CertSpec{..} = csCertificateDir "dhparams.pem" + +domainCombinedFile :: CertSpec -> FilePath +domainCombinedFile CertSpec{..} = csCertificateDir "cert.combined.pem" + +domainCertFile :: CertSpec -> FilePath +domainCertFile CertSpec{..} = csCertificateDir "cert.pem" genKey :: IO String genKey = withOpenSSL $ do @@ -407,3 +439,6 @@ infixl 0 `otherwiseM` (<..>) :: String -> String -> String "." <..> dom = dom sub <..> dom = sub ++ "." ++ dom + +leftMapM_ :: Monad m => (a -> m ()) -> Either a b -> m () +leftMapM_ f = mapM_ f . either Right Left -- cgit v1.2.3