diff options
author | Andrew Cady <d@jerkface.net> | 2016-04-10 20:33:26 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-04-10 20:33:26 -0400 |
commit | 74451bfa239515ed419e47e587a2c0009808525c (patch) | |
tree | f85d209c22efa160bc60637a7f0474261a3b0fc9 | |
parent | ed569c0a0adcddb95658a4ef88aa6db4d4145f98 (diff) |
New option to "update": --try
-rw-r--r-- | acme-certify.hs | 58 |
1 files 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 { | |||
93 | updateHosts :: [String], | 93 | updateHosts :: [String], |
94 | updateStaging :: Bool, | 94 | updateStaging :: Bool, |
95 | updateDryRun :: Bool, | 95 | updateDryRun :: Bool, |
96 | updateDoPrivisionCheck :: Bool | 96 | updateDoPrivisionCheck :: Bool, |
97 | updateTryVHosts :: [String] | ||
97 | } | 98 | } |
98 | 99 | ||
99 | instance Show HttpProvisioner where | ||
100 | show _ = "<code>" | ||
101 | instance Show Keys where | ||
102 | show _ = "<keys>" | ||
103 | |||
104 | data CertSpec = CertSpec { | ||
105 | csDomains :: [(DomainName, HttpProvisioner)], | ||
106 | csSkipDH :: Bool, | ||
107 | csCertificateDir :: FilePath, | ||
108 | csUserKeys :: Keys | ||
109 | } deriving Show | ||
110 | |||
111 | updateOpts :: Parser Command | 100 | updateOpts :: Parser Command |
112 | updateOpts = fmap Update $ | 101 | updateOpts = fmap Update $ |
113 | UpdateOpts <$> optional | 102 | UpdateOpts <$> optional |
@@ -124,6 +113,16 @@ updateOpts = fmap Update $ | |||
124 | , "configuration file and http provisioning" | 113 | , "configuration file and http provisioning" |
125 | ])) | 114 | ])) |
126 | <*> pure True | 115 | <*> pure True |
116 | <*> many | ||
117 | (strOption | ||
118 | (long "try" <> | ||
119 | metavar "DOMAIN" <> | ||
120 | help | ||
121 | (unwords | ||
122 | [ "When specified, only specified domains will be checked" | ||
123 | , "for the ability to provision HTTP files; when not" | ||
124 | , "specified, all domains will be checked" | ||
125 | ]))) | ||
127 | 126 | ||
128 | -- TODO: global options | 127 | -- TODO: global options |
129 | stagingSwitch :: Parser Bool | 128 | stagingSwitch :: Parser Bool |
@@ -172,6 +171,18 @@ certifyOpts = fmap Certify $ | |||
172 | , "making ACME requests" | 171 | , "making ACME requests" |
173 | ])) | 172 | ])) |
174 | 173 | ||
174 | instance Show HttpProvisioner where | ||
175 | show _ = "<code>" | ||
176 | instance Show Keys where | ||
177 | show _ = "<keys>" | ||
178 | |||
179 | data CertSpec = CertSpec { | ||
180 | csDomains :: [(DomainName, HttpProvisioner)], | ||
181 | csSkipDH :: Bool, | ||
182 | csCertificateDir :: FilePath, | ||
183 | csUserKeys :: Keys | ||
184 | } deriving Show | ||
185 | |||
175 | runUpdate :: UpdateOpts -> IO () | 186 | runUpdate :: UpdateOpts -> IO () |
176 | runUpdate UpdateOpts { .. } = do | 187 | runUpdate UpdateOpts { .. } = do |
177 | issuerCert <- readX509 letsEncryptX1CrossSigned | 188 | issuerCert <- readX509 letsEncryptX1CrossSigned |
@@ -197,15 +208,16 @@ runUpdate UpdateOpts { .. } = do | |||
197 | (return . (,,) host domain) | 208 | (return . (,,) host domain) |
198 | mbSpec | 209 | mbSpec |
199 | 210 | ||
200 | let wantedCertSpecs = filter (wantUpdate . view _1) validCertSpecs & map (view _3) | 211 | let wantedCertSpecs = filter (wantUpdate . view _1) validCertSpecs |
201 | 212 | ||
202 | when updateDoPrivisionCheck $ | 213 | when updateDoPrivisionCheck $ |
203 | forM_ wantedCertSpecs $ \spec -> | 214 | forM_ (view _3 <$> wantedCertSpecs) $ \spec -> |
204 | forM_ (csDomains spec) $ uncurry canProvision >=> | 215 | forM_ (filter (wantProvisionCheck . fst) $ csDomains spec) $ \csd -> do |
205 | (`unless` error "Error: cannot provision files to web server") | 216 | putStrLn $ "Provision check: " ++ (domainToString . fst $ csd) |
217 | can <- uncurry canProvision csd | ||
218 | unless can $ error "Error: cannot provision files to web server" | ||
206 | 219 | ||
207 | 220 | when (null updateTryVHosts) $ forM_ (view _3 <$> wantedCertSpecs) $ \spec -> do | |
208 | forM_ wantedCertSpecs $ \spec -> do | ||
209 | 221 | ||
210 | let terms = defaultTerms | 222 | let terms = defaultTerms |
211 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl | 223 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl |
@@ -219,8 +231,14 @@ runUpdate UpdateOpts { .. } = do | |||
219 | extractObject :: Config -> Object | 231 | extractObject :: Config -> Object |
220 | extractObject (Config _ o) = o | 232 | extractObject (Config _ o) = o |
221 | 233 | ||
234 | elemOrNull :: Eq a => [a] -> a -> Bool | ||
235 | elemOrNull xs x = null xs || x `elem` xs | ||
236 | |||
237 | wantProvisionCheck :: DomainName -> Bool | ||
238 | wantProvisionCheck = elemOrNull updateTryVHosts . domainToString | ||
239 | |||
222 | wantUpdate :: String -> Bool | 240 | wantUpdate :: String -> Bool |
223 | wantUpdate h = null updateHosts || isJust (find (== h) updateHosts) | 241 | wantUpdate = elemOrNull updateHosts |
224 | 242 | ||
225 | dereference :: [(DomainName, Either DomainName HttpProvisioner)] -> Maybe [(DomainName, HttpProvisioner)] | 243 | dereference :: [(DomainName, Either DomainName HttpProvisioner)] -> Maybe [(DomainName, HttpProvisioner)] |
226 | dereference xs = plumb $ xs <&> fmap (either deref Just) | 244 | dereference xs = plumb $ xs <&> fmap (either deref Just) |