validatecert.hs demonstrating squid's SslServerCertValidator feature.

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 @@
+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}
+-- validatecert.hs
+--
+-- translation of cert_valid.pl into haskell
+
+import Data.Char
+import Data.Monoid
+import Data.List
+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 Control.Monad
+import System.IO.Error
+import System.IO
+import Data.Map             ( Map )
+import Data.Time.LocalTime  ( getZonedTime )
+import Data.Time.Format     ( formatTime )
+import System.Exit
+import System.Posix.Process ( getProcessID )
+import System.Locale        ( defaultTimeLocale )
+import System.Environment   ( getProgName, getArgs )
+
+import ScanningParser
+import PEM
+
+continue e body = either (const $ return ()) body e
+
+while f = fixIO (\v -> f (return v))
+
+digits s = S.all isDigit s
+
+bshow :: Show x => x -> S.ByteString
+bshow = S.pack . show
+
+toS = foldl1' (<>) . L.toChunks
+
+
+parseHeader :: S.ByteString -> Either S.ByteString (S.ByteString, S.ByteString, Int, S.ByteString)
+parseHeader first_line = parseHeaderWords $ S.words first_line
+ where
+    parseHeaderWords (channelId:code:bodylen:body:ignored) | not (digits channelId)
+        = Left $ channelId <> " BH message=\"This helper is concurrent and requires\
+                              \ the concurrency option to be specified.\"\1"
+    parseHeaderWords (channelId:code:bodylen:body:ignored) | not (digits bodylen)
+        = Left $ channelId <> " BH message=\"cert validator request syntax error.\" \1";
+    parseHeaderWords (channelId:code:bodylen:body:ignored)
+        = Right ( channelId
+                , code
+                , read $ S.unpack bodylen
+                , body <> "\n"
+                )
+    parseHeaderWords (channelId:_)
+        = Left $ channelId <> " BH message=\"Insufficient words in message.\"\1"
+    parseHeaderWords []
+        = Left ""
+
+data ValidationError = ValidationError
+    { veName :: S.ByteString
+    , veCert :: S.ByteString
+    , veReason :: S.ByteString
+    }
+
+type Cert = PEMBlob
+
+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) <> "-----"
+    ]
+ where
+    base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert
+    split64s "" = []
+    split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
+
+data ValidationRequest = ValidationRequest
+    { vrHostname :: S.ByteString
+    , vrErrors :: Map S.ByteString ValidationError
+    , vrCerts :: Map S.ByteString Cert
+    , vrSyntaxErrors :: [L.ByteString]
+    , vrPeerCertId :: Maybe S.ByteString
+    }
+
+main = do
+    debug <- do
+        args <- getArgs
+        when (not $ null $ ["-h","--help"] `intersect` args) $ do
+            me <- getProgName
+            hPutStr stderr $ usage me
+                [(["-h","--help"], "brief help message")
+                ,(["-d","--debug"], "enable debug messages to stderr")]
+            exitSuccess
+        return $ not $ null $ ["-d","--debug"] `intersect` args
+
+    while $ \next -> do
+        e <- tryIOError S.getLine
+        continue e $ \first_line -> do
+        when (S.all isSpace first_line)
+             next
+        flip (either wlog) (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do
+        body1 <- L.hGet stdin (bodylen - S.length body0)
+        when debug $ wlog $ "GOT " <> "Code=" <> code <> " " <> bshow bodylen <> "\n"
+        let body = L.fromChunks $ body0 : L.toChunks body1
+            req = parseRequest body
+        when debug $ forM_ (vrSyntaxErrors req) $ \request -> do
+            wlog $ "ParseError on \"" <> toS request <> "\"\n"
+        when debug $ do
+            wlog $ "Parse result:\n"
+            wlog $ "\tFOUND host:" <> vrHostname req <> "\n"
+            let estr = S.intercalate " , " $ map showe $ Map.elems $ vrErrors req
+                showe e = veName e <> "/" <> veCert e
+            wlog $ "\tFOUND ERRORS:" <> estr <> "\n"
+            forM_ (Map.toList $ vrCerts req) $ \(key,cert) -> do
+                wlog $ "\tFOUND cert " <> key <> ": " <> certSubject cert <> "\n"
+        let responseErrors = fmap (\ve -> ve { veReason = "Checked by validatecert.hs" }) $ vrErrors req
+            response0 = createResponse req responseErrors
+            len = bshow $ S.length response0
+            response = if Map.null responseErrors
+                        then channelId <> " OK "  <> len <> " " <> response <> "\1"
+                        else channelId <> " ERR " <> len <> " " <> response <> "\1"
+        S.putStr response
+        hFlush stdout
+        when debug $ wlog $ ">> " <> response <> "\n"
+
+createResponse :: ValidationRequest -> Map S.ByteString ValidationError -> S.ByteString
+createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems responseErrors
+ where
+    mkresp i err = "error_name_" <> bshow i <> "=" <> veName err <> "\n"
+                 <>"error_reason_" <> bshow i <> "=" <> veReason err <> "\n"
+                 <>"error_cert_" <> bshow i <> "=" <> certFormatPEM (vrCertFromErr err) <> "\n"
+    vrCertFromErr err = vrCerts vr Map.! veCert err
+
+parseRequest body = parseRequest0 vr0 body
+ where
+    vr0 = ValidationRequest { vrHostname = ""
+                            , vrErrors = Map.empty
+                            , vrCerts = Map.empty
+                            , vrSyntaxErrors = []
+                            , vrPeerCertId = Nothing
+                            }
+    ve0 = ValidationError { veName = ""
+                          , veCert = ""
+                          , veReason = ""
+                          }
+    parseRequest0 vr request | L.all isSpace request = vr
+
+    parseRequest0 vr (splitEq -> Just ("host",L.break (=='\n')->(hostname,rs)))
+        = parseRequest0 vr' rs
+     where vr' = vr { vrHostname = toS hostname }
+
+    parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var
+        = parseRequest0 vr' (L.concat rs)
+     where vr' = maybe vr upd mb
+           upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr
+                         , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr }
+           p = pemParser (Just "CERTIFICATE")
+           (mb,rs) = scanAndParse1 p $ L.lines cert
+
+    parseRequest0 vr (digitsId . splitEq -> Just (("error_name",d),L.break (=='\n')->(errorName,rs)))
+        = parseRequest0 vr' rs
+     where vr' = vr { vrErrors = Map.alter (setErrorName errorName) (toS d) $ vrErrors vr }
+
+    parseRequest0 vr (digitsId . splitEq -> Just (("error_cert",d),L.break (=='\n')->(certId,rs)))
+        = parseRequest0 vr' rs
+     where vr' = vr { vrErrors = Map.alter (setErrorCert certId) (toS d) $ vrErrors vr }
+
+    parseRequest0 vr req = vr'
+      where
+        vr' = vr { vrSyntaxErrors = syntaxError $ vrSyntaxErrors vr }
+        syntaxError es = es ++ [ req ]
+    
+    setErrorName :: L.ByteString -> Maybe ValidationError -> Maybe ValidationError
+    setErrorName x mb = maybe (Just $ ve0 { veName = toS x })
+                              (\ve -> Just $ ve { veName = toS x })
+                              mb
+
+    setErrorCert :: L.ByteString -> Maybe ValidationError -> Maybe ValidationError
+    setErrorCert x mb = maybe (Just $ ve0 { veCert = toS x })
+                              (\ve -> Just $ ve { veCert = toS x })
+                              mb
+
+    digitsId mb = do
+        (n,v) <- mb
+        let (n',tl) = L.span isDigit $ L.reverse n
+        if "_" `L.isPrefixOf` tl
+            then Just ( (L.reverse $ L.drop 1 tl, L.reverse n'), v )
+            else Nothing
+
+    splitEq request = if L.null tl then Nothing
+                                   else Just (hd,L.drop 1 tl)
+     where
+        (hd,tl) = L.break (=='=') $ L.dropWhile isSpace request
+
+wlog msg = do
+    now <- getZonedTime
+    pid <- getProcessID
+    self <- getProgName
+    hPutStr stderr $
+        formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S.0" now
+             <> " " <> self
+             <> " " <> show pid
+             <> " | " <> S.unpack msg
+
+usage :: String -> [([String],String)] -> String
+usage cmdname argspec = unlines $ intercalate [""] $
+    [ "Usage:"
+    , tab <> cmdname <> " " <> breif argspec
+    ] : map helptext argspec
+ where
+    tab = "    "
+    tabbb = tab <> tab <> tab
+    alts as = intercalate " | " as
+    bracket s = "[" <> s <> "]"
+    breif spec = intercalate " " $ map (bracket . alts . fst) spec
+    helptext (as,help) = [ tab <> alts as
+                         , tabbb <> help ]