From 74451bfa239515ed419e47e587a2c0009808525c Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Sun, 10 Apr 2016 20:33:26 -0400
Subject: New option to "update": --try

---
 acme-certify.hs | 58 +++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 38 insertions(+), 20 deletions(-)

diff --git a/acme-certify.hs b/acme-certify.hs
index 73aff51..1ae9dbf 100644
--- a/acme-certify.hs
+++ b/acme-certify.hs
@@ -93,21 +93,10 @@ data UpdateOpts = UpdateOpts {
       updateHosts :: [String],
       updateStaging :: Bool,
       updateDryRun :: Bool,
-      updateDoPrivisionCheck :: Bool
+      updateDoPrivisionCheck :: Bool,
+      updateTryVHosts :: [String]
 }
 
-instance Show HttpProvisioner where
-    show _ = "<code>"
-instance Show Keys where
-    show _ = "<keys>"
-
-data CertSpec = CertSpec {
-      csDomains        :: [(DomainName, HttpProvisioner)],
-      csSkipDH         :: Bool,
-      csCertificateDir :: FilePath,
-      csUserKeys       :: Keys
-} deriving Show
-
 updateOpts :: Parser Command
 updateOpts = fmap Update $
   UpdateOpts <$> optional
@@ -124,6 +113,16 @@ updateOpts = fmap Update $
                                            , "configuration file and http provisioning"
                                            ]))
              <*> pure True
+             <*> many
+                   (strOption
+                      (long "try" <>
+                       metavar "DOMAIN" <>
+                       help
+                         (unwords
+                            [ "When specified, only specified domains will be checked"
+                            , "for the ability to provision HTTP files; when not"
+                            , "specified, all domains will be checked"
+                            ])))
 
 -- TODO: global options
 stagingSwitch :: Parser Bool
@@ -172,6 +171,18 @@ certifyOpts = fmap Certify $
                                                          , "making ACME requests"
                                                          ]))
 
+instance Show HttpProvisioner where
+    show _ = "<code>"
+instance Show Keys where
+    show _ = "<keys>"
+
+data CertSpec = CertSpec {
+      csDomains        :: [(DomainName, HttpProvisioner)],
+      csSkipDH         :: Bool,
+      csCertificateDir :: FilePath,
+      csUserKeys       :: Keys
+} deriving Show
+
 runUpdate :: UpdateOpts -> IO ()
 runUpdate UpdateOpts { .. } = do
   issuerCert <- readX509 letsEncryptX1CrossSigned
@@ -197,15 +208,16 @@ runUpdate UpdateOpts { .. } = do
                             (return . (,,) host domain)
                             mbSpec
 
-  let wantedCertSpecs = filter (wantUpdate . view _1) validCertSpecs & map (view _3)
+  let wantedCertSpecs = filter (wantUpdate . view _1) validCertSpecs
 
   when updateDoPrivisionCheck $
-    forM_ wantedCertSpecs $ \spec ->
-      forM_ (csDomains spec) $ uncurry canProvision >=>
-        (`unless` error "Error: cannot provision files to web server")
+    forM_ (view _3 <$> wantedCertSpecs) $ \spec ->
+      forM_ (filter (wantProvisionCheck . fst) $ csDomains spec) $ \csd -> do
+        putStrLn $ "Provision check: " ++ (domainToString . fst $ csd)
+        can <- uncurry canProvision csd
+        unless can $ error "Error: cannot provision files to web server"
 
-
-  forM_ wantedCertSpecs $ \spec -> do
+  when (null updateTryVHosts) $ forM_ (view _3 <$> wantedCertSpecs) $ \spec -> do
 
     let terms              = defaultTerms
         directoryUrl       = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl
@@ -219,8 +231,14 @@ runUpdate UpdateOpts { .. } = do
     extractObject :: Config -> Object
     extractObject (Config _ o) = o
 
+    elemOrNull :: Eq a => [a] -> a -> Bool
+    elemOrNull xs x = null xs || x `elem` xs
+
+    wantProvisionCheck :: DomainName -> Bool
+    wantProvisionCheck = elemOrNull updateTryVHosts . domainToString
+
     wantUpdate :: String -> Bool
-    wantUpdate h = null updateHosts || isJust (find (== h) updateHosts)
+    wantUpdate = elemOrNull updateHosts
 
     dereference :: [(DomainName, Either DomainName HttpProvisioner)] -> Maybe [(DomainName, HttpProvisioner)]
     dereference xs = plumb $ xs <&> fmap (either deref Just)
-- 
cgit v1.2.3