From 7307fb20e430ef896131f0fd6bfe2ae2371e1008 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 14 May 2014 23:04:50 -0400 Subject: validatecert.hs demonstrating squid's SslServerCertValidator feature. --- ScanningParser.hs | 11 +++ cert_valid.pl | 210 +++++++++++++++++++++++++++++++++++++++++++++++++++ validatecert.hs | 222 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 443 insertions(+) create mode 100755 cert_valid.pl create mode 100644 validatecert.hs diff --git a/ScanningParser.hs b/ScanningParser.hs index a0a5d23..f99e120 100644 --- a/ScanningParser.hs +++ b/ScanningParser.hs @@ -3,6 +3,7 @@ module ScanningParser ( ScanningParser(..) , scanAndParse + , scanAndParse1 ) where import Data.Maybe @@ -61,3 +62,13 @@ scanAndParse psr@(ScanningParser ffst pbdy) ts = do b <- ffst x return (b,drop 1 ts) +scanAndParse1 :: ScanningParser a c -> [a] -> (Maybe c, [a]) +scanAndParse1 psr@(ScanningParser ffst pbdy) ts = + maybe (Nothing,[]) (uncurry pbdy) mb + where + mb = listToMaybe $ mapMaybe findfst' tss + tss = tails ts + findfst' ts = do + x <- listToMaybe ts + b <- ffst x + return (b,drop 1 ts) diff --git a/cert_valid.pl b/cert_valid.pl new file mode 100755 index 0000000..41a1984 --- /dev/null +++ b/cert_valid.pl @@ -0,0 +1,210 @@ +#!/usr/bin/perl -w +# +# A dummy SSL certificate validator helper that +# echos back all the SSL errors sent by Squid. +# + +use warnings; +use strict; +use Getopt::Long; +use Pod::Usage; +use Crypt::OpenSSL::X509; +use FileHandle; +use POSIX qw(strftime); + +my $debug = 0; +my $help = 0; + +=pod + +=head1 NAME + +cert_valid.pl - A fake cert validation helper for Squid + +=head1 SYNOPSIS + +cert_valid.pl [-d | --debug] [-h | --help] + +=over 8 + +=item B<-h | --help> + +brief help message + +=item B<-d | --debug> + +enable debug messages to stderr + +=back + +=head1 DESCRIPTION + +Retrieves the SSL certificate error list from squid and echo back without any change. + +=head1 COPYRIGHT + +(C) 2012 The Measurement Factory, Author: Tsantilas Christos + +This program is free software. You may redistribute copies of it under the +terms of the GNU General Public License version 2, or (at your opinion) any +later version. + +=cut + +GetOptions( + 'help' => \$help, + 'debug' => \$debug, + ) or pod2usage(1); + +pod2usage(1) if ($help); + +$|=1; +while (<>) { + my $first_line = $_; + my @line_args = split; + + if ($first_line =~ /^\s*$/) { + next; + } + + my $response; + my $haserror = 0; + my $channelId = $line_args[0]; + my $code = $line_args[1]; + my $bodylen = $line_args[2]; + my $body = $line_args[3] . "\n"; + if ($channelId !~ /\d+/) { + $response = $channelId." BH message=\"This helper is concurrent and requires the concurrency option to be specified.\"\1"; + } elsif ($bodylen !~ /\d+/) { + $response = $channelId." BH message=\"cert validator request syntax error \" \1"; + } else { + my $readlen = length($body); + my %certs = (); + my %errors = (); + my @responseErrors = (); + + while($readlen < $bodylen) { + my $t = <>; + if (defined $t) { + $body = $body . $t; + $readlen = length($body); + } + } + + print(STDERR logPrefix()."GOT ". "Code=".$code." $bodylen \n") if ($debug); #.$body; + my $hostname; + parseRequest($body, \$hostname, \%errors, \%certs); + print(STDERR logPrefix()."Parse result: \n") if ($debug); + print(STDERR logPrefix()."\tFOUND host:".$hostname."\n") if ($debug); + print(STDERR logPrefix()."\tFOUND ERRORS:") if ($debug); + foreach my $err (keys %errors) { + print(STDERR logPrefix().$errors{$err}{"name"}."/".$errors{$err}{"cert"}." ,") if ($debug); + } + print(STDERR "\n") if ($debug); + foreach my $key (keys %certs) { + ## Use "perldoc Crypt::OpenSSL::X509" for X509 available methods. + print(STDERR logPrefix()."\tFOUND cert ".$key.": ".$certs{$key}->subject() . "\n") if ($debug); + } + + #got the peer certificate ID. Assume that the peer certificate is the first one. + my $peerCertId = (keys %certs)[0]; + + # Echo back the errors: fill the responseErrors array with the errors we read. + foreach my $err (keys %errors) { + $haserror = 1; + appendError (\@responseErrors, + $errors{$err}{"name"}, #The error name + "Checked by Cert Validator", # An error reason + $errors{$err}{"cert"} # The cert ID. We are always filling with the peer certificate. + ); + } + + $response = createResponse(\@responseErrors); + my $len = length($response); + if ($haserror) { + $response = $channelId." ERR ".$len." ".$response."\1"; + } else { + $response = $channelId." OK ".$len." ".$response."\1"; + } + } + + print $response; + print(STDERR logPrefix().">> ".$response."\n") if ($debug); +} + +sub trim +{ + my $s = shift; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub appendError +{ + my ($errorArrays) = shift; + my($errorName) = shift; + my($errorReason) = shift; + my($errorCert) = shift; + push @$errorArrays, { "error_name" => $errorName, "error_reason" => $errorReason, "error_cert" => $errorCert}; +} + +sub createResponse +{ + my ($responseErrors) = shift; + my $response=""; + my $i = 0; + foreach my $err (@$responseErrors) { + $response=$response."error_name_".$i."=".$err->{"error_name"}."\n". + "error_reason_".$i."=".$err->{"error_reason"}."\n". + "error_cert_".$i."=".$err->{"error_cert"}."\n"; + $i++; + } + return $response; +} + +sub parseRequest +{ + my($request)=shift; + my $hostname = shift; + my $errors = shift; + my $certs = shift; + while ($request !~ /^\s*$/) { + $request = trim($request); + if ($request =~ /^host=/) { + my($vallen) = index($request, "\n"); + my $host = substr($request, 5, $vallen - 5); + $$hostname = $host; + $request =~ s/^host=.*$//m; + } + if ($request =~ /^cert_(\d+)=/) { + my $certId = "cert_".$1; + my($vallen) = index($request, "-----END CERTIFICATE-----") + length("-----END CERTIFICATE-----"); + my $x509 = Crypt::OpenSSL::X509->new_from_string(substr($request, index($request, "-----BEGIN"))); + $certs->{$certId} = $x509; + $request = substr($request, $vallen); + } + elsif ($request =~ /^error_name_(\d+)=(.*)$/m) { + my $errorId = $1; + my $errorName = $2; + $request =~ s/^error_name_\d+=.*$//m; + $errors->{$errorId}{"name"} = $errorName; + } + elsif ($request =~ /^error_cert_(\d+)=(.*)$/m) { + my $errorId = $1; + my $certId = $2; + $request =~ s/^error_cert_\d+=.*$//m; + $errors->{$errorId}{"cert"} = $certId; + } + else { + print(STDERR logPrefix()."ParseError on \"".$request."\"\n") if ($debug); + $request = "";# finish processing.... + } + } +} + + +sub logPrefix +{ + return strftime("%Y/%m/%d %H:%M:%S.0", localtime)." ".$0." ".$$." | " ; +} 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 ] -- cgit v1.2.3