view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP/IMP/CSRFprotect.pm  view on Meta::CPAN

# 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 {