diff options
-rw-r--r-- | acme-certify.cabal | 10 | ||||
-rw-r--r-- | acme-certify.hs | 176 | ||||
-rw-r--r-- | src/Network/ACME.hs | 181 |
3 files changed, 193 insertions, 174 deletions
diff --git a/acme-certify.cabal b/acme-certify.cabal index e7340ea..ec7afbb 100644 --- a/acme-certify.cabal +++ b/acme-certify.cabal | |||
@@ -13,10 +13,11 @@ cabal-version: >=1.10 | |||
13 | 13 | ||
14 | library | 14 | library |
15 | hs-source-dirs: src | 15 | hs-source-dirs: src |
16 | exposed-modules: Network.ACME.Encoding | 16 | exposed-modules: Network.ACME, Network.ACME.Encoding |
17 | build-depends: base >= 4.7 && < 5, | 17 | build-depends: base >= 4.7 && < 5, |
18 | cryptonite, aeson, bytestring, base64-bytestring, SHA, | 18 | cryptonite, aeson, bytestring, base64-bytestring, SHA, |
19 | text, HsOpenSSL, time, email-validate | 19 | mtl, text, HsOpenSSL, wreq, lens, lens-aeson, time, |
20 | email-validate, pipes, directory, network-uri | ||
20 | default-language: Haskell2010 | 21 | default-language: Haskell2010 |
21 | 22 | ||
22 | executable acme-certify | 23 | executable acme-certify |
@@ -25,9 +26,8 @@ executable acme-certify | |||
25 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall | 26 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall |
26 | build-depends: base, acme-certify, | 27 | build-depends: base, acme-certify, |
27 | cryptonite, aeson, bytestring, base64-bytestring, SHA, | 28 | cryptonite, aeson, bytestring, base64-bytestring, SHA, |
28 | text, HsOpenSSL, wreq, lens, lens-aeson, | 29 | text, HsOpenSSL, optparse-applicative, time, |
29 | optparse-applicative, directory, mtl, time, pipes, | 30 | email-validate, network-uri, directory |
30 | email-validate, network-uri | ||
31 | default-language: Haskell2010 | 31 | default-language: Haskell2010 |
32 | 32 | ||
33 | -- test-suite acme-certify-test | 33 | -- test-suite acme-certify-test |
diff --git a/acme-certify.hs b/acme-certify.hs index fecd632..07c2942 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -10,31 +10,15 @@ | |||
10 | 10 | ||
11 | module Main where | 11 | module Main where |
12 | 12 | ||
13 | import Control.Lens hiding (each, (.=)) | ||
14 | import Control.Monad | 13 | import Control.Monad |
15 | import Control.Monad.RWS.Strict | ||
16 | import Data.Aeson (Value) | ||
17 | import Data.Aeson.Lens hiding (key) | ||
18 | import qualified Data.Aeson.Lens as JSON | ||
19 | import Data.ByteString (ByteString) | ||
20 | import qualified Data.ByteString as B | 14 | import qualified Data.ByteString as B |
21 | import qualified Data.ByteString.Char8 as BC | ||
22 | import qualified Data.ByteString.Lazy as LB | ||
23 | import qualified Data.ByteString.Lazy.Char8 as LC | 15 | import qualified Data.ByteString.Lazy.Char8 as LC |
24 | import Data.Coerce | 16 | import Data.Coerce |
25 | import Data.List | 17 | import Data.List |
26 | import Data.Maybe | 18 | import Data.Maybe |
27 | import Data.String (fromString) | 19 | import Data.String (fromString) |
28 | import qualified Data.Text as T | 20 | import Network.ACME (certify, readKeyFile, (</>), ensureWritableDir, canProvision, CSR(..)) |
29 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) | 21 | import Network.ACME.Encoding (Keys(..), toStrict) |
30 | import Data.Time.Clock.POSIX (getPOSIXTime) | ||
31 | import Network.ACME.Encoding | ||
32 | import Network.Wreq (Response, checkStatus, defaults, | ||
33 | responseBody, responseHeader, | ||
34 | responseStatus, statusCode, | ||
35 | statusMessage) | ||
36 | import qualified Network.Wreq as W | ||
37 | import qualified Network.Wreq.Session as WS | ||
38 | import OpenSSL | 22 | import OpenSSL |
39 | import OpenSSL.EVP.Digest | 23 | import OpenSSL.EVP.Digest |
40 | import OpenSSL.PEM | 24 | import OpenSSL.PEM |
@@ -42,7 +26,6 @@ import OpenSSL.RSA | |||
42 | import OpenSSL.X509.Request | 26 | import OpenSSL.X509.Request |
43 | import Options.Applicative hiding (header) | 27 | import Options.Applicative hiding (header) |
44 | import qualified Options.Applicative as Opt | 28 | import qualified Options.Applicative as Opt |
45 | import Pipes | ||
46 | import System.Directory | 29 | import System.Directory |
47 | import Text.Email.Validate | 30 | import Text.Email.Validate |
48 | import Text.Domain.Validate hiding (validate) | 31 | import Text.Domain.Validate hiding (validate) |
@@ -115,10 +98,9 @@ genKey privKeyFile = withOpenSSL $ do | |||
115 | pem <- writePKCS8PrivateKey kp Nothing | 98 | pem <- writePKCS8PrivateKey kp Nothing |
116 | writeFile privKeyFile pem | 99 | writeFile privKeyFile pem |
117 | 100 | ||
118 | genReq :: FilePath -> [DomainName] -> IO LC.ByteString | 101 | genReq :: Keys -> [DomainName] -> IO CSR |
119 | genReq _ [] = error "genReq called with zero domains" | 102 | genReq _ [] = error "genReq called with zero domains" |
120 | genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do | 103 | genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do |
121 | Just (Keys priv pub) <- readKeyFile domainKeyFile | ||
122 | Just dig <- getDigestByName "SHA256" | 104 | Just dig <- getDigestByName "SHA256" |
123 | req <- newX509Req | 105 | req <- newX509Req |
124 | setSubjectName req [("CN", show domain)] | 106 | setSubjectName req [("CN", show domain)] |
@@ -126,15 +108,10 @@ genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do | |||
126 | setPublicKey req pub | 108 | setPublicKey req pub |
127 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] | 109 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] |
128 | signX509Req req priv (Just dig) | 110 | signX509Req req priv (Just dig) |
129 | writeX509ReqDER req | 111 | CSR . toStrict <$> writeX509ReqDER req |
130 | where | 112 | where |
131 | nidSubjectAltName = 85 | 113 | nidSubjectAltName = 85 |
132 | 114 | ||
133 | readKeyFile :: FilePath -> IO (Maybe Keys) | ||
134 | readKeyFile = readFile >=> readKeys | ||
135 | |||
136 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } | ||
137 | |||
138 | otherwiseM :: Monad m => m Bool -> m () -> m () | 115 | otherwiseM :: Monad m => m Bool -> m () -> m () |
139 | a `otherwiseM` b = a >>= flip unless b | 116 | a `otherwiseM` b = a >>= flip unless b |
140 | infixl 0 `otherwiseM` | 117 | infixl 0 `otherwiseM` |
@@ -162,7 +139,8 @@ go CmdOpts { .. } = do | |||
162 | 139 | ||
163 | forM_ requestDomains $ canProvision challengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") | 140 | forM_ requestDomains $ canProvision challengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") |
164 | 141 | ||
165 | csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains | 142 | csrData <- fromMaybe (error "Error: failed to read domain key file") <$> |
143 | readKeyFile domainKeyFile >>= flip genReq requestDomains | ||
166 | B.writeFile domainCSRFile (coerce csrData) | 144 | B.writeFile domainCSRFile (coerce csrData) |
167 | 145 | ||
168 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail | 146 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail |
@@ -171,143 +149,3 @@ go CmdOpts { .. } = do | |||
171 | 149 | ||
172 | either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate | 150 | either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate |
173 | 151 | ||
174 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString) | ||
175 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData = | ||
176 | |||
177 | runACME directoryUrl keys $ do | ||
178 | forM_ optEmail $ register terms >=> statusReport | ||
179 | |||
180 | let producer :: Producer ChallengeRequest ACME () | ||
181 | producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield | ||
182 | consumer :: Consumer ChallengeRequest ACME () | ||
183 | consumer = forever $ await >>= consume1 | ||
184 | consume1 (ChallengeRequest nextUri token thumbtoken) = do | ||
185 | lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken | ||
186 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | ||
187 | |||
188 | runEffect $ producer >-> consumer | ||
189 | |||
190 | retrieveCert csrData >>= statusReport <&> checkCertResponse | ||
191 | |||
192 | newtype CSR = CSR ByteString | ||
193 | |||
194 | (</>) :: String -> String -> String | ||
195 | a </> b = a ++ "/" ++ b | ||
196 | infixr 5 </> | ||
197 | |||
198 | canProvision :: WritableDir -> DomainName -> IO Bool | ||
199 | canProvision challengeDir domain = do | ||
200 | randomish <- fromString . show <$> getPOSIXTime | ||
201 | |||
202 | let absFile = coerce challengeDir </> relFile | ||
203 | relFile = ".test." ++ show randomish | ||
204 | |||
205 | LC.writeFile absFile randomish | ||
206 | r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile | ||
207 | removeFile absFile | ||
208 | return $ r ^. responseBody == randomish | ||
209 | |||
210 | |||
211 | newtype WritableDir = WritableDir String | ||
212 | ensureWritableDir :: FilePath -> String -> IO WritableDir | ||
213 | ensureWritableDir file name = do | ||
214 | (writable <$> getPermissions file) >>= flip unless (err name) | ||
215 | return $ WritableDir file | ||
216 | where err n = error $ "Error: " ++ n ++ " is not writable" | ||
217 | |||
218 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest | ||
219 | extractCR r = do | ||
220 | Keys _ pub <- asks getKeys | ||
221 | let httpChallenge :: (Value -> Const (Endo s) Value) -> Response LC.ByteString -> Const (Endo s) (Response LC.ByteString) | ||
222 | httpChallenge = responseBody . | ||
223 | JSON.key "challenges" . | ||
224 | to universe . | ||
225 | traverse . | ||
226 | (filtered . has $ ix "type" . only "http-01") | ||
227 | |||
228 | token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 | ||
229 | crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack | ||
230 | |||
231 | thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) | ||
232 | thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) | ||
233 | |||
234 | return $ ChallengeRequest crUri token thumbtoken | ||
235 | |||
236 | ncErrorReport :: (Show body, AsValue body, MonadIO m) => Response body -> m () | ||
237 | ncErrorReport r = | ||
238 | when (Just "pending" /= r ^? responseBody . JSON.key "status" . _String) $ liftIO $ do | ||
239 | putStrLn "Unexpected response to challenge-response request:" | ||
240 | print r | ||
241 | |||
242 | checkCertResponse :: Response LC.ByteString -> Either String LC.ByteString | ||
243 | checkCertResponse r = | ||
244 | if isSuccess $ r ^. responseStatus . statusCode | ||
245 | then Right $ r ^. responseBody | ||
246 | else | ||
247 | let (summary, details) = (k "type", k "detail") | ||
248 | k x = r ^?! responseBody . JSON.key x . _String . to T.unpack | ||
249 | in Left $ summary ++ " ---- " ++ details | ||
250 | where | ||
251 | isSuccess n = n >= 200 && n <= 300 | ||
252 | |||
253 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) | ||
254 | retrieveCert input = sendPayload _newCert (csr $ coerce input) | ||
255 | |||
256 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | ||
257 | notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken) | ||
258 | |||
259 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } | ||
260 | |||
261 | type ACME = RWST Env () Nonce IO | ||
262 | runACME :: URI -> Keys -> ACME a -> IO a | ||
263 | runACME url keys f = WS.withSession $ \sess -> do | ||
264 | Just (dir, nonce) <- getDirectory sess (show url) | ||
265 | fst <$> evalRWST f (Env dir keys sess) nonce | ||
266 | |||
267 | data Directory = Directory { | ||
268 | _newCert :: String, | ||
269 | _newAuthz :: String, | ||
270 | _revokeCert :: String, | ||
271 | _newReg :: String | ||
272 | } | ||
273 | newtype Nonce = Nonce String | ||
274 | |||
275 | getDirectory :: WS.Session -> String -> IO (Maybe (Directory, Nonce)) | ||
276 | getDirectory sess url = do | ||
277 | r <- WS.get sess url | ||
278 | let nonce = r ^? responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
279 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack | ||
280 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce | ||
281 | |||
282 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) | ||
283 | register terms email = sendPayload _newReg (registration email (show terms)) | ||
284 | |||
285 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) | ||
286 | challengeRequest = sendPayload _newAuthz . authz . show | ||
287 | |||
288 | statusLine :: Response body -> String | ||
289 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) | ||
290 | |||
291 | statusReport :: MonadIO m => Response body -> m (Response body) | ||
292 | statusReport r = do | ||
293 | liftIO $ putStrLn $ statusLine r | ||
294 | return r | ||
295 | |||
296 | sendPayload :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => (Directory -> String) -> ByteString -> m (Response LC.ByteString) | ||
297 | sendPayload reqType payload = do | ||
298 | keys <- asks getKeys | ||
299 | dir <- asks getDir | ||
300 | nonce <- gets coerce | ||
301 | signed <- liftIO $ signPayload keys nonce payload | ||
302 | post (reqType dir) signed | ||
303 | |||
304 | post :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> LC.ByteString -> m (Response LC.ByteString) | ||
305 | post url payload = do | ||
306 | sess <- asks getSession | ||
307 | r <- liftIO $ WS.postWith noStatusCheck sess url payload | ||
308 | put $ r ^?! responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
309 | return r | ||
310 | where | ||
311 | noStatusCheck = defaults & checkStatus .~ Just nullChecker | ||
312 | nullChecker _ _ _ = Nothing | ||
313 | |||
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs new file mode 100644 index 0000000..116a291 --- /dev/null +++ b/src/Network/ACME.hs | |||
@@ -0,0 +1,181 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | {-# LANGUAGE ScopedTypeVariables #-} | ||
4 | |||
5 | -------------------------------------------------------------------------------- | ||
6 | -- | Get a certificate from Let's Encrypt using the ACME protocol. | ||
7 | -- | ||
8 | -- https://github.com/ietf-wg-acme/acme/blob/master/draft-ietf-acme-acme.md | ||
9 | |||
10 | module Network.ACME where | ||
11 | |||
12 | import Control.Lens hiding (each, (.=)) | ||
13 | import Control.Monad | ||
14 | import Control.Monad.RWS.Strict | ||
15 | import Data.Aeson (Value) | ||
16 | import Data.Aeson.Lens hiding (key) | ||
17 | import qualified Data.Aeson.Lens as JSON | ||
18 | import Data.ByteString (ByteString) | ||
19 | import qualified Data.ByteString.Char8 as BC | ||
20 | import qualified Data.ByteString.Lazy as LB | ||
21 | import qualified Data.ByteString.Lazy.Char8 as LC | ||
22 | import Data.Coerce | ||
23 | import Data.String (fromString) | ||
24 | import qualified Data.Text as T | ||
25 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) | ||
26 | import Data.Time.Clock.POSIX (getPOSIXTime) | ||
27 | import Network.ACME.Encoding | ||
28 | import Network.Wreq (Response, checkStatus, defaults, | ||
29 | responseBody, responseHeader, | ||
30 | responseStatus, statusCode, | ||
31 | statusMessage) | ||
32 | import qualified Network.Wreq as W | ||
33 | import qualified Network.Wreq.Session as WS | ||
34 | import OpenSSL.RSA | ||
35 | import Pipes | ||
36 | import System.Directory | ||
37 | import Text.Email.Validate | ||
38 | import Text.Domain.Validate hiding (validate) | ||
39 | import Network.URI | ||
40 | |||
41 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString) | ||
42 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData = | ||
43 | |||
44 | runACME directoryUrl keys $ do | ||
45 | forM_ optEmail $ register terms >=> statusReport | ||
46 | |||
47 | let producer :: Producer ChallengeRequest ACME () | ||
48 | producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield | ||
49 | consumer :: Consumer ChallengeRequest ACME () | ||
50 | consumer = forever $ await >>= consume1 | ||
51 | consume1 (ChallengeRequest nextUri token thumbtoken) = do | ||
52 | lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken | ||
53 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | ||
54 | |||
55 | runEffect $ producer >-> consumer | ||
56 | |||
57 | retrieveCert csrData >>= statusReport <&> checkCertResponse | ||
58 | |||
59 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } | ||
60 | |||
61 | newtype CSR = CSR ByteString | ||
62 | |||
63 | newtype WritableDir = WritableDir String | ||
64 | ensureWritableDir :: FilePath -> String -> IO WritableDir | ||
65 | ensureWritableDir file name = do | ||
66 | (writable <$> getPermissions file) >>= flip unless (err name) | ||
67 | return $ WritableDir file | ||
68 | where err n = error $ "Error: " ++ n ++ " is not writable" | ||
69 | |||
70 | (</>) :: String -> String -> String | ||
71 | a </> b = a ++ "/" ++ b | ||
72 | infixr 5 </> | ||
73 | |||
74 | canProvision :: WritableDir -> DomainName -> IO Bool | ||
75 | canProvision challengeDir domain = do | ||
76 | randomish <- fromString . show <$> getPOSIXTime | ||
77 | |||
78 | let absFile = coerce challengeDir </> relFile | ||
79 | relFile = ".test." ++ show randomish | ||
80 | |||
81 | LC.writeFile absFile randomish | ||
82 | r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile | ||
83 | removeFile absFile | ||
84 | return $ r ^. responseBody == randomish | ||
85 | |||
86 | |||
87 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest | ||
88 | extractCR r = do | ||
89 | Keys _ pub <- asks getKeys | ||
90 | let httpChallenge :: (Value -> Const (Endo s) Value) -> Response LC.ByteString -> Const (Endo s) (Response LC.ByteString) | ||
91 | httpChallenge = responseBody . | ||
92 | JSON.key "challenges" . | ||
93 | to universe . | ||
94 | traverse . | ||
95 | (filtered . has $ ix "type" . only "http-01") | ||
96 | |||
97 | token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 | ||
98 | crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack | ||
99 | |||
100 | thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) | ||
101 | thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) | ||
102 | |||
103 | return $ ChallengeRequest crUri token thumbtoken | ||
104 | |||
105 | ncErrorReport :: (Show body, AsValue body, MonadIO m) => Response body -> m () | ||
106 | ncErrorReport r = | ||
107 | when (Just "pending" /= r ^? responseBody . JSON.key "status" . _String) $ liftIO $ do | ||
108 | putStrLn "Unexpected response to challenge-response request:" | ||
109 | print r | ||
110 | |||
111 | checkCertResponse :: Response LC.ByteString -> Either String LC.ByteString | ||
112 | checkCertResponse r = | ||
113 | if isSuccess $ r ^. responseStatus . statusCode | ||
114 | then Right $ r ^. responseBody | ||
115 | else | ||
116 | let (summary, details) = (k "type", k "detail") | ||
117 | k x = r ^?! responseBody . JSON.key x . _String . to T.unpack | ||
118 | in Left $ summary ++ " ---- " ++ details | ||
119 | where | ||
120 | isSuccess n = n >= 200 && n <= 300 | ||
121 | |||
122 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) | ||
123 | retrieveCert input = sendPayload _newCert (csr $ coerce input) | ||
124 | |||
125 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | ||
126 | notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken) | ||
127 | |||
128 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } | ||
129 | |||
130 | type ACME = RWST Env () Nonce IO | ||
131 | runACME :: URI -> Keys -> ACME a -> IO a | ||
132 | runACME url keys f = WS.withSession $ \sess -> do | ||
133 | Just (dir, nonce) <- getDirectory sess (show url) | ||
134 | fst <$> evalRWST f (Env dir keys sess) nonce | ||
135 | |||
136 | data Directory = Directory { | ||
137 | _newCert :: String, | ||
138 | _newAuthz :: String, | ||
139 | _revokeCert :: String, | ||
140 | _newReg :: String | ||
141 | } | ||
142 | newtype Nonce = Nonce String | ||
143 | |||
144 | getDirectory :: WS.Session -> String -> IO (Maybe (Directory, Nonce)) | ||
145 | getDirectory sess url = do | ||
146 | r <- WS.get sess url | ||
147 | let nonce = r ^? responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
148 | k x = r ^? responseBody . JSON.key x . _String . to T.unpack | ||
149 | return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce | ||
150 | |||
151 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) | ||
152 | register terms email = sendPayload _newReg (registration email (show terms)) | ||
153 | |||
154 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) | ||
155 | challengeRequest = sendPayload _newAuthz . authz . show | ||
156 | |||
157 | statusLine :: Response body -> String | ||
158 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) | ||
159 | |||
160 | statusReport :: MonadIO m => Response body -> m (Response body) | ||
161 | statusReport r = do | ||
162 | liftIO $ putStrLn $ statusLine r | ||
163 | return r | ||
164 | |||
165 | sendPayload :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => (Directory -> String) -> ByteString -> m (Response LC.ByteString) | ||
166 | sendPayload reqType payload = do | ||
167 | keys <- asks getKeys | ||
168 | dir <- asks getDir | ||
169 | nonce <- gets coerce | ||
170 | signed <- liftIO $ signPayload keys nonce payload | ||
171 | post (reqType dir) signed | ||
172 | |||
173 | post :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> LC.ByteString -> m (Response LC.ByteString) | ||
174 | post url payload = do | ||
175 | sess <- asks getSession | ||
176 | r <- liftIO $ WS.postWith noStatusCheck sess url payload | ||
177 | put $ r ^?! responseHeader "Replay-Nonce" . to (Nonce . T.unpack . decodeUtf8) | ||
178 | return r | ||
179 | where | ||
180 | noStatusCheck = defaults & checkStatus .~ Just nullChecker | ||
181 | nullChecker _ _ _ = Nothing | ||