redir_ssl.pl

#!/usr/bin/perl
#
#  Redir SSL for Squid v0.1
#
#  Copyright (C) 2008 asq@asq.art.pl
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License Version 2 as
#  published by the Free Software Foundation.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
#  USA.
#
#  $Id$

use POSIX;
use DBI;
use DBD::SQLite;
use LWP::UserAgent;
use Net::Telnet ();
use Sys::SigAction qw(timeout_call);
use strict;

$|=1;

my $dbfile='/var/db/squid/ssl.db';
my $timeout=5;

my $dbh;

if (!-f $dbfile) {
    $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",{PrintError=>1}) || die $DBI::errstr;
    &create_db || die;
} else {
    $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","","",{PrintError=>1}) || die $DBI::errstr;
}

while (<>) {
    chomp;
    @_ = split /\s+/;
    my $url=$_[0];
    my $ip=$_[1];
    my $user=$_[2];
    my $method=$_[3];
    if ($method ne 'CONNECT') {
        &return_ok($_,'not an SSL attempt at all');
        next;
    } else {
        my $url_up_one=$url;
        $url_up_one=~s/.*?\./\./;
        # check if we're whitelisted
        &check_in_wl($url) && &return_ok($url,'whitelisted') && next;
        &check_in_wl($url_up_one) && &return_ok($url_up_one,'whitelisted') && next;

        # check if we already know anything about site
        my ($code,$msg) = &check_url($url);
        if ($code) {
            &return_ok($url,$msg);
            next;
        } else {
            &return_fail($url,$msg);
            next;
        }
    }
}

$dbh->disconnect();

sub create_db {
    &log('No DB -- creating');
    my $sth = $dbh->prepare("CREATE TABLE 'whitelisted' (id integer primary key autoincrement, url text, date int not null, user text not null, reason text not null)");
    $sth->execute() || return 0;
    $sth = $dbh->prepare("CREATE TABLE cache (id integer primary key autoincrement, url text, is_verified boolean, expiry int, cipher text, issuer text, subject text, comment text)");
    $sth->execute() || return 0;
    return 1;
}

sub log {
    my $msg=shift;
    my $timenow=strftime("%Y/%m/%d %H:%M:%S", localtime);
    print STDERR "$timenow| ".$0."[$$]: $msg\n";
}

sub return_ok {
    my $url=shift;
    my $msg=shift||'no reason';
    &log("=> $url <= PASSING: $msg");
    print "\n";
}

sub return_fail {
    my $url=shift;
    my $msg=shift||'ERROR: Unknown error please contact your administrator!';
    my $blockurl='http://w3cache.non.3dart.com/SSLvfail.html';
    &log("=> $url <= BLOCKING: $msg");
    $msg=~s/\s+/\+/g;
    print "302:$blockurl?url=$url&reason=$msg\n";
}

sub check_in_wl {
    my $url=shift;
    my $sth = $dbh->prepare("SELECT url FROM whitelisted WHERE url=?") || die;
    $sth->execute($url) || die;
    my $row = $sth->fetch;
    if ($row->[0]) {
        return 1;
    }
    return 0;
}

sub check_in_cache {
    my $url=shift;
    my $timenow=time();
    my $sth;
    # delete stale cache entries if any
    if (time()%60 eq 0) {
        &log('Sweeping cache');
        $sth = $dbh->prepare("DELETE FROM cache WHERE expiry<=?");
        $sth->execute($timenow) || die;
    } else {
        &log('Cleaning up cache for '.$url);
        $sth = $dbh->prepare("DELETE FROM cache WHERE url=? and expiry<=?");
        $sth->execute($url,$timenow) || die;
    }
    # check if we already know anything about site
    $sth = $dbh->prepare("SELECT url,is_verified,comment FROM cache WHERE url=? and expiry>?") || die;
    $sth->execute($url,$timenow) || die;
    my $row = $sth->fetch;
    if ($row->[0]) {
        if ($row->[1]) {
            # yes! it's clean
            &log("$url is clean in cache");
            return 1,$row->[2];
        } else {
            # yes! block it
            &log("$url blocked in cache: ".$row->[2]);
            return 0, $row->[2];
        }
    } else {
        # inconclusive
        &log("$url not in cache");
        return -1;
    }
}

