summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-05-19 14:01:24 -0400
committerjoe <joe@jerkface.net>2014-05-19 14:01:24 -0400
commit63dd196cd5332d755051b6ceb834ee6c6b922dd9 (patch)
treebf5f53141f8b5ccc2a00c9bb0dc69fce84402488
parent1a7aaabd84fc252451b343a7cc840725aed75e09 (diff)
Switched Cert type to Data.X509.SignedCertificate in validatecert
-rw-r--r--validatecert.hs37
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
10import qualified Data.Map as Map 10import qualified Data.Map as Map
11import qualified Data.ByteString.Char8 as S 11import qualified Data.ByteString.Char8 as S
12import qualified Data.ByteString.Lazy.Char8 as L 12import qualified Data.ByteString.Lazy.Char8 as L
13-- import qualified Data.ByteString.Lazy as L.Word8 13import qualified Data.X509 as X509
14-- import qualified Codec.Binary.Base64 as Base64
15import Control.Monad 14import Control.Monad
16import Control.Monad.Fix 15import Control.Monad.Fix
17import System.IO.Error 16import System.IO.Error
@@ -19,6 +18,7 @@ import System.IO
19import Data.Map ( Map ) 18import Data.Map ( Map )
20import Data.Time.LocalTime ( getZonedTime ) 19import Data.Time.LocalTime ( getZonedTime )
21import Data.Time.Format ( formatTime ) 20import Data.Time.Format ( formatTime )
21import Data.X509 as X509 ( SignedCertificate, Certificate, decodeSignedObject, getCertificate )
22import System.Exit 22import System.Exit
23import System.Posix.Process ( getProcessID ) 23import System.Posix.Process ( getProcessID )
24import System.Locale ( defaultTimeLocale ) 24import System.Locale ( defaultTimeLocale )
@@ -62,23 +62,18 @@ data ValidationError = ValidationError
62 , veReason :: S.ByteString 62 , veReason :: S.ByteString
63 } 63 }
64 64
65type Cert = PEMBlob 65type Cert = SignedCertificate -- PEMBlob
66
67pemToCert :: PEMBlob -> Maybe Cert
68pemToCert pem = either (const Nothing) Just $ decodeSignedObject obj
69 where
70 obj = foldl1' (<>) $ L.toChunks $ pemBlob pem
66 71
67certSubject :: Cert -> S.ByteString 72certSubject :: Cert -> S.ByteString
68certSubject cert = "TODO:certSubject" -- TODO 73certSubject cert = maybe "" X509.getCharacterStringRawData cn
69
70{-
71certFormatPEM :: Cert -> S.ByteString
72certFormatPEM cert = S.unlines
73 [ "-----BEGIN " <> toS (pemType cert) <> "-----"
74 , S.pack $ intercalate "\n" $ split64s base64
75 , "-----END " <> toS (pemType cert) <> "-----"
76 ]
77 where 74 where
78 base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert 75 dn = X509.certSubjectDN $ X509.getCertificate cert
79 split64s "" = [] 76 cn = X509.getDnElement X509.DnCommonName dn
80 split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
81-}
82 77
83data ValidationRequest = ValidationRequest 78data ValidationRequest = ValidationRequest
84 { vrHostname :: S.ByteString 79 { vrHostname :: S.ByteString
@@ -141,6 +136,7 @@ createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems r
141 <>"error_cert_" <> bshow i <> "=" <> veCert err <> "\n" 136 <>"error_cert_" <> bshow i <> "=" <> veCert err <> "\n"
142 -- vrCertFromErr err = vrCerts vr Map.! veCert err 137 -- vrCertFromErr err = vrCerts vr Map.! veCert err
143 138
139parseRequest :: L.ByteString -> ValidationRequest
144parseRequest body = parseRequest0 vr0 body 140parseRequest body = parseRequest0 vr0 body
145 where 141 where
146 vr0 = ValidationRequest { vrHostname = "" 142 vr0 = ValidationRequest { vrHostname = ""
@@ -153,6 +149,9 @@ parseRequest body = parseRequest0 vr0 body
153 , veCert = "" 149 , veCert = ""
154 , veReason = "" 150 , veReason = ""
155 } 151 }
152
153 parseRequest0 :: ValidationRequest -> L.ByteString -> ValidationRequest
154
156 parseRequest0 vr request | L.all isSpace request = vr 155 parseRequest0 vr request | L.all isSpace request = vr
157 156
158 parseRequest0 vr (splitEq -> Just ("host",L.break (=='\n')->(hostname,rs))) 157 parseRequest0 vr (splitEq -> Just ("host",L.break (=='\n')->(hostname,rs)))
@@ -161,8 +160,10 @@ parseRequest body = parseRequest0 vr0 body
161 160
162 parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var 161 parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var
163 = parseRequest0 vr' $ L.unlines rs 162 = parseRequest0 vr' $ L.unlines rs
164 where vr' = maybe vr upd mb 163 where vr' = maybe vr upd $ mb >>= pemToCert
165 upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr 164 upd cert = vr { vrCerts = Map.insert (toS var)
165 cert
166 $ vrCerts vr
166 , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr } 167 , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr }
167 p = pemParser (Just "CERTIFICATE") 168 p = pemParser (Just "CERTIFICATE")
168 (mb,rs) = scanAndParse1 p $ L.lines cert 169 (mb,rs) = scanAndParse1 p $ L.lines cert