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
|
{-# LANGUAGE FlexibleContexts #-}
{-# 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 qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as LC
import Data.Coerce
import Network.ACME (CSR (..), canProvision, certify,
ensureWritableDir, readKeyFile,
(</>))
import Network.ACME.Encoding (Keys (..), toStrict)
import Network.URI
import OpenSSL
import OpenSSL.EVP.Digest
import OpenSSL.PEM
import OpenSSL.RSA
import OpenSSL.X509.Request
import Options.Applicative hiding (header)
import qualified Options.Applicative as Opt
import System.Directory
import Text.Domain.Validate hiding (validate)
import Text.Email.Validate
stagingDirectoryUrl, liveDirectoryUrl :: URI
Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory"
Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory"
main :: IO ()
main = execParser opts >>= go
where
opts = info (helper <*> cmdopts) (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."
]
data CmdOpts = CmdOpts {
optKeyFile :: String,
optDomains :: [String],
optChallengeDir :: String,
optDomainDir :: Maybe String,
optEmail :: Maybe String,
optTerms :: Maybe String,
optStaging :: Bool
}
defaultTerms :: URI
Just defaultTerms = parseAbsoluteURI "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf"
cmdopts :: Parser CmdOpts
cmdopts = CmdOpts <$> 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 "staging" <> help
(unwords
[ "use staging servers instead of live servers"
, "(generated certificates will not be trusted!)"
]))
genKey :: String -> IO ()
genKey privKeyFile = withOpenSSL $ do
kp <- generateRSAKey' 4096 65537
pem <- writePKCS8PrivateKey kp Nothing
writeFile privKeyFile pem
genReq :: Keys -> [DomainName] -> IO CSR
genReq _ [] = error "genReq called with zero domains"
genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do
Just dig <- getDigestByName "SHA256"
req <- newX509Req
setSubjectName req [("CN", show domain)]
setVersion req 0
setPublicKey req pub
void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))]
signX509Req req priv (Just dig)
CSR . toStrict <$> writeX509ReqDER req
where
nidSubjectAltName = 85
otherwiseM :: Monad m => m Bool -> m () -> m ()
a `otherwiseM` b = a >>= flip unless b
infixl 0 `otherwiseM`
go :: CmdOpts -> IO ()
go CmdOpts { .. } = do
let terms = fromMaybe defaultTerms (join $ parseAbsoluteURI <$> optTerms)
directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl
domainKeyFile = domainDir </> "rsa.key"
domainCSRFile = domainDir </> "csr.der"
domainCertFile = domainDir </> "cert.der"
domainDir = fromMaybe (head optDomains) optDomainDir
privKeyFile = optKeyFile
requestDomains = fromMaybe (error "invalid domain name") $ sequence $ domainName . fromString <$> optDomains
doesFileExist privKeyFile `otherwiseM` genKey privKeyFile
doesDirectoryExist domainDir `otherwiseM` createDirectory domainDir
doesFileExist domainKeyFile `otherwiseM` genKey domainKeyFile
Just keys <- readKeyFile privKeyFile
challengeDir <- ensureWritableDir optChallengeDir "challenge directory"
void $ ensureWritableDir domainDir "domain directory"
forM_ requestDomains $ canProvision challengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory")
csrData <- fromMaybe (error "Error: failed to read domain key file") <$>
readKeyFile domainKeyFile >>= flip genReq requestDomains
B.writeFile domainCSRFile (coerce csrData)
let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail
certificate <- certify directoryUrl keys email terms requestDomains challengeDir csrData
either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate
|
