From fa94346e4bd195de96404c36043aa72291d36b1e Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Mon, 11 Apr 2016 03:19:11 -0400
Subject: Implement code to read X509 subjectAltName

This isn't actually used yet; it's just printed out.
---
 acme-certify.cabal |  3 ++-
 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
                        text, HsOpenSSL, optparse-applicative, time,
                        email-validate, network-uri, directory, yaml-config,
                        yaml, unordered-containers, lens, lens-aeson, process,
-                       posix-escape, transformers, resourcet, mtl
+                       posix-escape, transformers, resourcet, mtl, x509, pem,
+                       asn1-types
   default-language:    Haskell2010
 
 -- 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 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE MultiWayIf           #-}
@@ -18,8 +19,6 @@ module Main where
 
 import           BasePrelude
 import           Control.Lens                 hiding (argument, (&))
-import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Except
 import           Control.Monad.Except
 import           Control.Monad.Trans.Resource
 import           Data.Aeson.Lens
@@ -51,6 +50,11 @@ import           System.Process
 import           Text.Domain.Validate         hiding (validate)
 import           Text.Email.Validate
 
+import qualified Data.ASN1.Types              (ASN1Object)
+import qualified Data.ByteString              as B
+import           Data.PEM                     (pemContent, pemParseBS)
+import qualified Data.X509                    as X509
+
 stagingDirectoryUrl, liveDirectoryUrl, defaultTerms :: URI
 Just liveDirectoryUrl    = parseAbsoluteURI "https://acme-v01.api.letsencrypt.org/directory"
 Just stagingDirectoryUrl = parseAbsoluteURI "https://acme-staging.api.letsencrypt.org/directory"
@@ -187,9 +191,18 @@ data CertSpec = CertSpec {
       csUserKeys       :: Keys
 } deriving Show
 
-data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert deriving Show
-fetchNeeded :: CertSpec -> IO (Either NeedCertReason ())
-fetchNeeded (domainCertFile -> certFile) = runExceptT $ do
+certAltNames :: X509.SignedExact X509.Certificate -> [String]
+certAltNames sc = toListOf (_Just . _Right . to strip1 . folded) altNames & mapMaybe strip2
+  where
+    altNames :: Maybe (Either String X509.ExtSubjectAltName)
+    altNames = X509.extensionGetE $ X509.certExtensions $ X509.signedObject $ X509.getSigned sc
+    strip1 (X509.ExtSubjectAltName x) = x
+    strip2 (X509.AltNameDNS x) = Just x
+    strip2 _ = Nothing
+
+data NeedCertReason = Expired | NearExpiration | SubDomainsAdded | NoExistingCert | InvalidExistingCert deriving Show
+needToFetch :: CertSpec -> IO (Either NeedCertReason ())
+needToFetch cs@CertSpec{..} = runExceptT $ do
   exists <- liftIO $ doesFileExist certFile
   unless exists $ throwError NoExistingCert
 
@@ -198,7 +211,9 @@ fetchNeeded (domainCertFile -> certFile) = runExceptT $ do
   now <- liftIO getCurrentTime
 
   -- TODO: check X509v3 subjectAltName list within certificate
-  -- Need to patch HsOpenSSL.  Or use cryptonite.
+  objList <- liftIO $ readSignedObject certFile
+  sc <- maybe (throwError InvalidExistingCert) return $ preview (folded . _Right) objList
+  liftIO $ print $ certAltNames sc
 
   if | expiration < now                      -> throwError Expired
      | expiration < addUTCTime graceTime now -> throwError NearExpiration
@@ -206,6 +221,13 @@ fetchNeeded (domainCertFile -> certFile) = runExceptT $ do
   where
     graceTime = days 20
     days = (*) (24 * 60 * 60)
+    certFile = domainCertFile cs
+
+readSignedObject :: (Eq a, Show a, Data.ASN1.Types.ASN1Object a) => FilePath -> IO [Either String (X509.SignedExact a)]
+readSignedObject =
+  B.readFile >=> return .
+                 either error (map (X509.decodeSignedObject . pemContent)) . pemParseBS
+
 
 runUpdate :: UpdateOpts -> IO ()
 runUpdate UpdateOpts { .. } = do
@@ -247,7 +269,7 @@ runUpdate UpdateOpts { .. } = do
         directoryUrl       = if updateStaging then stagingDirectoryUrl else liveDirectoryUrl
         email              = emailAddress $ encodeUtf8 . pack $ "root@" ++ (domainToString . fst . head) (csDomains spec)
 
-    (fetchNeeded spec >>=) $ leftMapM_ $ \reason -> do
+    (needToFetch spec >>=) $ leftMapM_ $ \reason -> do
       putStrLn $ concat ["New certificate needed (for domain ", domainToString domain, "): ", show reason]
       if updateDryRun
       then putStrLn "Dry run: nothing fetched, nothing saved."
-- 
cgit v1.2.3