sub check_url {
    my $url=shift;
    my ($status,$msg,$r);
    ($status,$msg) = &check_in_cache($url);
    if ($status eq -1) {
        foreach ('https://'.$url.'/robots.txt', 'https://'.$url.'/favicon.ico', 'https://'.$url.'/') {
            ($status,$msg,$r)=&check_one_url($_);
            last if ($status eq 1);
        }
        # this is expensive - run last, only if all previous test succeeded
        if ($status eq 1) {
            my ($status_p,$msg_p)=&check_proto($url);
            if ($status_p eq 0) {
                &write_in_cache($status_p,$url,$msg_p);
                return $status_p, $msg_p;
            }
        }
        &write_in_cache($status,$url,$msg,$r);
        return $status, $msg;
    } else {
        return $status, $msg;
    }
}

sub check_proto {
    my $url=shift;
    my $host;
    my $port;
    if ($url=~/^(.*):(\d+)$/) {
        $host=$1;
        $port=$2;
    } else {
        $host=$url;
        $port=80;
    }
    my $proto = new Net::Telnet (Telnetmode => 0, Timeout => $timeout, Errmode => 'return');
    $proto->open(Host => $host, Port => $port) || return 0,"Unable to connect: ".$proto->errmsg();

    ## Read connection message.
    my $line;
    eval { $line = $proto->getline; };
    if ($line) {
        chomp($line);
        # talked first, not https
        &log("Protocol error: $line");
        return 0, "Protocol error: $line";
    } else {
        &log("$url - protocol clean");
        return 1,"$url - protocol clean";
    }
}

sub check_one_url {
    my $url=shift;
    my $ua = LWP::UserAgent->new(keep_alive => 0,timeout => $timeout);
    $ua->proxy(https => undef);
    $ENV{'https_proxy'}='';
    $ua->agent('Mozilla/5.0 Probe');
    my $rq=HTTP::Request->new(GET => $url);
    my $r;

    # protect us from network timeouts
    # $r=$ua->request($rq);
    if (timeout_call ($timeout+1, sub { $r=$ua->request($rq); } )) {
        $r=HTTP::Response->new(408,
                                "Connection timed out",
                                [ 'Client-Warning' => 'Internal response' ]
                              ); #408 is the HTTP timeout
    } else {
        $r;
    }

    my $status=$r->status_line;
    if ($r->header('Client-Warning')) { # Internal response
        &log("GET $url internal fatal: ".$r->header('Client-Warning')." ".$status);
        return 0, 'INTERNAL: '.$status, $r;
    }
    if ($r->is_success) {
        &log("GET $url ok: ".$status);
        return 1, $status, $r;
    }
    if ($r->code eq 404) {
        &log("GET $url conditional ok: ".$status);
        return 1, 'CONDITIONAL: '.$status, $r;
    }
    &log("GET $url code fatal: ".$r->header('Client-Warning')." ".$status);
    return 0, $status, $r;
}

sub write_in_cache {
    my $state=shift;
    my $url=shift;
    my $comment=shift||'';
    my $r=shift||0;
    my $ts=time()+(($state)?43200:3600);
    my $sth = $dbh->prepare("INSERT INTO cache (url,is_verified,expiry,cipher,issuer,subject,comment) VALUES (?,?,?,?,?,?,?)") || die;
    my ($cipher,$issuer,$subject);
    if ($r) {
        $cipher=$r->header('client-ssl-cipher');
        $issuer=$r->header('client-ssl-cert-issuer');
        $subject=$r->header('client-ssl-cert-subject');
    }
    $sth->execute(
        $url,
        $state,
        $ts,
        $cipher,
        $issuer,
        $subject,
        $comment) || die;
}