diff options
-rw-r--r-- | acme-certify.hs | 15 | ||||
-rw-r--r-- | src/Network/ACME.hs | 35 |
2 files changed, 34 insertions, 16 deletions
diff --git a/acme-certify.hs b/acme-certify.hs index d20c3e4..cda3d09 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -13,8 +13,7 @@ module Main where | |||
13 | 13 | ||
14 | import BasePrelude | 14 | import BasePrelude |
15 | import qualified Data.ByteString.Lazy.Char8 as LC | 15 | import qualified Data.ByteString.Lazy.Char8 as LC |
16 | import Network.ACME (CSR (..), canProvision, certify, | 16 | import Network.ACME (CSR (..), canProvision, certify, fileProvisioner, ensureWritableDir, (</>), domainToString) |
17 | ensureWritableDir, (</>), domainToString) | ||
18 | import Network.ACME.Encoding (Keys (..), readKeys, toStrict) | 17 | import Network.ACME.Encoding (Keys (..), readKeys, toStrict) |
19 | import Network.URI | 18 | import Network.URI |
20 | import OpenSSL | 19 | import OpenSSL |
@@ -106,7 +105,7 @@ genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do | |||
106 | setPublicKey req pub | 105 | setPublicKey req pub |
107 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))] | 106 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))] |
108 | signX509Req req priv (Just dig) | 107 | signX509Req req priv (Just dig) |
109 | CSR . toStrict <$> writeX509ReqDER req | 108 | CSR domains . toStrict <$> writeX509ReqDER req |
110 | where | 109 | where |
111 | nidSubjectAltName = 85 | 110 | nidSubjectAltName = 85 |
112 | 111 | ||
@@ -133,14 +132,16 @@ go CmdOpts { .. } = do | |||
133 | challengeDir <- ensureWritableDir optChallengeDir "challenge directory" | 132 | challengeDir <- ensureWritableDir optChallengeDir "challenge directory" |
134 | void $ ensureWritableDir domainDir "domain directory" | 133 | void $ ensureWritableDir domainDir "domain directory" |
135 | 134 | ||
136 | forM_ requestDomains $ canProvision challengeDir >=> | 135 | let skipProvisionCheck = True |
137 | (`unless` error "Error: cannot provision files to web server via challenge directory") | 136 | unless skipProvisionCheck $ |
137 | forM_ requestDomains $ canProvision challengeDir >=> | ||
138 | (`unless` error "Error: cannot provision files to web server via challenge directory") | ||
138 | 139 | ||
139 | csrData <- genReq domainKeys requestDomains | 140 | certReq <- genReq domainKeys requestDomains |
140 | 141 | ||
141 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail | 142 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail |
142 | 143 | ||
143 | certificate <- certify directoryUrl keys email terms requestDomains challengeDir csrData | 144 | certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq |
144 | 145 | ||
145 | either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate | 146 | either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate |
146 | 147 | ||
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs index 4df9f9b..5a66028 100644 --- a/src/Network/ACME.hs +++ b/src/Network/ACME.hs | |||
@@ -37,21 +37,38 @@ import Text.Email.Validate | |||
37 | import Text.Domain.Validate hiding (validate) | 37 | import Text.Domain.Validate hiding (validate) |
38 | import Network.URI | 38 | import Network.URI |
39 | 39 | ||
40 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString) | 40 | type HttpProvisioner = URI -> ByteString -> IO () |
41 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData = | 41 | |
42 | fileProvisioner :: WritableDir -> HttpProvisioner | ||
43 | fileProvisioner challengeDir = BC.writeFile . uToF | ||
44 | where | ||
45 | uToF = (coerce challengeDir </>) . takeWhileEnd (/= '/') . uriPath | ||
46 | takeWhileEnd f = reverse . takeWhile f . reverse | ||
47 | |||
48 | acmeChallengeURI :: DomainName -> BC.ByteString -> URI | ||
49 | acmeChallengeURI dom tok = URI | ||
50 | "http:" | ||
51 | (Just $ URIAuth "" (domainToString dom) "") | ||
52 | ("/.well-known/acme-challenge" </> BC.unpack tok) | ||
53 | "" | ||
54 | "" | ||
55 | |||
56 | certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String LC.ByteString) | ||
57 | certify directoryUrl keys reg provision certReq = | ||
42 | 58 | ||
43 | runACME directoryUrl keys $ do | 59 | runACME directoryUrl keys $ do |
44 | forM_ optEmail $ register terms >=> statusReport | 60 | forM_ reg $ uncurry register >=> statusReport |
45 | 61 | ||
46 | let performChallenge (ChallengeRequest nextUri token thumbtoken) = do | 62 | let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do |
47 | liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken | 63 | liftIO $ provision (acmeChallengeURI domain token) thumbtoken |
48 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 64 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
49 | 65 | ||
50 | challengeResultLinks <- forM requestDomains $ challengeRequest >=> statusReport >=> extractCR >=> performChallenge | 66 | challengeResultLinks <- forM (csrDomains certReq) $ \dom -> |
67 | challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom | ||
51 | 68 | ||
52 | pollResults challengeResultLinks >>= | 69 | pollResults challengeResultLinks >>= |
53 | either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++)) | 70 | either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++)) |
54 | (const (retrieveCert csrData >>= statusReport <&> checkCertResponse)) | 71 | (const (retrieveCert certReq >>= statusReport <&> checkCertResponse)) |
55 | 72 | ||
56 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) | 73 | pollResults :: [Response LC.ByteString] -> ACME (Either String ()) |
57 | pollResults [] = return $ Right () | 74 | pollResults [] = return $ Right () |
@@ -68,7 +85,7 @@ pollResults (link:links) = do | |||
68 | 85 | ||
69 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } | 86 | data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString } |
70 | 87 | ||
71 | newtype CSR = CSR ByteString | 88 | data CSR = CSR { csrDomains :: [DomainName], csrData :: ByteString } |
72 | 89 | ||
73 | newtype WritableDir = WritableDir String | 90 | newtype WritableDir = WritableDir String |
74 | ensureWritableDir :: FilePath -> String -> IO WritableDir | 91 | ensureWritableDir :: FilePath -> String -> IO WritableDir |
@@ -137,7 +154,7 @@ checkCertResponse r = | |||
137 | isSuccess n = n >= 200 && n <= 300 | 154 | isSuccess n = n >= 200 && n <= 300 |
138 | 155 | ||
139 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) | 156 | retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString) |
140 | retrieveCert input = sendPayload _newCert (csr $ coerce input) | 157 | retrieveCert input = sendPayload _newCert (csr $ csrData input) |
141 | 158 | ||
142 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) | 159 | notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString) |
143 | notifyChallenge uri thumbtoken = sendPayload (const uri) (challenge thumbtoken) | 160 | notifyChallenge uri thumbtoken = sendPayload (const uri) (challenge thumbtoken) |