diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-25 22:40:54 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-25 22:42:23 -0500 |
commit | d54ff778995b369ead6b708d9b6ee8bff31d366d (patch) | |
tree | d8457b095a026c41390d76710c0a3be8c9f4cc4b | |
parent | 3fc632688205e46295803460b5e652751c803d59 (diff) |
generate DH params; use PEM for final output
this needs to be made optional and the DH params should be cached,
because generating them is very slow.
-rw-r--r-- | acme-certify.hs | 24 | ||||
-rw-r--r-- | src/Network/ACME.hs | 29 | ||||
-rw-r--r-- | stack.yaml | 2 |
3 files changed, 40 insertions, 15 deletions
diff --git a/acme-certify.hs b/acme-certify.hs index 360579b..b84a728 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -17,6 +17,8 @@ import Network.ACME (canProvision, certify, fileProvisio | |||
17 | import Network.ACME.Encoding (Keys (..), readKeys) | 17 | import Network.ACME.Encoding (Keys (..), readKeys) |
18 | import Network.URI | 18 | import Network.URI |
19 | import OpenSSL | 19 | import OpenSSL |
20 | import OpenSSL.X509 (X509) | ||
21 | import OpenSSL.DH | ||
20 | import OpenSSL.PEM | 22 | import OpenSSL.PEM |
21 | import OpenSSL.RSA | 23 | import OpenSSL.RSA |
22 | import Options.Applicative hiding (header) | 24 | import Options.Applicative hiding (header) |
@@ -24,6 +26,7 @@ import qualified Options.Applicative as Opt | |||
24 | import System.Directory | 26 | import System.Directory |
25 | import Text.Domain.Validate hiding (validate) | 27 | import Text.Domain.Validate hiding (validate) |
26 | import Text.Email.Validate | 28 | import Text.Email.Validate |
29 | import System.IO | ||
27 | 30 | ||
28 | stagingDirectoryUrl, liveDirectoryUrl :: URI | 31 | stagingDirectoryUrl, liveDirectoryUrl :: URI |
29 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" | 32 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" |
@@ -125,10 +128,29 @@ go CmdOpts { .. } = do | |||
125 | 128 | ||
126 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail | 129 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail |
127 | 130 | ||
131 | let issuerCertFile = "lets-encrypt-x1-cross-signed.pem" | ||
132 | issuerCert <- readFile issuerCertFile >>= readX509 | ||
133 | |||
134 | hSetBuffering stdout NoBuffering | ||
135 | putStr "Generating DH Params..." | ||
136 | dh <- genDHParams DHGen2 2048 | ||
137 | putStrLn " Done." | ||
138 | |||
128 | certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq | 139 | certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq |
129 | 140 | ||
130 | either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate | 141 | either (error . ("Error: " ++)) |
142 | (combinedCert issuerCert (Just dh) domainKeys >=> writeFile domainCertFile) | ||
143 | certificate | ||
144 | |||
145 | combinedCert :: X509 -> Maybe DHP -> Keys -> X509 -> IO String | ||
146 | combinedCert issuerCert dh (Keys privKey _) cert = do | ||
147 | dhStr <- mapM writeDHParams dh | ||
148 | certStr <- writeX509 cert | ||
149 | privKeyStr <- writePKCS8PrivateKey privKey Nothing | ||
150 | issuerCertStr <- writeX509 issuerCert | ||
151 | return $ concat [certStr, issuerCertStr, privKeyStr, fromMaybe "" dhStr] | ||
131 | 152 | ||
132 | otherwiseM :: Monad m => m Bool -> m () -> m () | 153 | otherwiseM :: Monad m => m Bool -> m () -> m () |
133 | a `otherwiseM` b = a >>= flip unless b | 154 | a `otherwiseM` b = a >>= flip unless b |
134 | infixl 0 `otherwiseM` | 155 | infixl 0 `otherwiseM` |
156 | |||
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index f6bffe2..b05b823 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -39,6 +39,7 @@ import OpenSSL | |||
39 | import OpenSSL.EVP.Digest | 39 | import OpenSSL.EVP.Digest |
40 | import OpenSSL.RSA | 40 | import OpenSSL.RSA |
41 | import OpenSSL.X509.Request | 41 | import OpenSSL.X509.Request |
42 | import OpenSSL.X509 (readDerX509, X509) | ||
42 | import Data.List | 43 | import Data.List |
43 | 44 | ||
44 | type HttpProvisioner = URI -> ByteString -> IO () | 45 | type HttpProvisioner = URI -> ByteString -> IO () |
@@ -71,29 +72,31 @@ acmeChallengeURI dom tok = URI | |||
71 | "" | 72 | "" |
72 | "" | 73 | "" |
73 | 74 | ||
74 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String LC.ByteString) | 75 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509) |
75 | certify directoryUrl keys reg provision certReq = | 76 | certify directoryUrl keys reg provision certReq = run >>= traverse readDerX509 |
76 | 77 | ||
77 | runACME directoryUrl keys $ do | 78 | where |
78 | forM_ reg $ uncurry register >=> statusReport | 79 | run = |
80 | runACME directoryUrl keys $ do | ||
81 | forM_ reg $ uncurry register >=> statusReport | ||
79 | 82 | ||
80 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do | 83 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do |
81 | liftIO $ provision (acmeChallengeURI domain token) thumbtoken | 84 | liftIO $ provision (acmeChallengeURI domain token) thumbtoken |
82 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 85 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
83 | 86 | ||
84 | challengeResultLinks <- forM (csrDomains certReq) $ \dom -> | 87 | challengeResultLinks <- forM (csrDomains certReq) $ \dom -> |
85 | challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom | 88 | challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom |
86 | 89 | ||
87 | pollResults challengeResultLinks >>= | 90 | pollResults challengeResultLinks >>= |
88 | either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++)) | 91 | either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++)) |
89 | (const (retrieveCert certReq >>= statusReport <&> checkCertResponse)) | 92 | (const (retrieveCert certReq >>= statusReport <&> checkCertResponse)) |
90 | 93 | ||
91 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) | 94 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) |
92 | pollResults [] = return $ Right () | 95 | pollResults [] = return $ Right () |
93 | pollResults (link:links) = do | 96 | pollResults (link:links) = do |
94 | -- TODO: use "Retry-After" header if present | 97 | -- TODO: use "Retry-After" header if present |
95 | let Just uri = link ^? responseBody . JSON.key "uri" . _String | 98 | let Just uri = link ^? responseBody . JSON.key "uri" . _String |
96 | r <- liftIO $ W.get (T.unpack uri) | 99 | r <- liftIO $ W.get (T.unpack uri) >>= statusReport |
97 | let status = r ^. responseBody . JSON.key "status" . _String | 100 | let status = r ^. responseBody . JSON.key "status" . _String |
98 | case status of | 101 | case status of |
99 | "pending" -> pollResults $ links ++ [r] | 102 | "pending" -> pollResults $ links ++ [r] |
@@ -8,7 +8,7 @@ packages: | |||
8 | - '.' | 8 | - '.' |
9 | - location: | 9 | - location: |
10 | git: git@github.com:afcady/HSOpenSSL.git | 10 | git: git@github.com:afcady/HSOpenSSL.git |
11 | commit: 11f5c83fbe44d6c1c496be4cc3017fd925ba26e2 | 11 | commit: 90679fb0e20514f915c90c0e27774867a30915df |
12 | extra-dep: true | 12 | extra-dep: true |
13 | - location: | 13 | - location: |
14 | git: git@github.com:afcady/email-validate-hs.git | 14 | git: git@github.com:afcady/email-validate-hs.git |