From c4b9b52a2ebbc8d113f4829c86834dcd565cd6a3 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Sun, 24 Jan 2016 16:22:20 -0500
Subject: Oops; don't use "show" with DomainName type

---
 acme-certify.hs     |  6 +++---
 src/Network/ACME.hs | 18 ++++++++----------
 stack.yaml          |  2 +-
 3 files changed, 12 insertions(+), 14 deletions(-)

diff --git a/acme-certify.hs b/acme-certify.hs
index 5a50265..7849b65 100644
--- a/acme-certify.hs
+++ b/acme-certify.hs
@@ -14,7 +14,7 @@ module Main where
 import           BasePrelude
 import qualified Data.ByteString.Lazy.Char8 as LC
 import           Network.ACME               (CSR (..), canProvision, certify,
-                                             ensureWritableDir, (</>))
+                                             ensureWritableDir, (</>), domainToString)
 import           Network.ACME.Encoding      (Keys (..), readKeys, toStrict)
 import           Network.URI
 import           OpenSSL
@@ -101,10 +101,10 @@ genReq _ [] = error "genReq called with zero domains"
 genReq (Keys priv pub) domains@(domain:_) = withOpenSSL $ do
   Just dig <- getDigestByName "SHA256"
   req <- newX509Req
-  setSubjectName req [("CN", show domain)]
+  setSubjectName req [("CN", domainToString domain)]
   setVersion req 0
   setPublicKey req pub
-  void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))]
+  void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . domainToString) domains))]
   signX509Req req priv (Just dig)
   CSR . toStrict <$> writeX509ReqDER req
   where
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
index 116a291..d2216ac 100644
--- a/src/Network/ACME.hs
+++ b/src/Network/ACME.hs
@@ -32,7 +32,6 @@ import           Network.Wreq               (Response, checkStatus, defaults,
 import qualified Network.Wreq               as W
 import qualified Network.Wreq.Session       as WS
 import           OpenSSL.RSA
-import           Pipes
 import           System.Directory
 import           Text.Email.Validate
 import           Text.Domain.Validate hiding (validate)
@@ -44,15 +43,11 @@ certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData
   runACME directoryUrl keys $ do
     forM_ optEmail $ register terms >=> statusReport
 
-    let producer :: Producer ChallengeRequest ACME ()
-        producer = for (each requestDomains) $ challengeRequest >=> statusReport >=> extractCR >=> yield
-        consumer :: Consumer ChallengeRequest ACME ()
-        consumer = forever $ await >>= consume1
-        consume1 (ChallengeRequest nextUri token thumbtoken) = do
-          lift $ liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken
+    let performChallenge (ChallengeRequest nextUri token thumbtoken) = do
+          liftIO $ BC.writeFile (coerce optChallengeDir </> BC.unpack token) thumbtoken
           notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport
 
-    runEffect $ producer >-> consumer
+    forM_ requestDomains $ challengeRequest >=> statusReport >=> extractCR >=> performChallenge
 
     retrieveCert csrData >>= statusReport <&> checkCertResponse
 
@@ -71,6 +66,9 @@ ensureWritableDir file name = do
 a </> b = a ++ "/" ++ b
 infixr 5 </>
 
+domainToString :: DomainName -> String
+domainToString = T.unpack . decodeUtf8 . Text.Domain.Validate.toByteString
+
 canProvision :: WritableDir -> DomainName -> IO Bool
 canProvision challengeDir domain = do
   randomish <- fromString . show <$> getPOSIXTime
@@ -79,7 +77,7 @@ canProvision challengeDir domain = do
       relFile = ".test." ++ show randomish
 
   LC.writeFile absFile randomish
-  r <- W.get $ "http://" ++ show domain </> ".well-known/acme-challenge" </> relFile
+  r <- W.get $ "http://" ++ domainToString domain </> ".well-known/acme-challenge" </> relFile
   removeFile absFile
   return $ r ^. responseBody == randomish
 
@@ -152,7 +150,7 @@ register :: URI -> EmailAddress -> ACME (Response LC.ByteString)
 register terms email = sendPayload _newReg (registration email (show terms))
 
 challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString)
-challengeRequest = sendPayload _newAuthz . authz . show
+challengeRequest = sendPayload _newAuthz . authz . domainToString
 
 statusLine :: Response body -> String
 statusLine r =  (r ^. responseStatus . statusCode . to show) ++ " " ++ r ^. responseStatus . statusMessage . to (T.unpack . decodeUtf8)
diff --git a/stack.yaml b/stack.yaml
index 12e38e9..3766a07 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -12,7 +12,7 @@ packages:
   extra-dep: true
 - location:
     git: git@github.com:afcady/email-validate-hs.git
-    commit: faf9c1bbb2051de314bce4c159d4dbdbc768b629
+    commit: 6b3d6d232fcddb4f398f7118251a951e26f7b81b
   extra-dep: true
 
 # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
-- 
cgit v1.2.3