From c8f622463afa168dba3183bd0a025ef17965cffb Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Thu, 21 Jan 2016 17:00:00 -0500
Subject: Fail earlier

Checks that the output dirs are writable and that writing to the
challenge dir results in a file hosted at the proper URL.

I once had a linksys router that would forward incoming TCP connections
to a machine on my LAN, but would not route connections from that
machine to itself over the public IP. This check would break on such
a configuration; I suppose it might be made optional.
---
 acme-encrypt.cabal |  2 +-
 acme.hs            | 50 ++++++++++++++++++++++++++++++++++++--------------
 2 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/acme-encrypt.cabal b/acme-encrypt.cabal
index 66b80ec..229fe77 100644
--- a/acme-encrypt.cabal
+++ b/acme-encrypt.cabal
@@ -24,7 +24,7 @@ executable acme-encrypt-exe
   build-depends:       base,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
                        text, HsOpenSSL, process, wreq, lens, lens-aeson,
-                       optparse-applicative, directory, mtl, process-extras
+                       optparse-applicative, directory, mtl, process-extras, time
                      -- , acme-encrypt
   default-language:    Haskell2010
 
diff --git a/acme.hs b/acme.hs
index 3579fe6..199a441 100644
--- a/acme.hs
+++ b/acme.hs
@@ -28,12 +28,15 @@ import qualified Data.ByteString.Lazy.Char8 as LC
 import           Data.Coerce
 import           Data.Digest.Pure.SHA       (bytestringDigest, sha256)
 import           Data.Maybe
+import           Data.String                (fromString)
 import qualified Data.Text                  as T
 import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
+import           Data.Time.Clock.POSIX      (getPOSIXTime)
 import           Network.Wreq               (Response, checkStatus, defaults,
                                              responseBody, responseHeader,
                                              responseStatus, statusCode,
                                              statusMessage)
+import qualified Network.Wreq               as W
 import qualified Network.Wreq.Session       as WS
 import           OpenSSL
 import           OpenSSL.EVP.Digest
@@ -129,42 +132,61 @@ readKeys privKeyFile = do
 data ChallengeRequest = ChallengeRequest { crUri :: String, crToken :: ByteString, crThumbToken :: ByteString }
 
 go :: CmdOpts -> IO ()
-go (CmdOpts privKeyFile domain challengeDir altDomainDir email termOverride staging) = do
-  let terms           = fromMaybe defaultTerms termOverride
-      directoryUrl    = if staging then stagingDirectoryUrl else liveDirectoryUrl
+go CmdOpts{..} = do
+  let terms           = fromMaybe defaultTerms optTerms
+      directoryUrl    = if optStaging then stagingDirectoryUrl else liveDirectoryUrl
       domainKeyFile   = domainDir </> "rsa.key"
       domainCSRFile   = domainDir </> "csr.der"
       domainCertFile  = domainDir </> "cert.der"
-      domainDir       = fromMaybe domain altDomainDir
+      domainDir       = fromMaybe optDomain optDomainDir
+      privKeyFile     = optKeyFile
 
   doesFileExist privKeyFile >>= flip unless (genKey privKeyFile)
 
-  doesDirectoryExist domain >>= flip unless (createDirectory domainDir)
+  doesDirectoryExist optDomain >>= flip unless (createDirectory domainDir)
   doesFileExist domainKeyFile >>= flip unless (genKey domainKeyFile)
 
   keys <- readKeys privKeyFile
 
-  doesFileExist domainCSRFile >>= flip unless (genReq domainKeyFile domain >>= B.writeFile domainCSRFile)
+  doesFileExist domainCSRFile >>= flip unless (genReq domainKeyFile optDomain >>= B.writeFile domainCSRFile)
 
   csrData <- B.readFile domainCSRFile
 
-  -- TODO: verify that challengeDir is writable before continuing.
+  ensureWritable optChallengeDir "challenge directory"
+  ensureWritable domainDir "domain directory"
 
-  runACME directoryUrl keys $ do
-    forM_ email $ register terms >=> statusReport
+  canProvision optDomain optChallengeDir >>= flip unless (error "Error: cannot provision files to web server via challenge directory")
 
-    (ChallengeRequest nextUri token thumbtoken) <- challengeRequest domain >>= statusReport >>= extractCR
+  runACME directoryUrl keys $ do
+    forM_ optEmail $ register terms >=> statusReport
 
-    liftIO $ BC.writeFile (challengeDir </> BC.unpack token) thumbtoken
+    (ChallengeRequest nextUri token thumbtoken) <- challengeRequest optDomain >>= statusReport >>= extractCR
 
-    -- TODO: first hit the local server to test whether this is valid
+    liftIO $ BC.writeFile (optChallengeDir </> BC.unpack token) thumbtoken
 
     notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
 
     retrieveCert csrData >>= statusReport >>= saveCert domainCertFile
 
-  where
-    a </> b = a ++ "/" ++ b
+(</>) :: String -> String -> String
+a </> b = a ++ "/" ++ b
+
+canProvision :: String -> FilePath -> IO Bool
+canProvision domain challengeDir = do
+  randomish <- fromString . show <$> getPOSIXTime
+
+  let absFile = challengeDir </> relFile
+      relFile = ".test." ++ show randomish
+
+  LC.writeFile absFile randomish
+  r <- W.get $ "http://" ++ domain </> ".well-known/acme-challenge" </> relFile
+  removeFile absFile
+  return $ r ^. responseBody == randomish
+
+
+ensureWritable :: FilePath -> String -> IO ()
+ensureWritable file name = (writable <$> getPermissions file) >>= flip unless (err name)
+  where err n = error $ "Error: " ++ n ++ " is not writable"
 
 extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest
 extractCR r = do
-- 
cgit v1.2.3