Change API of "certify"

It now expects a callback to provision the challenge responses.

This needs to be improved so that it will also do cleanup.

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
 
 import           BasePrelude
 import qualified Data.ByteString.Lazy.Char8 as LC
-import           Network.ACME               (CSR (..), canProvision, certify,
-                                             ensureWritableDir, (</>), domainToString)
+import           Network.ACME               (CSR (..), canProvision, certify, fileProvisioner, ensureWritableDir, (</>), domainToString)
 import           Network.ACME.Encoding      (Keys (..), readKeys, toStrict)
 import           Network.URI
 import           OpenSSL
@@ -106,7 +105,7 @@ genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do
   setPublicKey req pub
   void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))]
   signX509Req req priv (Just dig)
-  CSR . toStrict <$> writeX509ReqDER req
+  CSR domains . toStrict <$> writeX509ReqDER req
   where
     nidSubjectAltName = 85
 
@@ -133,14 +132,16 @@ go CmdOpts { .. } = do
   challengeDir <- ensureWritableDir optChallengeDir "challenge directory"
   void $ ensureWritableDir domainDir "domain directory"
 
-  forM_ requestDomains $ canProvision challengeDir >=>
-            (`unless` error "Error: cannot provision files to web server via challenge directory")
+  let skipProvisionCheck = True
+  unless skipProvisionCheck $
+    forM_ requestDomains $ canProvision challengeDir >=>
+      (`unless` error "Error: cannot provision files to web server via challenge directory")
 
-  csrData <- genReq domainKeys requestDomains
+  certReq <- genReq domainKeys requestDomains
 
   let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail
 
-  certificate <- certify directoryUrl keys email terms requestDomains challengeDir csrData
+  certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq
 
   either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate
 
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
 import           Text.Domain.Validate hiding (validate)
 import           Network.URI
 
-certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> IO (Either String LC.ByteString)
-certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData =
+type HttpProvisioner = URI -> ByteString -> IO ()
+
+fileProvisioner :: WritableDir -> HttpProvisioner
+fileProvisioner challengeDir = BC.writeFile . uToF
+  where
+    uToF = (coerce challengeDir </>) . takeWhileEnd (/= '/') . uriPath
+    takeWhileEnd f = reverse . takeWhile f . reverse
+
+acmeChallengeURI :: DomainName -> BC.ByteString -> URI
+acmeChallengeURI dom tok = URI
+                             "http:"
+                             (Just $ URIAuth "" (domainToString dom) "")
+                             ("/.well-known/acme-challenge" </> BC.unpack tok)
+                             ""
+                             ""
+
+certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String LC.ByteString)
+certify directoryUrl keys reg provision certReq =
 
   runACME directoryUrl keys $ do
-    forM_ optEmail $ register terms >=> statusReport
+    forM_ reg $ uncurry register >=> statusReport
 
-    let performChallenge (ChallengeRequest nextUri token thumbtoken) = do
-          liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken
+    let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do
+          liftIO $ provision (acmeChallengeURI domain token) thumbtoken
           notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
 
-    challengeResultLinks <- forM requestDomains $ challengeRequest >=> statusReport >=> extractCR >=> performChallenge
+    challengeResultLinks <- forM (csrDomains certReq) $ \dom ->
+      challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom
 
     pollResults challengeResultLinks >>=
       either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++))
-             (const (retrieveCert csrData >>= statusReport <&> checkCertResponse))
+             (const (retrieveCert certReq >>= statusReport <&> checkCertResponse))
 
 pollResults :: [Response LC.ByteString] -> ACME (Either String ())
 pollResults [] = return $ Right ()
@@ -68,7 +85,7 @@ pollResults (link:links) = do
 
 data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString }
 
-newtype CSR = CSR ByteString
+data CSR = CSR { csrDomains :: [DomainName], csrData :: ByteString }
 
 newtype WritableDir = WritableDir String
 ensureWritableDir :: FilePath -> String -> IO WritableDir
@@ -137,7 +154,7 @@ checkCertResponse r =
     isSuccess n = n >= 200 && n <= 300
 
 retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString)
-retrieveCert input = sendPayload _newCert (csr $ coerce input)
+retrieveCert input = sendPayload _newCert (csr $ csrData input)
 
 notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString)
 notifyChallenge uri thumbtoken = sendPayload (const uri) (challenge thumbtoken)