File Coverage

blib/lib/App/HTTP_Proxy_IMP/IMP/CSRFprotect.pm

Criterion	Covered	Total	%
statement	26	113	23.0
branch	3	46	6.5
condition	0	3	0.0
subroutine	8	17	47.0
pod			n/a
total	37	179	20.6

# PoC for CSRF protection
# see pod at the end for detailed description of the idea and references

use strict;
use warnings;
package App::HTTP_Proxy_IMP::IMP::CSRFprotect;
use base 'Net::IMP::HTTP::Request';
use fields (
    'target',       # target domain from request header
    'origin',       # domain from origin/referer request header
);

use Net::IMP qw(:DEFAULT :log);
use Net::IMP::Debug;
use Net::IMP::HTTP;

sub RTYPES { return (
    IMP_REPLACE, # remove Cookie/Authorization header
    IMP_LOG,     # log if we removed something
    IMP_DENY,    # bad requests/responses
    IMP_PASS,
)}

sub new_analyzer {
    my ($class,%args) = @_;
    my $self = $class->SUPER::new_analyzer(%args);
    $self->run_callback(
	# we will not modify response, but need to look at the response
	# header to detect redirects. After the response header was seen
	# this will be upgraded to IMP_PASS
	[ IMP_PREPASS,1,IMP_MAXOFFSET]
    );
    return $self;
}

sub request_hdr {
    my ($self,$hdr) = @_;
    # modify if necessary, rest of request can be forwarded w/o inspection
    my $len = length($hdr);
    my @rv;
    if ( defined( my $newhdr = _modify_rqhdr($self,$hdr))) {
	push @rv, [ IMP_REPLACE,0,$len,$newhdr ];
    }
    $self->run_callback(@rv,[ IMP_PASS,0,IMP_MAXOFFSET ]);
}

sub response_hdr {
    my ($self,$hdr) = @_;
    # response header
    _analyze_rphdr($self,$hdr);
    $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ]); # upgrade to IMP_PASS
}


{
    # FIXME - should expire after a short time
    # FIXME - for multi-process environments it needs to be shared
    #         between processes
    # DELEGATION{FROM}{TO}: e.g. FROM delegated to TO by
    #  - having a POST request to TO with origin/referer FROM
    #  - having a redirect to TO in response from FROM
    my %DELEGATION;

    sub _delegate {
	my ($origin,$target,$why) = @_;
	if ( $DELEGATION{$origin}{$target} ) {
	    debug("refresh delegation $origin -> $target ($why)");
	    $DELEGATION{$origin}{$target} = 1;
	} else {
	    debug("add delegation $origin -> $target ($why)");
	    $DELEGATION{$origin}{$target} = 1;
	}
    }

    sub _delegation_exists {
	my ($origin,$target) = @_;
	return $DELEGATION{$origin}{$target};
    }
}

