From 0a77e9cb30c12a516993013b7ab5f4272bea94f9 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Sun, 24 Jan 2016 02:18:47 -0500
Subject: validate URIs

---
 acme-certify.cabal |  2 +-
 acme.hs            | 24 +++++++++++++-----------
 2 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/acme-certify.cabal b/acme-certify.cabal
index 3e90f42..6e28735 100644
--- a/acme-certify.cabal
+++ b/acme-certify.cabal
@@ -28,7 +28,7 @@ executable acme-certify
                        cryptonite, aeson, bytestring, base64-bytestring, SHA,
                        text, HsOpenSSL, wreq, lens, lens-aeson,
                        optparse-applicative, directory, mtl, time, pipes,
-                       email-validate
+                       email-validate, network-uri
   default-language:    Haskell2010
 
 -- test-suite acme-certify-test
diff --git a/acme.hs b/acme.hs
index 8b1a77e..be5a319 100644
--- a/acme.hs
+++ b/acme.hs
@@ -45,10 +45,11 @@ import qualified Options.Applicative        as Opt
 import           Pipes
 import           System.Directory
 import Text.Email.Validate
+import Network.URI
 
-stagingDirectoryUrl, liveDirectoryUrl :: String
-liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory"
-stagingDirectoryUrl = "https://acme-staging.api.letsencrypt.org/directory"
+stagingDirectoryUrl, liveDirectoryUrl :: URI
+Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory"
+Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory"
 
 main :: IO ()
 main = execParser opts >>= go
@@ -69,8 +70,8 @@ data CmdOpts = CmdOpts {
       optStaging      :: Bool
 }
 
-defaultTerms :: String
-defaultTerms = "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf"
+defaultTerms :: URI
+Just defaultTerms = parseAbsoluteURI "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf"
 
 cmdopts :: Parser CmdOpts
 cmdopts = CmdOpts <$> strOption (long "key" <> metavar "FILE" <>
@@ -139,7 +140,7 @@ infixl 0 `otherwiseM`
 
 go :: CmdOpts -> IO ()
 go CmdOpts { .. } = do
-  let terms           = fromMaybe defaultTerms optTerms
+  let terms           = fromMaybe defaultTerms (join $ parseAbsoluteURI <$> optTerms)
       directoryUrl    = if optStaging then stagingDirectoryUrl else liveDirectoryUrl
       domainKeyFile   = domainDir </> "rsa.key"
       domainCSRFile   = domainDir </> "csr.der"
@@ -167,7 +168,8 @@ go CmdOpts { .. } = do
 
   certify directoryUrl keys email terms requestDomains optChallengeDir csrData domainCertFile
 
-certify :: String -> Keys -> Maybe EmailAddress -> String -> [String] -> String -> CSR -> FilePath -> IO ()
+type DomainName = String -- TODO: use validated type
+certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> String -> CSR -> FilePath -> IO ()
 certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile =
 
   runACME directoryUrl keys $ do
@@ -252,9 +254,9 @@ notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtok
 data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session }
 
 type ACME = RWST Env () Nonce IO
-runACME :: String -> Keys -> ACME a -> IO a
+runACME :: URI -> Keys -> ACME a -> IO a
 runACME url keys f = WS.withSession $ \sess -> do
-  Just (dir, nonce) <- getDirectory sess url
+  Just (dir, nonce) <- getDirectory sess (show url)
   fst <$> evalRWST f (Env dir keys sess) nonce
 
 data Directory = Directory {
@@ -272,8 +274,8 @@ 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 -> EmailAddress -> ACME (Response LC.ByteString)
-register terms email = sendPayload _newReg (registration email terms)
+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) => String -> m (Response LC.ByteString)
 challengeRequest domain = sendPayload _newAuthz (authz domain)
-- 
cgit v1.2.3