diff options
author | Andrew Cady <d@jerkface.net> | 2016-04-11 03:19:11 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2016-04-11 03:19:11 -0400 |
commit | fa94346e4bd195de96404c36043aa72291d36b1e (patch) | |
tree | 2fdd031cd07c4854e068a702c9ed0b0f01f70c75 | |
parent | 5978351c55544b0ab72630ba70fec25825cad7b4 (diff) |
Implement code to read X509 subjectAltName
This isn't actually used yet; it's just printed out.
-rw-r--r-- | acme-certify.cabal | 3 | ||||
-rw-r--r-- | acme-certify.hs | 36 |
2 files changed, 31 insertions, 8 deletions
diff --git a/acme-certify.cabal b/acme-certify.cabal index 9a67cb9..a191c29 100644 --- a/acme-certify.cabal +++ b/acme-certify.cabal | |||
@@ -30,7 +30,8 @@ executable acme | |||
30 | text, HsOpenSSL, optparse-applicative, time, | 30 | text, HsOpenSSL, optparse-applicative, time, |
31 | email-validate, network-uri, directory, yaml-config, | 31 | email-validate, network-uri, directory, yaml-config, |
32 | yaml, unordered-containers, lens, lens-aeson, process, | 32 | yaml, unordered-containers, lens, lens-aeson, process, |
33 | posix-escape, transformers, resourcet, mtl | 33 | posix-escape, transformers, resourcet, mtl, x509, pem, |
34 | asn1-types | ||
34 | default-language: Haskell2010 | 35 | default-language: Haskell2010 |
35 | 36 | ||
36 | -- test-suite acme-certify-test | 37 | -- test-suite acme-certify-test |
diff --git a/acme-certify.hs b/acme-certify.hs index ecddc99..af11042 100644 --- a/acme-certify.hs +++ b/acme-certify.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
1 | {-# LANGUAGE FlexibleContexts #-} | 2 | {-# LANGUAGE FlexibleContexts #-} |
2 | {-# LANGUAGE FlexibleInstances #-} | 3 | {-# LANGUAGE FlexibleInstances #-} |
3 | {-# LANGUAGE MultiWayIf #-} | 4 | {-# LANGUAGE MultiWayIf #-} |
@@ -18,8 +19,6 @@ module Main where | |||
18 | 19 | ||
19 | import BasePrelude | 20 | import BasePrelude |
20 | import Control.Lens hiding (argument, (&)) | 21 | import Control.Lens hiding (argument, (&)) |
21 | import Control.Monad.IO.Class | ||
22 | import Control.Monad.Trans.Except | ||
23 | import Control.Monad.Except | 22 | import Control.Monad.Except |
24 | import Control.Monad.Trans.Resource | 23 | import Control.Monad.Trans.Resource |
25 | import Data.Aeson.Lens | 24 | import Data.Aeson.Lens |
@@ -51,6 +50,11 @@ import System.Process | |||
51 | import Text.Domain.Validate hiding (validate) | 50 | import Text.Domain.Validate hiding (validate) |
52 | import Text.Email.Validate | 51 | import Text.Email.Validate |
53 | 52 | ||
53 | import qualified Data.ASN1.Types (ASN1Object) | ||
54 | import qualified Data.ByteString as B | ||
55 | import Data.PEM (pemContent, pemParseBS) | ||
56 | import qualified Data.X509 as X509 | ||
57 | |||
54 | stagingDirectoryUrl, liveDirectoryUrl, defaultTerms :: URI | 58 | stagingDirectoryUrl, liveDirectoryUrl, defaultTerms :: URI |
55 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" | 59 | Just liveDirectoryUrl = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory" |
56 | Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory" | 60 | Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory" |
@@ -187,9 +191,18 @@ data CertSpec = CertSpec { | |||
187 | csUserKeys :: Keys | 191 | csUserKeys :: Keys |
188 | } deriving Show | 192 | } deriving Show |
189 | 193 | ||
190 | data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert deriving Show | 194 | certAltNames :: X509.SignedExact X509.Certificate -> [String] |
191 | fetchNeeded :: CertSpec -> IO (Either NeedCertReason ()) | 195 | certAltNames sc = toListOf (_Just . _Right . to strip1 . folded) altNames & mapMaybe strip2 |
192 | fetchNeeded (domainCertFile -> certFile) = runExceptT $ do | 196 | where |
197 | altNames :: Maybe (Either String X509.ExtSubjectAltName) | ||
198 | altNames = X509.extensionGetE $ X509.certExtensions $ X509.signedObject $ X509.getSigned sc | ||
199 | strip1 (X509.ExtSubjectAltName x) = x | ||
200 | strip2 (X509.AltNameDNS x) = Just x | ||
201 | strip2 _ = Nothing | ||
202 | |||
203 | data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert | InvalidExistingCert deriving Show | ||
204 | needToFetch :: CertSpec -> IO (Either NeedCertReason ()) | ||
205 | needToFetch cs@CertSpec{..} = runExceptT $ do | ||
193 | exists <- liftIO $ doesFileExist certFile | 206 | exists <- liftIO $ doesFileExist certFile |
194 | unless exists $ throwError NoExistingCert | 207 | unless exists $ throwError NoExistingCert |
195 | 208 | ||
@@ -198,7 +211,9 @@ fetchNeeded (domainCertFile -> certFile) = runExceptT $ do | |||
198 | now <- liftIO getCurrentTime | 211 | now <- liftIO getCurrentTime |
199 | 212 | ||
200 | -- TODO: check X509v3 subjectAltName list within certificate | 213 | -- TODO: check X509v3 subjectAltName list within certificate |
201 | -- Need to patch HsOpenSSL. Or use cryptonite. | 214 | objList <- liftIO $ readSignedObject certFile |
215 | sc <- maybe (throwError InvalidExistingCert) return $ preview (folded . _Right) objList | ||
216 | liftIO $ print $ certAltNames sc | ||
202 | 217 | ||
203 | if | expiration < now -> throwError Expired | 218 | if | expiration < now -> throwError Expired |
204 | | expiration < addUTCTime graceTime now -> throwError NearExpiration | 219 | | expiration < addUTCTime graceTime now -> throwError NearExpiration |
@@ -206,6 +221,13 @@ fetchNeeded (domainCertFile -> certFile) = runExceptT $ do | |||
206 | where | 221 | where |
207 | graceTime = days 20 | 222 | graceTime = days 20 |
208 | days = (*) (24 * 60 * 60) | 223 | days = (*) (24 * 60 * 60) |
224 | certFile = domainCertFile cs | ||
225 | |||
226 | readSignedObject :: (Eq a, Show a, Data.ASN1.Types.ASN1Object a) => FilePath -> IO [Either String (X509.SignedExact a)] | ||
227 | readSignedObject = | ||
228 | B.readFile >=> return . | ||
229 | either error (map (X509.decodeSignedObject . pemContent)) . pemParseBS | ||
230 | |||
209 | 231 | ||
210 | runUpdate :: UpdateOpts -> IO () | 232 | runUpdate :: UpdateOpts -> IO () |
211 | runUpdate UpdateOpts { .. } = do | 233 | runUpdate UpdateOpts { .. } = do |
@@ -247,7 +269,7 @@ runUpdate UpdateOpts { .. } = do | |||
247 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl | 269 | directoryUrl = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl |
248 | email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec) | 270 | email = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec) |
249 | 271 | ||
250 | (fetchNeeded spec >>=) $ leftMapM_ $ \reason -> do | 272 | (needToFetch spec >>=) $ leftMapM_ $ \reason -> do |
251 | putStrLn $ concat ["New certificate needed (for domain ", domainToString domain, "): ", show reason] | 273 | putStrLn $ concat ["New certificate needed (for domain ", domainToString domain, "): ", show reason] |
252 | if updateDryRun | 274 | if updateDryRun |
253 | then putStrLn "Dry run: nothing fetched, nothing saved." | 275 | then putStrLn "Dry run: nothing fetched, nothing saved." |