From 331965d2807bd888e7d5dfe3ee3e31f7161b6e30 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 23 Jan 2016 23:31:36 -0500 Subject: add support for multi-domain (subjectAltName) certificates --- README.md | 18 +++++---- acme-encrypt.cabal | 4 +- acme.hs | 106 +++++++++++++++++++++++++++-------------------------- 3 files changed, 66 insertions(+), 62 deletions(-) diff --git a/README.md b/README.md index 99ae8e0..d2a6e03 100644 --- a/README.md +++ b/README.md @@ -3,23 +3,25 @@ ``` Let's Encrypt! ACME client -Usage: acme-encrypt-exe --key FILE --domain DOMAIN --challenge-dir DIR - [--domain-dir DIR] [--email ADDRESS] [--terms URL] - [--staging] - This is a work in progress. +Usage: acme-certify --key FILE --domain DOMAIN --challenge-dir DIR + [--domain-dir DIR] [--email ADDRESS] [--terms URL] + [--staging] + This program will generate a signed TLS certificate using the ACME protocol + and the free Let's Encrypt! CA. Available options: -h,--help Show this help text --key FILE filename of your private RSA key - --domain DOMAIN the domain name to certify + --domain DOMAIN the domain name(s) to certify; specify more than once + for a multi-domain certificate --challenge-dir DIR output directory for ACME challenges --domain-dir DIR directory in which to domain certificates and keys - are stored; the default is to use the domain name as - a directory name + are stored; the default is to use the (first) domain + name as a directory name --email ADDRESS an email address with which to register an account --terms URL the terms param of the registration request --staging use staging servers instead of live servers - (certificates will not be real!) + (generated certificates will not be trusted!) ``` This is a simple Haskell script to obtain a certificate from [Let's diff --git a/acme-encrypt.cabal b/acme-encrypt.cabal index 9d9e980..e859c8e 100644 --- a/acme-encrypt.cabal +++ b/acme-encrypt.cabal @@ -20,14 +20,14 @@ library mtl, time default-language: Haskell2010 -executable letsencrypt +executable acme-certify -- hs-source-dirs: app main-is: acme.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: base, acme-encrypt, cryptonite, aeson, bytestring, base64-bytestring, SHA, text, HsOpenSSL, wreq, lens, lens-aeson, - optparse-applicative, directory, mtl, time + optparse-applicative, directory, mtl, time, pipes default-language: Haskell2010 -- test-suite acme-encrypt-test diff --git a/acme.hs b/acme.hs index 2731b15..795b822 100644 --- a/acme.hs +++ b/acme.hs @@ -11,7 +11,7 @@ module Main where -import Control.Lens hiding ((.=)) +import Control.Lens hiding ((.=), each) import Control.Monad import Control.Monad.RWS.Strict import Crypto.Number.Serialize (i2osp) @@ -50,6 +50,8 @@ import qualified Options.Applicative as Opt import System.Directory import Network.ACME +import Data.List +import Pipes stagingDirectoryUrl, liveDirectoryUrl :: String liveDirectoryUrl = "https://acme-v01.api.letsencrypt.org/directory" @@ -59,11 +61,14 @@ main :: IO () main = execParser opts >>= go where opts = info (helper <*> cmdopts) (fullDesc <> progDesc detailedDescription <> Opt.header "Let's Encrypt! ACME client") - detailedDescription = "This is a work in progress." + detailedDescription = unwords + [ "This program will generate a signed TLS certificate" + , "using the ACME protocol and the free Let's Encrypt! CA." + ] data CmdOpts = CmdOpts { optKeyFile :: String, - optDomain :: String, + optDomains :: [String], optChallengeDir :: String, optDomainDir :: Maybe String, optEmail :: Maybe String, @@ -75,33 +80,39 @@ defaultTerms :: String defaultTerms = "https://letsencrypt.org/documents/LE-SA-v1.0.1-July-27-2015.pdf" cmdopts :: Parser CmdOpts -cmdopts = CmdOpts <$> strOption - (long "key" <> metavar "FILE" <> help "filename of your private RSA key") - <*> strOption - (long "domain" <> metavar "DOMAIN" <> help "the domain name to certify") - <*> strOption - (long "challenge-dir" <> - metavar "DIR" <> - help "output directory for ACME challenges") +cmdopts = CmdOpts <$> strOption (long "key" <> metavar "FILE" <> + help "filename of your private RSA key") + <*> some + (strOption + (long "domain" <> + metavar "DOMAIN" <> + help + (unwords + [ "the domain name(s) to certify;" + , "specify more than once for a multi-domain certificate" + ]))) + <*> strOption (long "challenge-dir" <> metavar "DIR" <> + help "output directory for ACME challenges") <*> optional (strOption (long "domain-dir" <> metavar "DIR" <> help - "directory in which to domain certificates and keys are stored; the default is to use the domain name as a directory name")) - <*> optional - (strOption - (long "email" <> - metavar "ADDRESS" <> - help "an email address with which to register an account")) + (unwords + [ "directory in which to domain certificates and keys are stored;" + , "the default is to use the (first) domain name as a directory name" + ]))) <*> optional - (strOption - (long "terms" <> - metavar "URL" <> - help "the terms param of the registration request")) + (strOption (long "email" <> metavar "ADDRESS" <> + help "an email address with which to register an account")) + <*> optional (strOption (long "terms" <> metavar "URL" <> + help "the terms param of the registration request")) <*> switch (long "staging" <> help - "use staging servers instead of live servers (certificates will not be real!)") + (unwords + [ "use staging servers instead of live servers" + , "(generated certificates will not be trusted!)" + ])) genKey :: String -> IO () genKey privKeyFile = withOpenSSL $ do @@ -109,30 +120,16 @@ genKey privKeyFile = withOpenSSL $ do pem <- writePKCS8PrivateKey kp Nothing writeFile privKeyFile pem -genReq :: FilePath -> String -> IO LC.ByteString -genReq domainKeyFile domain = withOpenSSL $ do +genReq :: FilePath -> [String] -> 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)] setVersion req 0 setPublicKey req pub - when False $ - -- This certificate seems well-formed ('openssl req' can parse it) but Let's Encrypt rejects it. - void $ addExtensions req - [ nidSubjectAltName %%% "DNS:" ++ domain - , nidKeyUsage %%% "critical,digitalSignature,keyEncipherment" - ] - - -- This, on the other hand, is accepted: - void $ addExtensions req [nidSubjectAltName %%% "DNS:" ++ domain] - - -- Trying to name other domains, though, results in this: - -- - -- void $ addExtensions req [nidSubjectAltName %%% "DNS:" ++ domain ++ ", DNS:www." ++ domain] - -- - -- urn:acme:error:unauthorized ---- Error creating new cert :: Authorizations - -- for these names not found or expired: www.fifty.childrenofmay.org + void $ addExtensions req [nidSubjectAltName %%% intercalate ", " (map ("DNS:" ++) domains)] signX509Req req priv (Just dig) writeX509ReqDER req where @@ -151,39 +148,44 @@ a `otherwiseM` b = a >>= flip unless b infixl 0 `otherwiseM` go :: CmdOpts -> IO () -go CmdOpts{..} = do +go CmdOpts { .. } = do let terms = fromMaybe defaultTerms optTerms directoryUrl = if optStaging then stagingDirectoryUrl else liveDirectoryUrl domainKeyFile = domainDir "rsa.key" domainCSRFile = domainDir "csr.der" domainCertFile = domainDir "cert.der" - domainDir = fromMaybe optDomain optDomainDir + domainDir = fromMaybe (head optDomains) optDomainDir privKeyFile = optKeyFile + requestDomains = optDomains doesFileExist privKeyFile `otherwiseM` genKey privKeyFile - doesDirectoryExist optDomain `otherwiseM` createDirectory domainDir + doesDirectoryExist domainDir `otherwiseM` createDirectory domainDir doesFileExist domainKeyFile `otherwiseM` genKey domainKeyFile Just keys <- readKeyFile privKeyFile - doesFileExist domainCSRFile `otherwiseM` genReq domainKeyFile optDomain >>= LC.writeFile domainCSRFile + doesFileExist domainCSRFile `otherwiseM` genReq domainKeyFile requestDomains >>= LC.writeFile domainCSRFile csrData <- B.readFile domainCSRFile ensureWritable optChallengeDir "challenge directory" ensureWritable domainDir "domain directory" - canProvision optDomain optChallengeDir `otherwiseM` error "Error: cannot provision files to web server via challenge directory" + forM_ requestDomains $ canProvision optChallengeDir >=> (`unless` error "Error: cannot provision files to web server via challenge directory") runACME directoryUrl keys $ do forM_ optEmail $ register terms >=> statusReport - (ChallengeRequest nextUri token thumbtoken) <- challengeRequest optDomain >>= statusReport >>= extractCR - - liftIO $ BC.writeFile (optChallengeDir BC.unpack token) thumbtoken + 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 (optChallengeDir BC.unpack token) thumbtoken + notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport - notifyChallenge nextUri thumbtoken >>= statusReport >>= ncErrorReport + runEffect $ producer >-> consumer retrieveCert csrData >>= statusReport >>= saveCert domainCertFile @@ -191,8 +193,8 @@ go CmdOpts{..} = do a b = a ++ "/" ++ b infixr 5 -canProvision :: String -> FilePath -> IO Bool -canProvision domain challengeDir = do +canProvision :: FilePath -> String -> IO Bool +canProvision challengeDir domain = do randomish <- fromString . show <$> getPOSIXTime let absFile = challengeDir relFile @@ -251,7 +253,7 @@ notifyChallenge crUri thumbtoken = sendPayload (const crUri) (challenge thumbtok data Env = Env { getDir :: Directory, getKeys :: Keys, getSession :: WS.Session } -type ACME a = RWST Env () Nonce IO a +type ACME = RWST Env () Nonce IO runACME :: String -> Keys -> ACME a -> IO a runACME url keys f = WS.withSession $ \sess -> do Just (dir, nonce) <- getDirectory sess url -- cgit v1.2.3