Switched Cert type to Data.X509.SignedCertificate in validatecert

1 files changed, 19 insertions, 18 deletions

diff --git a/validatecert.hs b/validatecert.hs
index a318275..19df9fc 100644
--- a/validatecert.hs
+++ b/validatecert.hs
@@ -10,8 +10,7 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
--- import qualified Data.ByteString.Lazy as L.Word8
--- import qualified Codec.Binary.Base64 as Base64
+import qualified Data.X509 as X509
 import Control.Monad
 import Control.Monad.Fix
 import System.IO.Error
@@ -19,6 +18,7 @@ import System.IO
 import Data.Map             ( Map )
 import Data.Time.LocalTime  ( getZonedTime )
 import Data.Time.Format     ( formatTime )
+import Data.X509 as X509    ( SignedCertificate, Certificate, decodeSignedObject, getCertificate )
 import System.Exit
 import System.Posix.Process ( getProcessID )
 import System.Locale        ( defaultTimeLocale )
@@ -62,23 +62,18 @@ data ValidationError = ValidationError
     , veReason :: S.ByteString
     }
 
-type Cert = PEMBlob
+type Cert = SignedCertificate -- PEMBlob
+
+pemToCert :: PEMBlob -> Maybe Cert
+pemToCert pem = either (const Nothing) Just $ decodeSignedObject obj
+ where
+    obj = foldl1' (<>) $ L.toChunks $ pemBlob pem
 
 certSubject :: Cert -> S.ByteString
-certSubject cert = "TODO:certSubject" -- TODO
-
-{-
-certFormatPEM :: Cert -> S.ByteString
-certFormatPEM cert = S.unlines
-    [ "-----BEGIN " <> toS (pemType cert) <> "-----"
-    , S.pack $ intercalate "\n" $ split64s base64
-    , "-----END " <> toS (pemType cert) <> "-----"
-    ]
+certSubject cert = maybe "" X509.getCharacterStringRawData cn
  where
-    base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert
-    split64s "" = []
-    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
--}
+    dn = X509.certSubjectDN $ X509.getCertificate cert
+    cn = X509.getDnElement X509.DnCommonName dn
 
 data ValidationRequest = ValidationRequest
     { vrHostname :: S.ByteString
@@ -141,6 +136,7 @@ createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems r
                  <>"error_cert_" <> bshow i <> "=" <> veCert err <> "\n"
     -- vrCertFromErr err = vrCerts vr Map.! veCert err
 
+parseRequest :: L.ByteString -> ValidationRequest
 parseRequest body = parseRequest0 vr0 body
  where
     vr0 = ValidationRequest { vrHostname = ""
@@ -153,6 +149,9 @@ parseRequest body = parseRequest0 vr0 body
                           , veCert = ""
                           , veReason = ""
                           }
+
+    parseRequest0 :: ValidationRequest -> L.ByteString -> ValidationRequest
+
     parseRequest0 vr request | L.all isSpace request = vr
 
     parseRequest0 vr (splitEq -> Just ("host",L.break (=='\n')->(hostname,rs)))
@@ -161,8 +160,10 @@ parseRequest body = parseRequest0 vr0 body
 
     parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var
         = parseRequest0 vr' $ L.unlines rs
-     where vr' = maybe vr upd mb
-           upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr
+     where vr' = maybe vr upd $ mb >>= pemToCert
+           upd cert = vr { vrCerts = Map.insert (toS var)
+                                                cert
+                                                $ vrCerts vr
                          , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr }
            p = pemParser (Just "CERTIFICATE")
            (mb,rs) = scanAndParse1 p $ L.lines cert