# extract target and origin domain
# if they differ remove cookies and authorization infos unless we have
#   an established trust between these domains
my $rx_host = qr{([\w\-.]+|\[[\da-fA-F:.]+\])};
my $rx_host_from_url = qr{^https?://$rx_host};
sub _modify_rqhdr {
    my ($self,$hdr) = @_;

    # determine target
    my (@target) = $hdr =~m{\A\w+[ \t]+http://$rx_host};
    @target = _gethdr($hdr,'Host',$rx_host) if ! @target;
    if ( ! @target or @target>1 ) {
	$self->run_callback(
	    [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
		"cannot determine target from request\n".$hdr ],
	    [ IMP_DENY,0, "cannot determine target from request" ]
	);
	return;
    }

    # determine referer/origin domain
    my @origin = _gethdr($hdr,'Origin',$rx_host_from_url);
    @origin = _gethdr($hdr,'Referer',$rx_host_from_url) if ! @origin;
    if ( @origin > 1 ) {
	# invalid: conflicting origins
	$self->run_callback(
	    [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
		"conflicting origins in request\n".$hdr ],
	    [ IMP_DENY,0, "conflicting origins in request" ]
	);
	return;
    }

    if ( ! @origin ) {
	# we have no origin to check trust inside request
	debug("no origin to check trust in request to @target");

    } else {
	# do nothing unless the request is cross-origin
	$self->{origin} = $origin[0];
	$self->{target} = $target[0];
	return if $origin[0] eq $target[0];

	# implicite trust when both have the same root-domain
	my $origin = _rootdom($origin[0]);
	my $target = _rootdom($target[0]);
	if ( $origin eq $target ) {
	    debug("trusted request from $origin[0] to $target[0] (same root-dom)");
	    return
	}

	# check if this is a delegation (POST)
	if ( $hdr =~m{\APOST } ) {
	    _delegate($origin,$target,'POST');
	}

	# consider the request trused if we got an earlier delegation from
	# $target to $origin (e.g. in the other direction)
	if ( _delegation_exists($target,$origin)) {
	    debug("trusted request from $origin to $target (earlier delegation)");
	    return
	}
    }

    # remove cookies, because there is no cross-domain trust
    # we should remove authorization header too, but then access to the
    # protected site will probably not be available at all (see BUGS section)
    my @del;
    push @del,$1 while ( $hdr =~s{^(Cookie|Cookie2):[ \t]*(.*(?:\n[ \t].*)*)\n}{}im );
    if (@del) {
	$self->run_callback([
	    IMP_LOG,0,0,0,IMP_LOG_INFO,
	    "removed cross-origin session credentials (@del) for request @origin -> @target"
	]);
	# return changed header
	return $hdr;
    }

    # nothing changed
    return undef;
}

# find out if response header contains delegation through a redirect
sub _analyze_rphdr {
    my ($self,$hdr) = @_;
    # we are only interested in temporal redirects
    $hdr =~m{\AHTTP/1\.[01] 30[237]} or return;

    my @location = _gethdr($hdr,'Location',$rx_host_from_url)
	or return; # no redirect
    if ( @location > 1 ) {
	# invalid: multiple conflicting redirects
	$self->run_callback(
	    [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
		"conflicting redirects in response\n".$hdr ],
	    [ IMP_DENY,0, "conflicting redirects in response" ]
	);
	return;
    }
    my $location = $location[0];
    my $target   = $self->{target} or return;
    return if $target eq $location; # no cross-domain

    $target   = _rootdom($target);
    $location = _rootdom($location);
    return if $target eq $location; # not considered cross-domain too

    _delegate($target,$location,'redirect');
}

sub _gethdr {
    my ($hdr,$key,$rx) = @_;
    my @val;
    for ( $hdr =~m{^\Q$key\E:[ \t]*(.*(?:\n[ \t].*)*)}mgi ) {
	s{\r\n}{}g;
	s{\s+$}{};
	s{^\s+}{};
	push @val, m{$rx};
    }
    my %v;
    return grep { ! $v{$_}++ } @val;
}

BEGIN {
    if ( eval { require WWW::CSP::PublicDNSSuffix } ) {
	*_rootdom = sub {
	    my ($rest,$tld) = WWW::CSP::PublicDNSSuffix::public_suffix( shift );
	    return $rest =~m{([^.]+)$} ? "$1.$tld" : undef;
	}
    } elsif ( eval { require Mozilla::PublicSuffix }) {
	*_rootdom = sub {
	    my $host = shift;
	    my $suffix = Mozilla::PublicSuffix::public_suffix($host);
	    return $host =~m{([^\.]+\.\Q$suffix)} ? $1:undef,
	}
    } elsif ( my $suffix = eval {
	require Domain::PublicSuffix;
	Domain::PublicSuffix->new
    }) {
	*_rootdom = sub { return $suffix->get_root_domain( shift ) }
    } else {
	die "need one of Domain::PublicSuffix, Mozilla::PublicSuffix or WWW::CSP::PublicDNSSuffix"
    }
}

1;
__END__