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
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | 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 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 Text.Domain.Validate hiding (validate)
import Text.Email.Validate
import qualified Data.Yaml.Config as Yaml
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
}
data AcmeCertRequest = AcmeCertRequest {
acrDomains :: [(DomainName, HttpProvisioner)],
acrSkipDH :: Bool,
acrCertificateDir :: FilePath,
acrUserKeys :: Keys
}
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"
]))
runUpdate :: UpdateOpts -> IO ()
runUpdate UpdateOpts{..} = do
error "test"
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 ())
doesDirectoryExist domainDir `otherwiseM` createDirectory domainDir
challengeDir <- ensureWritableDir optChallengeDir "challenge directory"
void $ ensureWritableDir domainDir "domain directory"
Just keys <- getOrCreateKeys privKeyFile
let req = AcmeCertRequest {..}
acrDomains = map (flip (,) (provisionViaFile challengeDir)) requestDomains
acrSkipDH = optSkipDH
acrUserKeys = keys
acrCertificateDir = domainDir
unless optSkipProvisionCheck $
forM_ acrDomains $ uncurry canProvision >=>
(`unless` error "Error: cannot provision files to web server")
go' directoryUrl terms email issuerCert req
go' :: URI -> URI -> Maybe EmailAddress -> X509 -> AcmeCertRequest -> IO (Either String ())
go' directoryUrl terms email issuerCert acr@AcmeCertRequest{..} = do
Just domainKeys <- getOrCreateKeys $ acrCertificateDir </> "rsa.key"
dh <- saveDhParams acr
certificate <- certify directoryUrl acrUserKeys ((,) terms <$> email) domainKeys acrDomains
for certificate $ saveCertificate issuerCert dh domainKeys acr
saveDhParams :: AcmeCertRequest -> IO (Maybe DHP)
saveDhParams AcmeCertRequest{acrSkipDH, acrCertificateDir} = do
let domainDhFile = acrCertificateDir </> "dhparams.pem"
if acrSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile
saveCertificate :: X509 -> Maybe DHP -> Keys -> AcmeCertRequest -> X509 -> IO ()
saveCertificate issuerCert dh domainKeys AcmeCertRequest{acrCertificateDir} = saveBoth
where
saveBoth x509 = savePEM x509 >> saveCombined x509
saveCombined = combinedCert issuerCert dh domainKeys >=> writeFile domainCombinedFile
savePEM = writeX509 >=> writeFile domainCertFile
domainCombinedFile = acrCertificateDir </> "cert.combined.pem"
domainCertFile = acrCertificateDir </> "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
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: " ++ show 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`
|
