diff options
Diffstat (limited to 'acme.hs')
-rw-r--r-- | acme.hs | 43 |
1 files changed, 23 insertions, 20 deletions
@@ -44,8 +44,9 @@ import Options.Applicative hiding (header) | |||
44 | import qualified Options.Applicative as Opt | 44 | import qualified Options.Applicative as Opt |
45 | import Pipes | 45 | import Pipes |
46 | import System.Directory | 46 | import System.Directory |
47 | import Text.Email.Validate | 47 | import Text.Email.Validate |
48 | import Network.URI | 48 | import Text.Domain.Validate hiding (validate) |
49 | import Network.URI | ||
49 | 50 | ||
50 | stagingDirectoryUrl, liveDirectoryUrl :: URI | 51 | stagingDirectoryUrl, liveDirectoryUrl :: URI |
51 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" | 52 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" |
@@ -114,16 +115,16 @@ genKey privKeyFile = withOpenSSL $ do | |||
114 | pem <- writePKCS8PrivateKey kp Nothing | 115 | pem <- writePKCS8PrivateKey kp Nothing |
115 | writeFile privKeyFile pem | 116 | writeFile privKeyFile pem |
116 | 117 | ||
117 | genReq :: FilePath -> [String] -> IO LC.ByteString | 118 | genReq :: FilePath -> [DomainName] -> IO LC.ByteString |
118 | genReq _ [] = error "genReq called with zero domains" | 119 | genReq _ [] = error "genReq called with zero domains" |
119 | genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do | 120 | genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do |
120 | Just (Keys priv pub) <- readKeyFile domainKeyFile | 121 | Just (Keys priv pub) <- readKeyFile domainKeyFile |
121 | Just dig <- getDigestByName "SHA256" | 122 | Just dig <- getDigestByName "SHA256" |
122 | req <- newX509Req | 123 | req <- newX509Req |
123 | setSubjectName req [("CN", domain)] | 124 | setSubjectName req [("CN", show domain)] |
124 | setVersion req 0 | 125 | setVersion req 0 |
125 | setPublicKey req pub | 126 | setPublicKey req pub |
126 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map ("DNS:" ++) domains))] | 127 | void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] |
127 | signX509Req req priv (Just dig) | 128 | signX509Req req priv (Just dig) |
128 | writeX509ReqDER req | 129 | writeX509ReqDER req |
129 | where | 130 | where |
@@ -147,7 +148,7 @@ go CmdOpts { .. } = do | |||
147 | domainCertFile = domainDir </> "cert.der" | 148 | domainCertFile = domainDir </> "cert.der" |
148 | domainDir = fromMaybe (head optDomains) optDomainDir | 149 | domainDir = fromMaybe (head optDomains) optDomainDir |
149 | privKeyFile = optKeyFile | 150 | privKeyFile = optKeyFile |
150 | requestDomains = optDomains | 151 | requestDomains = fromMaybe (error "invalid domain name") $ sequence $ domainName . fromString <$> optDomains |
151 | 152 | ||
152 | doesFileExist privKeyFile `otherwiseM` genKey privKeyFile | 153 | doesFileExist privKeyFile `otherwiseM` genKey privKeyFile |
153 | 154 | ||
@@ -156,20 +157,19 @@ go CmdOpts { .. } = do | |||
156 | 157 | ||
157 | Just keys <- readKeyFile privKeyFile | 158 | Just keys <- readKeyFile privKeyFile |
158 | 159 | ||
159 | ensureWritable optChallengeDir "challenge directory" | 160 | challengeDir <- ensureWritableDir optChallengeDir "challenge directory" |
160 | ensureWritable domainDir "domain directory" | 161 | void $ ensureWritableDir domainDir "domain directory" |
161 | 162 | ||
162 | forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") | 163 | forM_ requestDomains $ canProvision challengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") |
163 | 164 | ||
164 | csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains | 165 | csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains |
165 | B.writeFile domainCSRFile (coerce csrData) | 166 | B.writeFile domainCSRFile (coerce csrData) |
166 | 167 | ||
167 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail | 168 | let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail |
168 | 169 | ||
169 | certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile | 170 | certify directoryUrl keys email terms requestDomains challengeDir csrData domainCertFile |
170 | 171 | ||
171 | type DomainName = String -- TODO: use validated type | 172 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> FilePath -> IO () |
172 | certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> String -> CSR -> FilePath -> IO () | ||
173 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = | 173 | certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = |
174 | 174 | ||
175 | runACME directoryUrl keys $ do | 175 | runACME directoryUrl keys $ do |
@@ -180,7 +180,7 @@ certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData | |||
180 | consumer :: Consumer ChallengeRequest ACME () | 180 | consumer :: Consumer ChallengeRequest ACME () |
181 | consumer = forever $ await >>= consume1 | 181 | consumer = forever $ await >>= consume1 |
182 | consume1 (ChallengeRequest nextUri token thumbtoken) = do | 182 | consume1 (ChallengeRequest nextUri token thumbtoken) = do |
183 | lift $ liftIO $ BC.writeFile (optChallengeDir </> BC.unpack token) thumbtoken | 183 | lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken |
184 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport | 184 | notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport |
185 | 185 | ||
186 | runEffect $ producer >-> consumer | 186 | runEffect $ producer >-> consumer |
@@ -193,21 +193,24 @@ newtype CSR = CSR ByteString | |||
193 | a </> b = a ++ "/" ++ b | 193 | a </> b = a ++ "/" ++ b |
194 | infixr 5 </> | 194 | infixr 5 </> |
195 | 195 | ||
196 | canProvision :: FilePath -> String -> IO Bool | 196 | canProvision :: WritableDir -> DomainName -> IO Bool |
197 | canProvision challengeDir domain = do | 197 | canProvision challengeDir domain = do |
198 | randomish <- fromString . show <$> getPOSIXTime | 198 | randomish <- fromString . show <$> getPOSIXTime |
199 | 199 | ||
200 | let absFile = challengeDir </> relFile | 200 | let absFile = coerce challengeDir </> relFile |
201 | relFile = ".test." ++ show randomish | 201 | relFile = ".test." ++ show randomish |
202 | 202 | ||
203 | LC.writeFile absFile randomish | 203 | LC.writeFile absFile randomish |
204 | r <- W.get $ "http://" ++ domain </> ".well-known/acme-challenge" </> relFile | 204 | r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile |
205 | removeFile absFile | 205 | removeFile absFile |
206 | return $ r ^. responseBody == randomish | 206 | return $ r ^. responseBody == randomish |
207 | 207 | ||
208 | 208 | ||
209 | ensureWritable :: FilePath -> String -> IO () | 209 | newtype WritableDir = WritableDir String |
210 | ensureWritable file name = (writable <$> getPermissions file) >>= flip unless (err name) | 210 | ensureWritableDir :: FilePath -> String -> IO WritableDir |
211 | ensureWritableDir file name = do | ||
212 | (writable <$> getPermissions file) >>= flip unless (err name) | ||
213 | return $ WritableDir file | ||
211 | where err n = error $ "Error: " ++ n ++ " is not writable" | 214 | where err n = error $ "Error: " ++ n ++ " is not writable" |
212 | 215 | ||
213 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest | 216 | extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest |
@@ -277,8 +280,8 @@ getDirectory sess url = do | |||
277 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) | 280 | register :: URI -> EmailAddress -> ACME (Response LC.ByteString) |
278 | register terms email = sendPayload _newReg (registration email (show terms)) | 281 | register terms email = sendPayload _newReg (registration email (show terms)) |
279 | 282 | ||
280 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString) | 283 | challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) |
281 | challengeRequest domain = sendPayload _newAuthz (authz domain) | 284 | challengeRequest = sendPayload _newAuthz . authz . show |
282 | 285 | ||
283 | statusLine :: Response body -> String | 286 | statusLine :: Response body -> String |
284 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) | 287 | statusLine r = (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8) |