summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-05-15 04:45:05 -0400
committerjoe <joe@jerkface.net>2014-05-15 04:45:05 -0400
commit73e9081cbd07359d85926d16d9ef1bf418e61f96 (patch)
tree59976d8ecbf5eaf457ab3460d0c08b632c9beb50
parent7307fb20e430ef896131f0fd6bfe2ae2371e1008 (diff)
fixes
-rw-r--r--PEM.hs2
-rw-r--r--validatecert.hs34
2 files changed, 21 insertions, 15 deletions
diff --git a/PEM.hs b/PEM.hs
index 7b27e04..f969484 100644
--- a/PEM.hs
+++ b/PEM.hs
@@ -24,7 +24,7 @@ pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
24 let typ = L.take (L.length x0 - 5) x0 24 let typ = L.take (L.length x0 - 5) x0
25 return typ 25 return typ
26 26
27 pbdy typ xs = (mblob, rs) 27 pbdy typ xs = (mblob, drop 1 rs)
28 where 28 where
29 (ys,rs) = span (/="-----END " <> typ <> "-----") xs 29 (ys,rs) = span (/="-----END " <> typ <> "-----") xs
30 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta) 30 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
diff --git a/validatecert.hs b/validatecert.hs
index b082419..a318275 100644
--- a/validatecert.hs
+++ b/validatecert.hs
@@ -10,9 +10,10 @@ 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
13import qualified Data.ByteString.Lazy as L.Word8 13-- import qualified Data.ByteString.Lazy as L.Word8
14import qualified Codec.Binary.Base64 as Base64 14-- import qualified Codec.Binary.Base64 as Base64
15import Control.Monad 15import Control.Monad
16import Control.Monad.Fix
16import System.IO.Error 17import System.IO.Error
17import System.IO 18import System.IO
18import Data.Map ( Map ) 19import Data.Map ( Map )
@@ -28,8 +29,6 @@ import PEM
28 29
29continue e body = either (const $ return ()) body e 30continue e body = either (const $ return ()) body e
30 31
31while f = fixIO (\v -> f (return v))
32
33digits s = S.all isDigit s 32digits s = S.all isDigit s
34 33
35bshow :: Show x => x -> S.ByteString 34bshow :: Show x => x -> S.ByteString
@@ -55,7 +54,7 @@ parseHeader first_line = parseHeaderWords $ S.words first_line
55 parseHeaderWords (channelId:_) 54 parseHeaderWords (channelId:_)
56 = Left $ channelId <> " BH message=\"Insufficient words in message.\"\1" 55 = Left $ channelId <> " BH message=\"Insufficient words in message.\"\1"
57 parseHeaderWords [] 56 parseHeaderWords []
58 = Left "" 57 = Left $ "what: " <> bshow first_line <> "\n"
59 58
60data ValidationError = ValidationError 59data ValidationError = ValidationError
61 { veName :: S.ByteString 60 { veName :: S.ByteString
@@ -68,6 +67,7 @@ type Cert = PEMBlob
68certSubject :: Cert -> S.ByteString 67certSubject :: Cert -> S.ByteString
69certSubject cert = "TODO:certSubject" -- TODO 68certSubject cert = "TODO:certSubject" -- TODO
70 69
70{-
71certFormatPEM :: Cert -> S.ByteString 71certFormatPEM :: Cert -> S.ByteString
72certFormatPEM cert = S.unlines 72certFormatPEM cert = S.unlines
73 [ "-----BEGIN " <> toS (pemType cert) <> "-----" 73 [ "-----BEGIN " <> toS (pemType cert) <> "-----"
@@ -78,6 +78,7 @@ certFormatPEM cert = S.unlines
78 base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert 78 base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert
79 split64s "" = [] 79 split64s "" = []
80 split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta 80 split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
81-}
81 82
82data ValidationRequest = ValidationRequest 83data ValidationRequest = ValidationRequest
83 { vrHostname :: S.ByteString 84 { vrHostname :: S.ByteString
@@ -98,14 +99,17 @@ main = do
98 exitSuccess 99 exitSuccess
99 return $ not $ null $ ["-d","--debug"] `intersect` args 100 return $ not $ null $ ["-d","--debug"] `intersect` args
100 101
101 while $ \next -> do 102 fix $ \next -> do
102 e <- tryIOError S.getLine 103 e <- tryIOError S.getLine
103 continue e $ \first_line -> do 104 continue e $ \first_line -> do
104 when (S.all isSpace first_line) 105 when (S.all isSpace first_line)
105 next 106 next
106 flip (either wlog) (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do 107 let wlog' s | debug = wlog s
107 body1 <- L.hGet stdin (bodylen - S.length body0) 108 | otherwise = return ()
109 flip (either wlog') (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do
108 when debug $ wlog $ "GOT " <> "Code=" <> code <> " " <> bshow bodylen <> "\n" 110 when debug $ wlog $ "GOT " <> "Code=" <> code <> " " <> bshow bodylen <> "\n"
111 body1 <- L.hGet stdin (bodylen - S.length body0)
112 `catchIOError` (const $ return "")
109 let body = L.fromChunks $ body0 : L.toChunks body1 113 let body = L.fromChunks $ body0 : L.toChunks body1
110 req = parseRequest body 114 req = parseRequest body
111 when debug $ forM_ (vrSyntaxErrors req) $ \request -> do 115 when debug $ forM_ (vrSyntaxErrors req) $ \request -> do
@@ -122,19 +126,20 @@ main = do
122 response0 = createResponse req responseErrors 126 response0 = createResponse req responseErrors
123 len = bshow $ S.length response0 127 len = bshow $ S.length response0
124 response = if Map.null responseErrors 128 response = if Map.null responseErrors
125 then channelId <> " OK " <> len <> " " <> response <> "\1" 129 then channelId <> " OK " <> len <> " " <> response0 <> "\1"
126 else channelId <> " ERR " <> len <> " " <> response <> "\1" 130 else channelId <> " ERR " <> len <> " " <> response0 <> "\1"
127 S.putStr response 131 S.putStr response
128 hFlush stdout 132 hFlush stdout
129 when debug $ wlog $ ">> " <> response <> "\n" 133 when debug $ wlog $ ">> " <> S.init response <> "\n"
134 next
130 135
131createResponse :: ValidationRequest -> Map S.ByteString ValidationError -> S.ByteString 136createResponse :: ValidationRequest -> Map S.ByteString ValidationError -> S.ByteString
132createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems responseErrors 137createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems responseErrors
133 where 138 where
134 mkresp i err = "error_name_" <> bshow i <> "=" <> veName err <> "\n" 139 mkresp i err = "error_name_" <> bshow i <> "=" <> veName err <> "\n"
135 <>"error_reason_" <> bshow i <> "=" <> veReason err <> "\n" 140 <>"error_reason_" <> bshow i <> "=" <> veReason err <> "\n"
136 <>"error_cert_" <> bshow i <> "=" <> certFormatPEM (vrCertFromErr err) <> "\n" 141 <>"error_cert_" <> bshow i <> "=" <> veCert err <> "\n"
137 vrCertFromErr err = vrCerts vr Map.! veCert err 142 -- vrCertFromErr err = vrCerts vr Map.! veCert err
138 143
139parseRequest body = parseRequest0 vr0 body 144parseRequest body = parseRequest0 vr0 body
140 where 145 where
@@ -155,7 +160,7 @@ parseRequest body = parseRequest0 vr0 body
155 where vr' = vr { vrHostname = toS hostname } 160 where vr' = vr { vrHostname = toS hostname }
156 161
157 parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var 162 parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var
158 = parseRequest0 vr' (L.concat rs) 163 = parseRequest0 vr' $ L.unlines rs
159 where vr' = maybe vr upd mb 164 where vr' = maybe vr upd mb
160 upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr 165 upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr
161 , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr } 166 , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr }
@@ -206,6 +211,7 @@ wlog msg = do
206 <> " " <> self 211 <> " " <> self
207 <> " " <> show pid 212 <> " " <> show pid
208 <> " | " <> S.unpack msg 213 <> " | " <> S.unpack msg
214 hFlush stderr
209 215
210usage :: String -> [([String],String)] -> String 216usage :: String -> [([String],String)] -> String
211usage cmdname argspec = unlines $ intercalate [""] $ 217usage cmdname argspec = unlines $ intercalate [""] $