From a5da398526bc5c3bb2f4dade1235e458f3dab31c Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Fri, 8 Apr 2016 20:42:17 -0400
Subject: Change type of HttpProvisioner

Now it is parameterized on domain name.  This will allow to provision to
a different directory for each (sub)domain.
---
 acme-certify.hs     |  5 +++--
 src/Network/ACME.hs | 21 ++++++++++-----------
 2 files changed, 13 insertions(+), 13 deletions(-)

diff --git a/acme-certify.hs b/acme-certify.hs
index 2b666af..4fa16a0 100644
--- a/acme-certify.hs
+++ b/acme-certify.hs
@@ -122,14 +122,15 @@ go CmdOpts { .. } = do
   Just keys <- getOrCreateKeys privKeyFile
 
   unless optSkipProvisionCheck $
-    forM_ requestDomains $ canProvision challengeDir >=>
+    forM_ requestDomains $ canProvision (const $ Just challengeDir) >=>
       (`unless` error "Error: cannot provision files to web server via challenge directory")
 
   certReq <- genReq domainKeys requestDomains
 
   dh <- if optSkipDH then return Nothing else Just <$> getOrCreateDH domainDhFile
 
-  certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq
+  let provision = fileProvisioner (const $ Just challengeDir)
+  certificate <- certify directoryUrl keys ((,) terms <$> email) provision certReq
 
   let save = saveCertificate issuerCert dh domainKeys domainCombinedFile domainCertFile
   mapM save certificate
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
index 2c58bac..2312389 100644
--- a/src/Network/ACME.hs
+++ b/src/Network/ACME.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE ViewPatterns          #-}
 
 --------------------------------------------------------------------------------
 -- | Get a certificate from Let's Encrypt using the ACME protocol.
@@ -57,7 +58,7 @@ certify directoryUrl keys reg provision certReq =
     forM_ reg $ uncurry register >=> statusReport
 
     let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do
-          liftResourceT $ provision (acmeChallengeURI domain token) thumbtoken
+          liftResourceT $ provision domain token thumbtoken
           notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
 
         cr dom = challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom
@@ -83,15 +84,15 @@ pollResults (link:links) = do
 
 -- Provisioner callback
 
-type HttpProvisioner = URI -> ByteString -> ResIO ()
-fileProvisioner :: WritableDir -> HttpProvisioner
-fileProvisioner challengeDir uri thumbtoken = do
+type HttpProvisioner = DomainName -> ByteString -> ByteString -> ResIO ()
+fileProvisioner :: (DomainName -> Maybe WritableDir) -> HttpProvisioner
+fileProvisioner challengeDir (challengeDir -> Just dir) tok thumbtoken = do
   void $ allocate (return f) removeFile
   liftIO $ BC.writeFile f thumbtoken
 
   where
-    f = (coerce challengeDir </>) . takeWhileEnd (/= '/') . uriPath $ uri
-    takeWhileEnd s = reverse . takeWhile s . reverse
+    f = (coerce dir </>) (T.unpack $ decodeUtf8 tok)
+fileProvisioner _ dom _ _ = liftIO $ fail $ "fileProvisioner: no writable directory for domain: " ++ show dom
 
 newtype WritableDir = WritableDir String
 ensureWritableDir :: FilePath -> String -> IO WritableDir
@@ -100,15 +101,13 @@ ensureWritableDir file name = do
   return $ WritableDir file
   where e n = error $ "Error: " ++ n ++ " is not writable"
 
-canProvision :: WritableDir -> DomainName -> IO Bool
+canProvision :: (DomainName -> Maybe WritableDir) -> DomainName -> IO Bool
 canProvision challengeDir domain = do
   token <- (".test." ++) . show <$> getPOSIXTime
 
-  let uri = acmeChallengeURI domain (fromString token)
-
   r <- runResourceT $ do
-         fileProvisioner challengeDir uri (fromString token)
-         liftIO $ W.get (show uri)
+         fileProvisioner challengeDir domain (fromString token) (fromString token)
+         liftIO $ W.get $ show $ acmeChallengeURI domain (fromString token)
   return $ r ^. responseBody == fromString token
 
 -- The ACME monad
-- 
cgit v1.2.3