From d54ff778995b369ead6b708d9b6ee8bff31d366d Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Mon, 25 Jan 2016 22:40:54 -0500
Subject: generate DH params; use PEM for final output

this needs to be made optional and the DH params should be cached,
because generating them is very slow.
---
 acme-certify.hs     | 24 +++++++++++++++++++++++-
 src/Network/ACME.hs | 29 ++++++++++++++++-------------
 stack.yaml          |  2 +-
 3 files changed, 40 insertions(+), 15 deletions(-)

diff --git a/acme-certify.hs b/acme-certify.hs
index 360579b..b84a728 100644
--- a/acme-certify.hs
+++ b/acme-certify.hs
@@ -17,6 +17,8 @@ import           Network.ACME               (canProvision, certify, fileProvisio
 import           Network.ACME.Encoding      (Keys (..), readKeys)
 import           Network.URI
 import           OpenSSL
+import           OpenSSL.X509 (X509)
+import           OpenSSL.DH
 import           OpenSSL.PEM
 import           OpenSSL.RSA
 import           Options.Applicative        hiding (header)
@@ -24,6 +26,7 @@ import qualified Options.Applicative        as Opt
 import           System.Directory
 import           Text.Domain.Validate       hiding (validate)
 import           Text.Email.Validate
+import System.IO
 
 stagingDirectoryUrl, liveDirectoryUrl :: URI
 Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory"
@@ -125,10 +128,29 @@ go CmdOpts { .. } = do
 
   let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail
 
+  let issuerCertFile = "lets-encrypt-x1-cross-signed.pem"
+  issuerCert <- readFile issuerCertFile >>= readX509
+
+  hSetBuffering stdout NoBuffering
+  putStr "Generating DH Params..."
+  dh <- genDHParams DHGen2 2048
+  putStrLn "  Done."
+
   certificate <- certify directoryUrl keys ((,) terms <$> email) (fileProvisioner challengeDir) certReq
 
-  either (error . ("Error: " ++)) (LC.writeFile domainCertFile) certificate
+  either (error . ("Error: " ++))
+         (combinedCert issuerCert (Just dh) domainKeys >=> writeFile domainCertFile)
+         certificate
+
+combinedCert :: X509 -> Maybe DHP -> Keys -> X509 -> IO String
+combinedCert issuerCert dh (Keys privKey _) cert = do
+  dhStr <- mapM writeDHParams dh
+  certStr <- writeX509 cert
+  privKeyStr <- writePKCS8PrivateKey privKey Nothing
+  issuerCertStr <- writeX509 issuerCert
+  return $ concat [certStr, issuerCertStr, privKeyStr, fromMaybe "" dhStr]
 
 otherwiseM :: Monad m => m Bool -> m () -> m ()
 a `otherwiseM` b = a >>= flip unless b
 infixl 0 `otherwiseM`
+
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
index f6bffe2..b05b823 100644
--- a/src/Network/ACME.hs
+++ b/src/Network/ACME.hs
@@ -39,6 +39,7 @@ import           OpenSSL
 import           OpenSSL.EVP.Digest
 import           OpenSSL.RSA
 import           OpenSSL.X509.Request
+import           OpenSSL.X509 (readDerX509, X509)
 import Data.List
 
 type HttpProvisioner = URI -> ByteString -> IO ()
@@ -71,29 +72,31 @@ acmeChallengeURI dom tok = URI
                              ""
                              ""
 
-certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String LC.ByteString)
-certify directoryUrl keys reg provision certReq =
+certify :: URI -> Keys -> Maybe (URI, EmailAddress) -> HttpProvisioner -> CSR -> IO (Either String X509)
+certify directoryUrl keys reg provision certReq = run >>= traverse readDerX509
 
-  runACME directoryUrl keys $ do
-    forM_ reg $ uncurry register >=> statusReport
+  where
+    run =
+      runACME directoryUrl keys $ do
+        forM_ reg $ uncurry register >=> statusReport
 
-    let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do
-          liftIO $ provision (acmeChallengeURI domain token) thumbtoken
-          notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
+        let performChallenge domain (ChallengeRequest nextUri token thumbtoken) = do
+              liftIO $ provision (acmeChallengeURI domain token) thumbtoken
+              notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
 
-    challengeResultLinks <- forM (csrDomains certReq) $ \dom ->
-      challengeRequest dom >>= statusReport >>= extractCR >>= performChallenge dom
+        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 certReq >>= statusReport <&> checkCertResponse))
+        pollResults challengeResultLinks >>=
+          either (return . Left . ("certificate receipt was not attempted because a challenge failed: " ++))
+                 (const (retrieveCert certReq >>= statusReport <&> checkCertResponse))
 
 pollResults :: [Response LC.ByteString] -> ACME (Either String ())
 pollResults [] = return $ Right ()
 pollResults (link:links) = do
   -- TODO: use "Retry-After" header if present
   let Just uri = link ^? responseBody . JSON.key "uri" . _String
-  r <- liftIO $ W.get (T.unpack uri)
+  r <- liftIO $ W.get (T.unpack uri) >>= statusReport
   let status = r ^. responseBody . JSON.key "status" . _String
   case status of
     "pending" -> pollResults $ links ++ [r]
diff --git a/stack.yaml b/stack.yaml
index 3766a07..d69a7ef 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -8,7 +8,7 @@ packages:
 - '.'
 - location:
     git: git@github.com:afcady/HSOpenSSL.git
-    commit: 11f5c83fbe44d6c1c496be4cc3017fd925ba26e2
+    commit: 90679fb0e20514f915c90c0e27774867a30915df
   extra-dep: true
 - location:
     git: git@github.com:afcady/email-validate-hs.git
-- 
cgit v1.2.3