diff options
author | Andrew Cady <d@jerkface.net> | 2016-01-20 22:58:39 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-01-20 22:58:39 -0500 |
commit | d6bb99752c20ffd7ea1679c651563963a216556c (patch) | |
tree | 56ee409c21c2919d83b06146b6bfe98faff2b2cc | |
parent | 7fe2488ce345f261c2d99746788e4037069fe9bb (diff) |
More debug logging
I have no idea why it doesn't work. "Let's Encrypt" servers hit
my server. The file hosted on my server matches the value in the
"keyAuthorization" field I get back from them. What is wrong??
Maybe it's not the code, but something related to my domain?
-rw-r--r-- | acme.hs | 49 |
1 files changed, 29 insertions, 20 deletions
@@ -5,6 +5,8 @@ | |||
5 | 5 | ||
6 | -------------------------------------------------------------------------------- | 6 | -------------------------------------------------------------------------------- |
7 | -- | Get a certificate from Let's Encrypt using the ACME protocol. | 7 | -- | Get a certificate from Let's Encrypt using the ACME protocol. |
8 | -- | ||
9 | -- https://github.com/ietf-wg-acme/acme/blob/master/draft-ietf-acme-acme.md | ||
8 | 10 | ||
9 | module Main where | 11 | module Main where |
10 | 12 | ||
@@ -113,10 +115,16 @@ go (CmdOpts privKeyFile domain challengeDir email termOverride) = do | |||
113 | 115 | ||
114 | token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 | 116 | token = r ^?! httpChallenge . JSON.key "token" . _String . to encodeUtf8 |
115 | crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack | 117 | crUri = r ^?! httpChallenge . JSON.key "uri" . _String . to T.unpack |
118 | |||
116 | thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) | 119 | thumb = thumbprint (JWK (rsaE pub) "RSA" (rsaN pub)) |
117 | thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) | 120 | thumbtoken = toStrict (LB.fromChunks [token, ".", thumb]) |
118 | 121 | ||
119 | liftIO $ writeFile (challengeDir </> BC.unpack token) (BC.unpack thumbtoken) | 122 | liftIO $ do |
123 | mapM_ print $ r ^@.. httpChallenge . members | ||
124 | print $ encodeOrdered (JWK (rsaE pub) "RSA" (rsaN pub)) | ||
125 | |||
126 | -- liftIO $ LC.writeFile (challengeDir </> BC.unpack token) p | ||
127 | liftIO $ BC.writeFile (challengeDir </> BC.unpack token) thumbtoken | ||
120 | 128 | ||
121 | -- Wait for challenge validation | 129 | -- Wait for challenge validation |
122 | -- TODO: first hit the local server to test whether this is valid | 130 | -- TODO: first hit the local server to test whether this is valid |
@@ -128,10 +136,7 @@ go (CmdOpts privKeyFile domain challengeDir email termOverride) = do | |||
128 | -- Send a CSR and get a certificate | 136 | -- Send a CSR and get a certificate |
129 | void $ saveCert csrData domainCertFile >>= statusReport | 137 | void $ saveCert csrData domainCertFile >>= statusReport |
130 | 138 | ||
131 | else liftIO $ do | 139 | else liftIO $ putStrLn "Error" |
132 | putStrLn "Error" | ||
133 | print r | ||
134 | print $ r ^? responseBody . JSON.key "status" . _String | ||
135 | 140 | ||
136 | where | 141 | where |
137 | a </> b = a ++ "/" ++ b | 142 | a </> b = a ++ "/" ++ b |
@@ -144,19 +149,23 @@ saveCert input output = do | |||
144 | return r | 149 | return r |
145 | 150 | ||
146 | pollChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | 151 | pollChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) |
147 | pollChallenge crUri thumbtoken = do | 152 | pollChallenge crUri thumbtoken = loop |
148 | liftIO $ putStrLn "polling..." | 153 | where |
149 | r <- sendPayload (const crUri) (challenge thumbtoken) >>= statusReport | 154 | loop = do |
150 | let status = r ^? responseBody . JSON.key "status" . _String | ||
151 | if status == Just "pending" | ||
152 | then do | ||
153 | liftIO . print $ r ^. responseBody | ||
154 | liftIO . threadDelay $ 2000 * 1000 | 155 | liftIO . threadDelay $ 2000 * 1000 |
155 | pollChallenge crUri thumbtoken | 156 | liftIO $ putStrLn "polling..." |
156 | else do | 157 | r <- sendPayload (const crUri) (challenge thumbtoken) >>= statusReport |
157 | liftIO $ putStrLn "done polling." | 158 | let status = r ^? responseBody . JSON.key "status" . _String |
158 | liftIO $ print r | 159 | if status == Just "pending" |
159 | return r | 160 | then do |
161 | liftIO . print $ r ^. responseBody | ||
162 | liftIO . print $ r ^? responseBody . JSON.key "keyAuthorization" . _String | ||
163 | liftIO . threadDelay $ 2000 * 1000 | ||
164 | loop | ||
165 | else do | ||
166 | liftIO $ putStrLn "done polling." | ||
167 | liftIO $ print r | ||
168 | return r | ||
160 | 169 | ||
161 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } | 170 | data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } |
162 | 171 | ||
@@ -246,7 +255,7 @@ header' key = Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) Nothing | |||
246 | 255 | ||
247 | header :: RSAKey k => k -> String -> ByteString | 256 | header :: RSAKey k => k -> String -> ByteString |
248 | header key nonce = (toStrict . encode) | 257 | header key nonce = (toStrict . encode) |
249 | (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce)) | 258 | (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce)) |
250 | 259 | ||
251 | -- | Registration payload to sign with user key. | 260 | -- | Registration payload to sign with user key. |
252 | registration :: String -> String -> ByteString | 261 | registration :: String -> String -> ByteString |
@@ -265,7 +274,7 @@ csr :: ByteString -> ByteString | |||
265 | csr = b64 . toStrict . encode . CSR . b64 | 274 | csr = b64 . toStrict . encode . CSR . b64 |
266 | 275 | ||
267 | thumbprint :: JWK -> ByteString | 276 | thumbprint :: JWK -> ByteString |
268 | thumbprint = b64 . toStrict .bytestringDigest . sha256 . encodeOrdered | 277 | thumbprint = b64 . toStrict . bytestringDigest . sha256 . encodeOrdered |
269 | 278 | ||
270 | -- | There is an `encodePretty'` in `aeson-pretty`, but do it by hand here. | 279 | -- | There is an `encodePretty'` in `aeson-pretty`, but do it by hand here. |
271 | encodeOrdered :: JWK -> LB.ByteString | 280 | encodeOrdered :: JWK -> LB.ByteString |
@@ -295,7 +304,7 @@ instance ToJSON Header where | |||
295 | toJSON Header{..} = object $ | 304 | toJSON Header{..} = object $ |
296 | [ "alg" .= hAlg | 305 | [ "alg" .= hAlg |
297 | , "jwk" .= toJSON hJwk | 306 | , "jwk" .= toJSON hJwk |
298 | ] ++ maybe [] ((:[]) . ("nonce" .=)) hNonce | 307 | ] ++ maybeToList (("nonce" .=) <$> hNonce) |
299 | 308 | ||
300 | instance ToJSON JWK where | 309 | instance ToJSON JWK where |
301 | toJSON JWK{..} = object | 310 | toJSON JWK{..} = object |