From 5921fc9e6876536178f903cd5c18be0308af89cf Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sun, 24 Jan 2016 12:50:34 -0500 Subject: validate domain names --- acme.hs | 43 +++++++++++++++++++++++-------------------- stack.yaml | 4 ++++ 2 files changed, 27 insertions(+), 20 deletions(-) diff --git a/acme.hs b/acme.hs index be5a319..3ebc911 100644 --- a/acme.hs +++ b/acme.hs @@ -44,8 +44,9 @@ import Options.Applicative hiding (header) import qualified Options.Applicative as Opt import Pipes import System.Directory -import Text.Email.Validate -import Network.URI +import Text.Email.Validate +import Text.Domain.Validate hiding (validate) +import Network.URI stagingDirectoryUrl, liveDirectoryUrl :: URI Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" @@ -114,16 +115,16 @@ genKey privKeyFile = withOpenSSL $ do pem <- writePKCS8PrivateKey kp Nothing writeFile privKeyFile pem -genReq :: FilePath -> [String] -> IO LC.ByteString +genReq :: FilePath -> [DomainName] -> IO LC.ByteString genReq _ [] = error "genReq called with zero domains" genReq domainKeyFile domains@(domain:_) = withOpenSSL $ do Just (Keys priv pub) <- readKeyFile domainKeyFile Just dig <- getDigestByName "SHA256" req <- newX509Req - setSubjectName req [("CN", domain)] + setSubjectName req [("CN", show domain)] setVersion req 0 setPublicKey req pub - void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map ("DNS:" ++) domains))] + void $ addExtensions req [(nidSubjectAltName, intercalate ", " (map (("DNS:" ++) . show) domains))] signX509Req req priv (Just dig) writeX509ReqDER req where @@ -147,7 +148,7 @@ go CmdOpts { .. } = do domainCertFile = domainDir "cert.der" domainDir = fromMaybe (head optDomains) optDomainDir privKeyFile = optKeyFile - requestDomains = optDomains + requestDomains = fromMaybe (error "invalid domain name") $ sequence $ domainName . fromString <$> optDomains doesFileExist privKeyFile `otherwiseM` genKey privKeyFile @@ -156,20 +157,19 @@ go CmdOpts { .. } = do Just keys <- readKeyFile privKeyFile - ensureWritable optChallengeDir "challenge directory" - ensureWritable domainDir "domain directory" + challengeDir <- ensureWritableDir optChallengeDir "challenge directory" + void $ ensureWritableDir domainDir "domain directory" - forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") + forM_ requestDomains $ canProvision challengeDir >=> (`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 directoryUrl keys email terms requestDomains challengeDir csrData domainCertFile -type DomainName = String -- TODO: use validated type -certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> String -> CSR -> FilePath -> IO () +certify :: URI -> Keys -> Maybe EmailAddress -> URI -> [DomainName] -> WritableDir -> CSR -> FilePath -> IO () certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData domainCertFile = runACME directoryUrl keys $ do @@ -180,7 +180,7 @@ certify directoryUrl keys optEmail terms requestDomains optChallengeDir csrData consumer :: Consumer ChallengeRequest ACME () consumer = forever $ await >>= consume1 consume1 (ChallengeRequest nextUri token thumbtoken) = do - lift $ liftIO $ BC.writeFile (optChallengeDir BC.unpack token) thumbtoken + lift $ liftIO $ BC.writeFile (coerce optChallengeDir BC.unpack token) thumbtoken notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport runEffect $ producer >-> consumer @@ -193,21 +193,24 @@ newtype CSR = CSR ByteString a b = a ++ "/" ++ b infixr 5 -canProvision :: FilePath -> String -> IO Bool +canProvision :: WritableDir -> DomainName -> IO Bool canProvision challengeDir domain = do randomish <- fromString . show <$> getPOSIXTime - let absFile = challengeDir relFile + let absFile = coerce challengeDir relFile relFile = ".test." ++ show randomish LC.writeFile absFile randomish - r <- W.get $ "http://" ++ domain ".well-known/acme-challenge" relFile + r <- W.get $ "http://" ++ show 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) +newtype WritableDir = WritableDir String +ensureWritableDir :: FilePath -> String -> IO WritableDir +ensureWritableDir file name = do + (writable <$> getPermissions file) >>= flip unless (err name) + return $ WritableDir file where err n = error $ "Error: " ++ n ++ " is not writable" extractCR :: MonadReader Env m => Response LC.ByteString -> m ChallengeRequest @@ -277,8 +280,8 @@ getDirectory sess url = do 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) +challengeRequest :: (MonadIO m, MonadState Nonce m, MonadReader Env m) => DomainName -> m (Response LC.ByteString) +challengeRequest = sendPayload _newAuthz . authz . show 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 df9bc13..12e38e9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,6 +10,10 @@ packages: git: git@github.com:afcady/HSOpenSSL.git commit: 11f5c83fbe44d6c1c496be4cc3017fd925ba26e2 extra-dep: true +- location: + git: git@github.com:afcady/email-validate-hs.git + commit: faf9c1bbb2051de314bce4c159d4dbdbc768b629 + extra-dep: true # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: [] -- cgit v1.2.3