From fdf06576f7d21392f512492b164df899136f30d3 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Sun, 24 Jan 2016 01:53:55 -0500
Subject: Validate email address

---
 acme-certify.cabal  |  7 ++++---
 acme.hs             | 23 ++++++++++++++++-------
 src/Network/ACME.hs | 14 ++++++++------
 3 files changed, 28 insertions(+), 16 deletions(-)

diff --git a/acme-certify.cabal b/acme-certify.cabal
index 30fff26..3e90f42 100644
--- a/acme-certify.cabal
+++ b/acme-certify.cabal
@@ -16,8 +16,8 @@ library
   exposed-modules:     Network.ACME
   build-depends:       base >= 4.7 && < 5,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
-                       text, HsOpenSSL, wreq, lens, lens-aeson,
-                       mtl, time
+                       text, HsOpenSSL, wreq, lens, lens-aeson, mtl, time,
+                       email-validate
   default-language:    Haskell2010
 
 executable acme-certify
@@ -27,7 +27,8 @@ executable acme-certify
   build-depends:       base, acme-certify,
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
                        text, HsOpenSSL, wreq, lens, lens-aeson,
-                       optparse-applicative, directory, mtl, time, pipes
+                       optparse-applicative, directory, mtl, time, pipes,
+                       email-validate
   default-language:    Haskell2010
 
 -- test-suite acme-certify-test
diff --git a/acme.hs b/acme.hs
index d187f86..8b1a77e 100644
--- a/acme.hs
+++ b/acme.hs
@@ -44,6 +44,7 @@ import           Options.Applicative        hiding (header)
 import qualified Options.Applicative        as Opt
 import           Pipes
 import           System.Directory
+import Text.Email.Validate
 
 stagingDirectoryUrl, liveDirectoryUrl :: String
 liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory"
@@ -154,15 +155,21 @@ go CmdOpts { .. } = do
 
   Just keys <- readKeyFile privKeyFile
 
-  doesFileExist domainCSRFile `otherwiseM` genReq domainKeyFile requestDomains >>= LC.writeFile domainCSRFile
-
-  csrData <- B.readFile domainCSRFile
-
   ensureWritable optChallengeDir "challenge directory"
   ensureWritable domainDir "domain directory"
 
   forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory")
 
+  csrData <- CSR . toStrict <$> genReq domainKeyFile requestDomains
+  B.writeFile domainCSRFile (coerce csrData)
+
+  let email = either (error . ("Error: invalid email address: " ++)) id . validate . fromString <$> optEmail
+
+  certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile
+
+certify :: String -> Keys -> Maybe EmailAddress -> String -> [String] -> String -> CSR -> FilePath -> IO ()
+certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile =
+
   runACME directoryUrl keys $ do
     forM_ optEmail $ register terms >=> statusReport
 
@@ -178,6 +185,8 @@ go CmdOpts { .. } = do
 
     retrieveCert csrData >>= statusReport >>= saveCert domainCertFile
 
+newtype CSR = CSR ByteString
+
 (</>) :: String -> String -> String
 a </> b = a ++ "/" ++ b
 infixr 5 </>
@@ -234,8 +243,8 @@ saveCert domainCertFile r =
   where
     isSuccess n = n >= 200 && n <= 300
 
-retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => ByteString -> m (Response LC.ByteString)
-retrieveCert input = sendPayload _newCert (csr input)
+retrieveCert :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => CSR -> m (Response LC.ByteString)
+retrieveCert input = sendPayload _newCert (csr $ coerce input)
 
 notifyChallenge :: (MonadReader Env m, MonadState Nonce m, MonadIO m) => String -> ByteString -> m (Response LC.ByteString)
 notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtoken)
@@ -263,7 +272,7 @@ getDirectory sess url = do
       k x   = r ^? responseBody . JSON.key x . _String . to T.unpack
   return $ (,) <$> (Directory <$> k "new-cert" <*> k "new-authz" <*> k "revoke-cert" <*> k "new-reg") <*> nonce
 
-register :: String -> String -> ACME (Response LC.ByteString)
+register :: String -> EmailAddress -> ACME (Response LC.ByteString)
 register terms email = sendPayload _newReg (registration email terms)
 
 challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => String -> m (Response LC.ByteString)
diff --git a/src/Network/ACME.hs b/src/Network/ACME.hs
index ccd0a8c..d6a0f47 100644
--- a/src/Network/ACME.hs
+++ b/src/Network/ACME.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Network.ACME (
     Keys(..),
@@ -32,6 +32,8 @@ import           OpenSSL.EVP.PKey
 import           OpenSSL.EVP.Sign
 import           OpenSSL.PEM
 import           OpenSSL.RSA
+import           Text.Email.Validate
+import qualified Data.Text                  as T
 
 data Keys = Keys RSAKeyPair RSAPubKey
 readKeys :: String -> IO (Maybe Keys)
@@ -69,7 +71,7 @@ header key nonce = (toStrict . encode)
                      (Header "RS256" (JWK (rsaE key) "RSA" (rsaN key)) (Just nonce))
 
 -- | Registration payload to sign with user key.
-registration :: String -> String -> ByteString
+registration :: EmailAddress -> String -> ByteString
 registration emailAddr terms = (b64 . toStrict . encode) (Reg emailAddr terms)
 
 -- | Challenge request payload to sign with user key.
@@ -125,7 +127,7 @@ instance ToJSON JWK where
     ]
 
 data Reg = Reg
-  { rMail      :: String
+  { rMail      :: EmailAddress
   , rAgreement :: String
   }
   deriving Show
@@ -133,7 +135,7 @@ data Reg = Reg
 instance ToJSON Reg where
   toJSON Reg{..} = object
     [ "resource" .= ("new-reg" :: String)
-    , "contact" .= ["mailto:" ++ rMail]
+    , "contact" .= ["mailto:" ++ (T.unpack . decodeUtf8 . toByteString $ rMail)]
     , "agreement" .= rAgreement
     ]
 
-- 
cgit v1.2.3