3 files changed, 443 insertions, 0 deletions

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 ]