1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
-- | Get a certificate from Let's Encrypt using the ACME protocol.
--
-- https://github.com/ietf-wg-acme/acme/blob/master/draft-ietf-acme-acme.md
module Main where
import BasePrelude
import Control.Lens hiding ((&))
import Control.Monad.IO.Class
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.Encoding (decodeUtf8, encodeUtf8)
import Data.Yaml (Object)
import qualified Data.Yaml.Config as Config
import Data.Yaml.Config.Internal (Config (..))
import Network.ACME (HttpProvisioner, Keys (..),
canProvision, certify,
ensureWritableDir,
provisionViaFile, readKeys,
(</>))
import Network.ACME.Issuer (letsEncryptX1CrossSigned)
import Network.URI
import OpenSSL
import OpenSSL.DH
import OpenSSL.PEM
import OpenSSL.RSA
import OpenSSL.X509 (X509)
import Options.Applicative hiding (header)
import qualified Options.Applicative as Opt
import System.Directory
import System.IO
import System.Posix.Escape
import System.Process
import Text.Domain.Validate hiding (validate)
import Text.Email.Validate
stagingDirectoryUrl, liveDirectoryUrl, defaultTerms :: URI
Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory"
Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory"
Just defaultTerms = parseAbsoluteURI "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf"
main :: IO ()
main = execParser (info opts idm) >>= run
where
opts :: Parser Options
opts = Options <$> parseCommand
parseCommand :: Parser Command
parseCommand = subparser $
command "certify" (info (helper <*> certifyOpts) desc) <>
command "update" (info (helper <*> updateOpts) desc)
desc = fullDesc <> progDesc detailedDescription <> Opt.header "Let's Encrypt! ACME client"
detailedDescription = unwords
[ "This program will generate a signed TLS certificate"
, "using the ACME protocol and the free Let's Encrypt! CA."
]
run :: Options -> IO ()
run (Options (Certify opts)) = runCertify opts >>= either (error . ("Error: " ++)) return
run (Options (Update opts)) = runUpdate opts
data Command = Certify CertifyOpts | Update UpdateOpts
data Options = Options {
optCommand :: Command
}
data CertifyOpts = CertifyOpts {
optKeyFile :: String,
optDomains :: [String],
optChallengeDir :: String,
optDomainDir :: Maybe String,
optEmail :: Maybe String,
optTerms :: Maybe String,
optSkipDH :: Bool,
optStaging :: Bool,
optSkipProvisionCheck :: Bool
}
data UpdateOpts = UpdateOpts {
updateConfigFile :: Maybe FilePath
}
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
(strOption
(long "config" <>
metavar "FILENAME" <>
help "location of YAML configuration file"))
certifyOpts :: Parser Command
certifyOpts = fmap Certify $
CertifyOpts <$> strOption (long "key" <> metavar "FILE" <>
help "Filename of your private RSA key")
<*> some
(strOption
(long "domain" <>
metavar "DOMAIN" <>
help
(unwords
[ "The domain name(s) to certify;"
, "specify more than once for a multi-domain certificate"
])))
<*> strOption (long "challenge-dir" <> metavar "DIR" <>
help "Output directory for ACME challenges")
<*> optional
(strOption
(long "domain-dir" <>
metavar "DIR" <>
help
(unwords
[ "Directory in which to domain certificates and keys are stored;"
, "the default is to use the (first) domain name as a directory name"
])))
<*> optional (strOption (long "email" <> metavar "ADDRESS" <>
help "An email address with which to register an account"))
<*> optional (strOption (long "terms" <> metavar "URL" <>
help "The terms param of the registration request"))
<*> switch (long "skip-dhparams" <> help "Don't generate DH params for combined cert")
<*> switch
(long "staging" <> help
(unwords
[ "Use staging servers instead of live servers"
, "(generated certificates will not be trusted!)"
]))
<*> switch
(long "skip-provision-check" <> help
(unwords
[ "Don't test whether HTTP provisioning works before"
, "making ACME requests"
]))
-- lookup' :: (Monad m, FromJSON a) => Config.Key -> Config -> m a
extractObject :: Config -> Object
extractObject (Config _ o) = o
runUpdate :: UpdateOpts -> IO ()
runUpdate UpdateOpts { .. } = do
config <- Config.load "config.yaml"
hostsConfig <- Config.subconfig "hosts" config
certReqDomains <- fmap concat <$> forM (Config.keys hostsConfig) $ \host ->
do
hostParts <- (Config.subconfig host hostsConfig >>= Config.subconfig
"domains") <&> extractObject
forM (HashMap.keys hostParts) $ \domain ->
return (unpack host, combineSubdomains domain hostParts)
when False $ forM_ certReqDomains print
globalCertificateDir <- getHomeDirectory <&> (</> ".acme/test")
createDirectoryIfMissing True globalCertificateDir
Just keys <- getOrCreateKeys $ globalCertificateDir </> "rsa.key"
let certSpecs = flip map certReqDomains $ \(host, domains) -> fmap ((,) host) $
dereference (map (chooseProvisioner host) domains) <&> certSpec globalCertificateDir keys host
when False $ do
mapM_ print certSpecs
h <- remoteTemp "localhost" "/tmp/whatevs 'bro'" "this content\ncontains stuff'"
threadDelay $ 1000 * 1000 * 10
removeTemp h
issuerCert <- readX509 letsEncryptX1CrossSigned
forM_ certReqDomains $ \(host, domains) -> do
when (host == "fifty") $ do
putStrLn host
let Just spec = dereference (map (chooseProvisioner host) domains) <&> certSpec globalCertificateDir keys host
print spec
when True $
forM_ (csDomains spec) $ uncurry canProvision >=>
(`unless` error "Error: cannot provision files to web server")
let terms = defaultTerms
directoryUrl = stagingDirectoryUrl
email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec)
print =<< fetchCertificate directoryUrl terms email issuerCert spec
error "Error: unimplemented"
where
dereference :: [(DomainName, Either DomainName HttpProvisioner)] -> Maybe [(DomainName, HttpProvisioner)]
dereference xs = plumb $ xs <&> fmap (either deref Just)
where
deref :: DomainName -> Maybe HttpProvisioner
deref s = lookup s xs & preview (_Just . _Right)
plumb = traverse (\(a, b) -> fmap ((,) a) b)
chooseProvisioner :: String -> VHostSpec -> (DomainName, Either DomainName HttpProvisioner)
chooseProvisioner host (VHostSpec domain pathInfo) =
(domain, provisionViaRemoteFile host <$> pathInfo)
certSpec :: FilePath -> Keys -> String -> [(DomainName, HttpProvisioner)] -> CertSpec
certSpec baseDir keys host requestDomains = CertSpec { .. }
where
csDomains = requestDomains
csSkipDH = True -- TODO: implement
csUserKeys = keys
csCertificateDir = baseDir </> host </> (domainToString . fst) (head requestDomains)
combineSubdomains :: AsPrimitive v => Text -> HashMap.HashMap Text v -> [VHostSpec]
combineSubdomains domain subs =
map (makeVHostSpec (domainName' $ unpack domain)) $
sort -- relying on the fact that '.' sorts first
$ concat $ HashMap.lookup domain subs & toListOf (_Just . _String . to (words . unpack))
domainToString :: DomainName -> String
domainToString = unpack . decodeUtf8 . Text.Domain.Validate.toByteString
data VHostSpec = VHostSpec DomainName (Either DomainName FilePath) deriving Show
makeVHostSpec :: DomainName -> String -> VHostSpec
makeVHostSpec = make
where
make (domainToString -> parentDomain) (splitSpec -> (sub, spec)) =
VHostSpec (domainName' $ sub <..> parentDomain) (makeRef spec)
where
makeRef :: Either String FilePath -> Either DomainName FilePath
makeRef = left (\refSub -> domainName' $ refSub <..> parentDomain)
splitSpec :: String -> (String, Either String FilePath)
splitSpec (break (== '{') -> (a, b)) = (,) a $
case b of
('{':c@('/':_)) -> Right $ takeWhile (/= '}') c
('{':c) -> Left $ takeWhile (/= '}') c
_ -> Right $ "/srv" </> a </> "public_html"
data TempRemover = TempRemover { removeTemp :: IO () }
remoteTemp :: String -> FilePath -> String -> IO TempRemover
remoteTemp host fileName content = do
(inp,out,err,_pid) <- ssh $ unlines
[ "mkdir -p " ++ escape (dirname fileName)
, "printf '%s' " ++ escape content ++ " > " ++ escape fileName
, "echo provisioned."
, "trap " ++ (escape . unwords) ["rm -f", escape fileName] ++ " EXIT"
, "read line"
]
void $ hGetLine out
return $ TempRemover $ mapM_ hClose [inp, out, err]
where
ssh cmd = runInteractiveProcess "ssh" (host : words "-- sh -c" ++ [escape cmd]) Nothing Nothing
dirname = dropWhileEnd (/= '/')
provisionViaRemoteFile :: String -> FilePath -> HttpProvisioner
provisionViaRemoteFile = provision
where
provision host dir (bsToS -> tok) (bsToS -> thumbtoken) =
void $ allocate (liftIO $ remoteTemp host (dir </> wk </> tok) thumbtoken) removeTemp
wk = ".well-known/acme-challenge"
bsToS = unpack . decodeUtf8
runCertify :: CertifyOpts -> IO (Either String ())
runCertify CertifyOpts{..} = do
let terms = fromMaybe defaultTerms (join $ parseAbsoluteURI <$> optTerms)
directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl
domainDir = fromMaybe (head optDomains) optDomainDir
privKeyFile = optKeyFile
requestDomains = map domainName' optDomains
email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail
issuerCert <- readX509 letsEncryptX1CrossSigned
seq email (return ())
createDirectoryIfMissing False domainDir
challengeDir <- ensureWritableDir optChallengeDir "challenge directory"
void $ ensureWritableDir domainDir "domain directory"
Just keys <- getOrCreateKeys privKeyFile
let spec = CertSpec {..}
csDomains = map (flip (,) (provisionViaFile challengeDir)) requestDomains
csSkipDH = optSkipDH
csUserKeys = keys
csCertificateDir = domainDir
unless optSkipProvisionCheck $
forM_ csDomains $ uncurry canProvision >=>
(`unless` error "Error: cannot provision files to web server")
fetchCertificate directoryUrl terms email issuerCert spec
fetchCertificate :: URI -> URI -> Maybe EmailAddress -> X509 -> CertSpec -> IO (Either String ())
fetchCertificate directoryUrl terms email issuerCert cs@CertSpec{..} = do
Just domainKeys <- getOrCreateKeys $ csCertificateDir </> "rsa.key"
dh <- saveDhParams cs
certificate <- certify directoryUrl csUserKeys ((,) terms <$> email) domainKeys csDomains
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
saveCertificate :: X509 -> Maybe DHP -> Keys -> CertSpec -> X509 -> IO ()
saveCertificate issuerCert dh domainKeys CertSpec{csCertificateDir} = 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"
genKey :: IO String
genKey = withOpenSSL $ do
kp <- generateRSAKey' 4096 65537
writePKCS8PrivateKey kp Nothing
getOrCreate :: IO String -> (String -> IO a) -> FilePath -> IO a
getOrCreate gen parse file = do
exists <- doesFileExist file
createDirectoryIfMissing True (dirname file)
parse =<< if exists then readFile file else gen >>= save file
where
save f x = writeFile f x >> return x
getOrCreateKeys :: FilePath -> IO (Maybe Keys)
getOrCreateKeys = getOrCreate genKey readKeys
getOrCreateDH :: FilePath -> IO DHP
getOrCreateDH = getOrCreate (genDHParams' >>= writeDHParams) readDHParams
domainName' :: String -> DomainName
domainName' dom = fromMaybe (error $ "Error: invalid domain name: " ++ dom) (domainName $ fromString dom)
genDHParams' :: IO DHP
genDHParams' = do
hSetBuffering stdout NoBuffering
putStr "Generating DH Params..."
dh <- genDHParams DHGen2 2048
putStrLn " Done."
return dh
combinedCert :: X509 -> Maybe DHP -> Keys -> X509 -> IO String
combinedCert issuerCert dh (Keys privKey _) cert = do
dhStr <- mapM writeDHParams dh
certStr <- writeX509 cert
privKeyStr <- writePKCS8PrivateKey privKey Nothing
issuerCertStr <- writeX509 issuerCert
return $ concat [certStr, issuerCertStr, privKeyStr, fromMaybe "" dhStr]
otherwiseM :: Monad m => m Bool -> m () -> m ()
a `otherwiseM` b = a >>= flip unless b
infixl 0 `otherwiseM`
(<..>) :: String -> String -> String
"." <..> dom = dom
sub <..> dom = sub ++ "." ++ dom
|