diff options
Diffstat (limited to 'acme-certify.hs')
-rw-r--r-- | acme-certify.hs | 77 |
1 files changed, 56 insertions, 21 deletions
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 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | 1 | {-# LANGUAGE FlexibleContexts #-} |
2 | {-# LANGUAGE FlexibleInstances #-} | 2 | {-# LANGUAGE FlexibleInstances #-} |
3 | {-# LANGUAGE MultiWayIf #-} | ||
3 | {-# LANGUAGE NamedFieldPuns #-} | 4 | {-# LANGUAGE NamedFieldPuns #-} |
4 | {-# LANGUAGE NoImplicitPrelude #-} | 5 | {-# LANGUAGE NoImplicitPrelude #-} |
5 | {-# LANGUAGE OverloadedStrings #-} | 6 | {-# LANGUAGE OverloadedStrings #-} |
@@ -16,13 +17,16 @@ | |||
16 | module Main where | 17 | module Main where |
17 | 18 | ||
18 | import BasePrelude | 19 | import BasePrelude |
19 | import Control.Lens hiding ((&), argument) | 20 | import Control.Lens hiding (argument, (&)) |
20 | import Control.Monad.IO.Class | 21 | import Control.Monad.IO.Class |
22 | import Control.Monad.Trans.Except | ||
23 | import Control.Monad.Except | ||
21 | import Control.Monad.Trans.Resource | 24 | import Control.Monad.Trans.Resource |
22 | import Data.Aeson.Lens | 25 | import Data.Aeson.Lens |
23 | import qualified Data.HashMap.Strict as HashMap | 26 | import qualified Data.HashMap.Strict as HashMap |
24 | import Data.Text (Text, unpack, pack) | 27 | import Data.Text (Text, pack, unpack) |
25 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) | 28 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) |
29 | import Data.Time.Clock | ||
26 | import Data.Yaml (Object) | 30 | import Data.Yaml (Object) |
27 | import qualified Data.Yaml.Config as Config | 31 | import qualified Data.Yaml.Config as Config |
28 | import Data.Yaml.Config.Internal (Config (..)) | 32 | import Data.Yaml.Config.Internal (Config (..)) |
@@ -37,7 +41,7 @@ import OpenSSL | |||
37 | import OpenSSL.DH | 41 | import OpenSSL.DH |
38 | import OpenSSL.PEM | 42 | import OpenSSL.PEM |
39 | import OpenSSL.RSA | 43 | import OpenSSL.RSA |
40 | import OpenSSL.X509 (X509) | 44 | import OpenSSL.X509 (X509, getNotAfter) |
41 | import Options.Applicative hiding (header) | 45 | import Options.Applicative hiding (header) |
42 | import qualified Options.Applicative as Opt | 46 | import qualified Options.Applicative as Opt |
43 | import System.Directory | 47 | import System.Directory |
@@ -89,12 +93,12 @@ data CertifyOpts = CertifyOpts { | |||
89 | } | 93 | } |
90 | 94 | ||
91 | data UpdateOpts = UpdateOpts { | 95 | data UpdateOpts = UpdateOpts { |
92 | updateConfigFile :: Maybe FilePath, | 96 | updateConfigFile :: Maybe FilePath, |
93 | updateHosts :: [String], | 97 | updateHosts :: [String], |
94 | updateStaging :: Bool, | 98 | updateStaging :: Bool, |
95 | updateDryRun :: Bool, | 99 | updateDryRun :: Bool, |
96 | updateDoPrivisionCheck :: Bool, | 100 | updateDoPrivisionCheck :: Bool, |
97 | updateTryVHosts :: [String] | 101 | updateTryVHosts :: [String] |
98 | } | 102 | } |
99 | 103 | ||
100 | updateOpts :: Parser Command | 104 | updateOpts :: Parser Command |
@@ -183,6 +187,26 @@ data CertSpec = CertSpec { | |||
183 | csUserKeys :: Keys | 187 | csUserKeys :: Keys |
184 | } deriving Show | 188 | } deriving Show |
185 | 189 | ||
190 | data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert deriving Show | ||
191 | fetchNeeded :: CertSpec -> IO (Either NeedCertReason ()) | ||
192 | fetchNeeded (domainCertFile -> certFile) = runExceptT $ do | ||
193 | exists <- liftIO $ doesFileExist certFile | ||
194 | unless exists $ throwError NoExistingCert | ||
195 | |||
196 | cert <- liftIO $ readFile certFile >>= readX509 | ||
197 | expiration <- liftIO $ getNotAfter cert | ||
198 | now <- liftIO getCurrentTime | ||
199 | |||
200 | -- TODO: check X509v3 subjectAltName list within certificate | ||
201 | -- Need to patch HsOpenSSL. Or use cryptonite. | ||
202 | |||
203 | if | expiration < now -> throwError Expired | ||
204 | | expiration < addUTCTime graceTime now -> throwError NearExpiration | ||
205 | | otherwise -> return () | ||
206 | where | ||
207 | graceTime = days 20 | ||
208 | days = (*) (24 * 60 * 60) | ||
209 | |||
186 | runUpdate :: UpdateOpts -> IO () | 210 | runUpdate :: UpdateOpts -> IO () |
187 | runUpdate UpdateOpts { .. } = do | 211 | runUpdate UpdateOpts { .. } = do |
188 | issuerCert <- readX509 letsEncryptX1CrossSigned | 212 | issuerCert <- readX509 letsEncryptX1CrossSigned |
@@ -194,7 +218,7 @@ runUpdate UpdateOpts { .. } = do | |||
194 | return $ flip map (HashMap.keys hostParts) $ \domain -> | 218 | return $ flip map (HashMap.keys hostParts) $ \domain -> |
195 | (unpack host, domainName' $ unpack domain, combineSubdomains domain hostParts) | 219 | (unpack host, domainName' $ unpack domain, combineSubdomains domain hostParts) |
196 | 220 | ||
197 | globalCertificateDir <- getHomeDirectory <&> (</> if updateStaging then ".acme/test-certs" else ".acme/certs") | 221 | globalCertificateDir <- getHomeDirectory <&> (</> if updateStaging then ".acme/fake-certs" else ".acme/certs") |
198 | createDirectoryIfMissing True globalCertificateDir | 222 | createDirectoryIfMissing True globalCertificateDir |
199 | 223 | ||
200 | Just keys <- getOrCreateKeys $ globalCertificateDir </> "rsa.key" | 224 | Just keys <- getOrCreateKeys $ globalCertificateDir </> "rsa.key" |
@@ -217,15 +241,17 @@ runUpdate UpdateOpts { .. } = do | |||
217 | can <- uncurry canProvision csd | 241 | can <- uncurry canProvision csd |
218 | unless can $ error "Error: cannot provision files to web server" | 242 | unless can $ error "Error: cannot provision files to web server" |
219 | 243 | ||
220 | when (null updateTryVHosts) $ forM_ (view _3 <$> wantedCertSpecs) $ \spec -> do | 244 | when (null updateTryVHosts) $ forM_ wantedCertSpecs $ \(_, domain, spec) -> do |
221 | 245 | ||
222 | let terms = defaultTerms | 246 | let terms = defaultTerms |
223 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl | 247 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl |
224 | email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec) | 248 | email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec) |
225 | 249 | ||
226 | if updateDryRun | 250 | (fetchNeeded spec >>=) $ leftMapM_ $ \reason -> do |
227 | then putStrLn $ "Dry run; would have fetched certificate: " ++ show spec | 251 | putStrLn $ concat ["New certificate needed (for domain ", domainToString domain, "): ", show reason] |
228 | else print =<< fetchCertificate directoryUrl terms email issuerCert spec | 252 | if updateDryRun |
253 | then putStrLn "Dry run: nothing fetched, nothing saved." | ||
254 | else print =<< fetchCertificate directoryUrl terms email issuerCert spec | ||
229 | 255 | ||
230 | where | 256 | where |
231 | extractObject :: Config -> Object | 257 | extractObject :: Config -> Object |
@@ -349,18 +375,24 @@ fetchCertificate directoryUrl terms email issuerCert cs@CertSpec{..} = do | |||
349 | for certificate $ saveCertificate issuerCert dh domainKeys cs | 375 | for certificate $ saveCertificate issuerCert dh domainKeys cs |
350 | 376 | ||
351 | saveDhParams :: CertSpec -> IO (Maybe DHP) | 377 | saveDhParams :: CertSpec -> IO (Maybe DHP) |
352 | saveDhParams CertSpec{csSkipDH, csCertificateDir} = do | 378 | saveDhParams cs@CertSpec{csSkipDH} = |
353 | let domainDhFile = csCertificateDir </> "dhparams.pem" | 379 | if csSkipDH then return Nothing else Just <$> getOrCreateDH (domainDhFile cs) |
354 | if csSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile | ||
355 | 380 | ||
356 | saveCertificate :: X509 -> Maybe DHP -> Keys -> CertSpec -> X509 -> IO () | 381 | saveCertificate :: X509 -> Maybe DHP -> Keys -> CertSpec -> X509 -> IO () |
357 | saveCertificate issuerCert dh domainKeys CertSpec{csCertificateDir} = saveBoth | 382 | saveCertificate issuerCert dh domainKeys cs = saveBoth |
358 | where | 383 | where |
359 | saveBoth x509 = savePEM x509 >> saveCombined x509 | 384 | saveBoth x509 = savePEM x509 >> saveCombined x509 |
360 | saveCombined = combinedCert issuerCert dh domainKeys >=> writeFile domainCombinedFile | 385 | saveCombined = combinedCert issuerCert dh domainKeys >=> writeFile (domainCombinedFile cs) |
361 | savePEM = writeX509 >=> writeFile domainCertFile | 386 | savePEM = writeX509 >=> writeFile (domainCertFile cs) |
362 | domainCombinedFile = csCertificateDir </> "cert.combined.pem" | 387 | |
363 | domainCertFile = csCertificateDir </> "cert.pem" | 388 | domainDhFile :: CertSpec -> FilePath |
389 | domainDhFile CertSpec{..} = csCertificateDir </> "dhparams.pem" | ||
390 | |||
391 | domainCombinedFile :: CertSpec -> FilePath | ||
392 | domainCombinedFile CertSpec{..} = csCertificateDir </> "cert.combined.pem" | ||
393 | |||
394 | domainCertFile :: CertSpec -> FilePath | ||
395 | domainCertFile CertSpec{..} = csCertificateDir </> "cert.pem" | ||
364 | 396 | ||
365 | genKey :: IO String | 397 | genKey :: IO String |
366 | genKey = withOpenSSL $ do | 398 | genKey = withOpenSSL $ do |
@@ -407,3 +439,6 @@ infixl 0 `otherwiseM` | |||
407 | (<..>) :: String -> String -> String | 439 | (<..>) :: String -> String -> String |
408 | "." <..> dom = dom | 440 | "." <..> dom = dom |
409 | sub <..> dom = sub ++ "." ++ dom | 441 | sub <..> dom = sub ++ "." ++ dom |
442 | |||
443 | leftMapM_ :: Monad m => (a -> m ()) -> Either a b -> m () | ||
444 | leftMapM_ f = mapM_ f . either Right Left | ||