diff options
Diffstat (limited to 'validatecert.hs')
-rw-r--r-- | validatecert.hs | 222 |
1 files changed, 222 insertions, 0 deletions
diff --git a/validatecert.hs b/validatecert.hs new file mode 100644 index 0000000..b082419 --- /dev/null +++ b/validatecert.hs | |||
@@ -0,0 +1,222 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, ViewPatterns #-} | ||
2 | -- validatecert.hs | ||
3 | -- | ||
4 | -- translation of cert_valid.pl into haskell | ||
5 | |||
6 | import Data.Char | ||
7 | import Data.Monoid | ||
8 | import Data.List | ||
9 | import Data.Maybe | ||
10 | import qualified Data.Map as Map | ||
11 | import qualified Data.ByteString.Char8 as S | ||
12 | import qualified Data.ByteString.Lazy.Char8 as L | ||
13 | import qualified Data.ByteString.Lazy as L.Word8 | ||
14 | import qualified Codec.Binary.Base64 as Base64 | ||
15 | import Control.Monad | ||
16 | import System.IO.Error | ||
17 | import System.IO | ||
18 | import Data.Map ( Map ) | ||
19 | import Data.Time.LocalTime ( getZonedTime ) | ||
20 | import Data.Time.Format ( formatTime ) | ||
21 | import System.Exit | ||
22 | import System.Posix.Process ( getProcessID ) | ||
23 | import System.Locale ( defaultTimeLocale ) | ||
24 | import System.Environment ( getProgName, getArgs ) | ||
25 | |||
26 | import ScanningParser | ||
27 | import PEM | ||
28 | |||
29 | continue e body = either (const $ return ()) body e | ||
30 | |||
31 | while f = fixIO (\v -> f (return v)) | ||
32 | |||
33 | digits s = S.all isDigit s | ||
34 | |||
35 | bshow :: Show x => x -> S.ByteString | ||
36 | bshow = S.pack . show | ||
37 | |||
38 | toS = foldl1' (<>) . L.toChunks | ||
39 | |||
40 | |||
41 | parseHeader :: S.ByteString -> Either S.ByteString (S.ByteString, S.ByteString, Int, S.ByteString) | ||
42 | parseHeader first_line = parseHeaderWords $ S.words first_line | ||
43 | where | ||
44 | parseHeaderWords (channelId:code:bodylen:body:ignored) | not (digits channelId) | ||
45 | = Left $ channelId <> " BH message=\"This helper is concurrent and requires\ | ||
46 | \ the concurrency option to be specified.\"\1" | ||
47 | parseHeaderWords (channelId:code:bodylen:body:ignored) | not (digits bodylen) | ||
48 | = Left $ channelId <> " BH message=\"cert validator request syntax error.\" \1"; | ||
49 | parseHeaderWords (channelId:code:bodylen:body:ignored) | ||
50 | = Right ( channelId | ||
51 | , code | ||
52 | , read $ S.unpack bodylen | ||
53 | , body <> "\n" | ||
54 | ) | ||
55 | parseHeaderWords (channelId:_) | ||
56 | = Left $ channelId <> " BH message=\"Insufficient words in message.\"\1" | ||
57 | parseHeaderWords [] | ||
58 | = Left "" | ||
59 | |||
60 | data ValidationError = ValidationError | ||
61 | { veName :: S.ByteString | ||
62 | , veCert :: S.ByteString | ||
63 | , veReason :: S.ByteString | ||
64 | } | ||
65 | |||
66 | type Cert = PEMBlob | ||
67 | |||
68 | certSubject :: Cert -> S.ByteString | ||
69 | certSubject cert = "TODO:certSubject" -- TODO | ||
70 | |||
71 | certFormatPEM :: Cert -> S.ByteString | ||
72 | certFormatPEM cert = S.unlines | ||
73 | [ "-----BEGIN " <> toS (pemType cert) <> "-----" | ||
74 | , S.pack $ intercalate "\n" $ split64s base64 | ||
75 | , "-----END " <> toS (pemType cert) <> "-----" | ||
76 | ] | ||
77 | where | ||
78 | base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert | ||
79 | split64s "" = [] | ||
80 | split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta | ||
81 | |||
82 | data ValidationRequest = ValidationRequest | ||
83 | { vrHostname :: S.ByteString | ||
84 | , vrErrors :: Map S.ByteString ValidationError | ||
85 | , vrCerts :: Map S.ByteString Cert | ||
86 | , vrSyntaxErrors :: [L.ByteString] | ||
87 | , vrPeerCertId :: Maybe S.ByteString | ||
88 | } | ||
89 | |||
90 | main = do | ||
91 | debug <- do | ||
92 | args <- getArgs | ||
93 | when (not $ null $ ["-h","--help"] `intersect` args) $ do | ||
94 | me <- getProgName | ||
95 | hPutStr stderr $ usage me | ||
96 | [(["-h","--help"], "brief help message") | ||
97 | ,(["-d","--debug"], "enable debug messages to stderr")] | ||
98 | exitSuccess | ||
99 | return $ not $ null $ ["-d","--debug"] `intersect` args | ||
100 | |||
101 | while $ \next -> do | ||
102 | e <- tryIOError S.getLine | ||
103 | continue e $ \first_line -> do | ||
104 | when (S.all isSpace first_line) | ||
105 | next | ||
106 | flip (either wlog) (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do | ||
107 | body1 <- L.hGet stdin (bodylen - S.length body0) | ||
108 | when debug $ wlog $ "GOT " <> "Code=" <> code <> " " <> bshow bodylen <> "\n" | ||
109 | let body = L.fromChunks $ body0 : L.toChunks body1 | ||
110 | req = parseRequest body | ||
111 | when debug $ forM_ (vrSyntaxErrors req) $ \request -> do | ||
112 | wlog $ "ParseError on \"" <> toS request <> "\"\n" | ||
113 | when debug $ do | ||
114 | wlog $ "Parse result:\n" | ||
115 | wlog $ "\tFOUND host:" <> vrHostname req <> "\n" | ||
116 | let estr = S.intercalate " , " $ map showe $ Map.elems $ vrErrors req | ||
117 | showe e = veName e <> "/" <> veCert e | ||
118 | wlog $ "\tFOUND ERRORS:" <> estr <> "\n" | ||
119 | forM_ (Map.toList $ vrCerts req) $ \(key,cert) -> do | ||
120 | wlog $ "\tFOUND cert " <> key <> ": " <> certSubject cert <> "\n" | ||
121 | let responseErrors = fmap (\ve -> ve { veReason = "Checked by validatecert.hs" }) $ vrErrors req | ||
122 | response0 = createResponse req responseErrors | ||
123 | len = bshow $ S.length response0 | ||
124 | response = if Map.null responseErrors | ||
125 | then channelId <> " OK " <> len <> " " <> response <> "\1" | ||
126 | else channelId <> " ERR " <> len <> " " <> response <> "\1" | ||
127 | S.putStr response | ||
128 | hFlush stdout | ||
129 | when debug $ wlog $ ">> " <> response <> "\n" | ||
130 | |||
131 | createResponse :: ValidationRequest -> Map S.ByteString ValidationError -> S.ByteString | ||
132 | createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems responseErrors | ||
133 | where | ||
134 | mkresp i err = "error_name_" <> bshow i <> "=" <> veName err <> "\n" | ||
135 | <>"error_reason_" <> bshow i <> "=" <> veReason err <> "\n" | ||
136 | <>"error_cert_" <> bshow i <> "=" <> certFormatPEM (vrCertFromErr err) <> "\n" | ||
137 | vrCertFromErr err = vrCerts vr Map.! veCert err | ||
138 | |||
139 | parseRequest body = parseRequest0 vr0 body | ||
140 | where | ||
141 | vr0 = ValidationRequest { vrHostname = "" | ||
142 | , vrErrors = Map.empty | ||
143 | , vrCerts = Map.empty | ||
144 | , vrSyntaxErrors = [] | ||
145 | , vrPeerCertId = Nothing | ||
146 | } | ||
147 | ve0 = ValidationError { veName = "" | ||
148 | , veCert = "" | ||
149 | , veReason = "" | ||
150 | } | ||
151 | parseRequest0 vr request | L.all isSpace request = vr | ||
152 | |||
153 | parseRequest0 vr (splitEq -> Just ("host",L.break (=='\n')->(hostname,rs))) | ||
154 | = parseRequest0 vr' rs | ||
155 | where vr' = vr { vrHostname = toS hostname } | ||
156 | |||
157 | parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var | ||
158 | = parseRequest0 vr' (L.concat rs) | ||
159 | where vr' = maybe vr upd mb | ||
160 | upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr | ||
161 | , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr } | ||
162 | p = pemParser (Just "CERTIFICATE") | ||
163 | (mb,rs) = scanAndParse1 p $ L.lines cert | ||
164 | |||
165 | parseRequest0 vr (digitsId . splitEq -> Just (("error_name",d),L.break (=='\n')->(errorName,rs))) | ||
166 | = parseRequest0 vr' rs | ||
167 | where vr' = vr { vrErrors = Map.alter (setErrorName errorName) (toS d) $ vrErrors vr } | ||
168 | |||
169 | parseRequest0 vr (digitsId . splitEq -> Just (("error_cert",d),L.break (=='\n')->(certId,rs))) | ||
170 | = parseRequest0 vr' rs | ||
171 | where vr' = vr { vrErrors = Map.alter (setErrorCert certId) (toS d) $ vrErrors vr } | ||
172 | |||
173 | parseRequest0 vr req = vr' | ||
174 | where | ||
175 | vr' = vr { vrSyntaxErrors = syntaxError $ vrSyntaxErrors vr } | ||
176 | syntaxError es = es ++ [ req ] | ||
177 | |||
178 | setErrorName :: L.ByteString -> Maybe ValidationError -> Maybe ValidationError | ||
179 | setErrorName x mb = maybe (Just $ ve0 { veName = toS x }) | ||
180 | (\ve -> Just $ ve { veName = toS x }) | ||
181 | mb | ||
182 | |||
183 | setErrorCert :: L.ByteString -> Maybe ValidationError -> Maybe ValidationError | ||
184 | setErrorCert x mb = maybe (Just $ ve0 { veCert = toS x }) | ||
185 | (\ve -> Just $ ve { veCert = toS x }) | ||
186 | mb | ||
187 | |||
188 | digitsId mb = do | ||
189 | (n,v) <- mb | ||
190 | let (n',tl) = L.span isDigit $ L.reverse n | ||
191 | if "_" `L.isPrefixOf` tl | ||
192 | then Just ( (L.reverse $ L.drop 1 tl, L.reverse n'), v ) | ||
193 | else Nothing | ||
194 | |||
195 | splitEq request = if L.null tl then Nothing | ||
196 | else Just (hd,L.drop 1 tl) | ||
197 | where | ||
198 | (hd,tl) = L.break (=='=') $ L.dropWhile isSpace request | ||
199 | |||
200 | wlog msg = do | ||
201 | now <- getZonedTime | ||
202 | pid <- getProcessID | ||
203 | self <- getProgName | ||
204 | hPutStr stderr $ | ||
205 | formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S.0" now | ||
206 | <> " " <> self | ||
207 | <> " " <> show pid | ||
208 | <> " | " <> S.unpack msg | ||
209 | |||
210 | usage :: String -> [([String],String)] -> String | ||
211 | usage cmdname argspec = unlines $ intercalate [""] $ | ||
212 | [ "Usage:" | ||
213 | , tab <> cmdname <> " " <> breif argspec | ||
214 | ] : map helptext argspec | ||
215 | where | ||
216 | tab = " " | ||
217 | tabbb = tab <> tab <> tab | ||
218 | alts as = intercalate " | " as | ||
219 | bracket s = "[" <> s <> "]" | ||
220 | breif spec = intercalate " " $ map (bracket . alts . fst) spec | ||
221 | helptext (as,help) = [ tab <> alts as | ||
222 | , tabbb <> help ] | ||