File Coverage

blib/lib/App/HTTP_Proxy_IMP/IMP/CSRFprotect.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # PoC for CSRF protection
2             # see pod at the end for detailed description of the idea and references
3              
4 1     1   4413 use strict;
  1         2  
  1         32  
5 1     1   7 use warnings;
  1         2  
  1         34  
6             package App::HTTP_Proxy_IMP::IMP::CSRFprotect;
7 1     1   5 use base 'Net::IMP::HTTP::Request';
  1         2  
  1         851  
8             use fields (
9             'target', # target domain from request header
10             'origin', # domain from origin/referer request header
11             );
12              
13             use Net::IMP qw(:DEFAULT :log);
14             use Net::IMP::Debug;
15             use Net::IMP::HTTP;
16              
17             sub RTYPES { return (
18             IMP_REPLACE, # remove Cookie/Authorization header
19             IMP_LOG, # log if we removed something
20             IMP_DENY, # bad requests/responses
21             IMP_PASS,
22             )}
23              
24             sub new_analyzer {
25             my ($class,%args) = @_;
26             my $self = $class->SUPER::new_analyzer(%args);
27             $self->run_callback(
28             # we will not modify response, but need to look at the response
29             # header to detect redirects. After the response header was seen
30             # this will be upgraded to IMP_PASS
31             [ IMP_PREPASS,1,IMP_MAXOFFSET]
32             );
33             return $self;
34             }
35              
36             sub request_hdr {
37             my ($self,$hdr) = @_;
38             # modify if necessary, rest of request can be forwarded w/o inspection
39             my $len = length($hdr);
40             my @rv;
41             if ( defined( my $newhdr = _modify_rqhdr($self,$hdr))) {
42             push @rv, [ IMP_REPLACE,0,$len,$newhdr ];
43             }
44             $self->run_callback(@rv,[ IMP_PASS,0,IMP_MAXOFFSET ]);
45             }
46              
47             sub response_hdr {
48             my ($self,$hdr) = @_;
49             # response header
50             _analyze_rphdr($self,$hdr);
51             $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ]); # upgrade to IMP_PASS
52             }
53              
54              
55             {
56             # FIXME - should expire after a short time
57             # FIXME - for multi-process environments it needs to be shared
58             # between processes
59             # DELEGATION{FROM}{TO}: e.g. FROM delegated to TO by
60             # - having a POST request to TO with origin/referer FROM
61             # - having a redirect to TO in response from FROM
62             my %DELEGATION;
63              
64             sub _delegate {
65             my ($origin,$target,$why) = @_;
66             if ( $DELEGATION{$origin}{$target} ) {
67             debug("refresh delegation $origin -> $target ($why)");
68             $DELEGATION{$origin}{$target} = 1;
69             } else {
70             debug("add delegation $origin -> $target ($why)");
71             $DELEGATION{$origin}{$target} = 1;
72             }
73             }
74              
75             sub _delegation_exists {
76             my ($origin,$target) = @_;
77             return $DELEGATION{$origin}{$target};
78             }
79             }
80              
81             # extract target and origin domain
82             # if they differ remove cookies and authorization infos unless we have
83             # an established trust between these domains
84             my $rx_host = qr{([\w\-.]+|\[[\da-fA-F:.]+\])};
85             my $rx_host_from_url = qr{^https?://$rx_host};
86             sub _modify_rqhdr {
87             my ($self,$hdr) = @_;
88            
89             # determine target
90             my (@target) = $hdr =~m{\A\w+[ \t]+http://$rx_host};
91             @target = _gethdr($hdr,'Host',$rx_host) if ! @target;
92             if ( ! @target or @target>1 ) {
93             $self->run_callback(
94             [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
95             "cannot determine target from request\n".$hdr ],
96             [ IMP_DENY,0, "cannot determine target from request" ]
97             );
98             return;
99             }
100              
101             # determine referer/origin domain
102             my @origin = _gethdr($hdr,'Origin',$rx_host_from_url);
103             @origin = _gethdr($hdr,'Referer',$rx_host_from_url) if ! @origin;
104             if ( @origin > 1 ) {
105             # invalid: conflicting origins
106             $self->run_callback(
107             [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
108             "conflicting origins in request\n".$hdr ],
109             [ IMP_DENY,0, "conflicting origins in request" ]
110             );
111             return;
112             }
113              
114             if ( ! @origin ) {
115             # we have no origin to check trust inside request
116             debug("no origin to check trust in request to @target");
117              
118             } else {
119             # do nothing unless the request is cross-origin
120             $self->{origin} = $origin[0];
121             $self->{target} = $target[0];
122             return if $origin[0] eq $target[0];
123              
124             # implicite trust when both have the same root-domain
125             my $origin = _rootdom($origin[0]);
126             my $target = _rootdom($target[0]);
127             if ( $origin eq $target ) {
128             debug("trusted request from $origin[0] to $target[0] (same root-dom)");
129             return
130             }
131              
132             # check if this is a delegation (POST)
133             if ( $hdr =~m{\APOST } ) {
134             _delegate($origin,$target,'POST');
135             }
136              
137             # consider the request trused if we got an earlier delegation from
138             # $target to $origin (e.g. in the other direction)
139             if ( _delegation_exists($target,$origin)) {
140             debug("trusted request from $origin to $target (earlier delegation)");
141             return
142             }
143             }
144              
145             # remove cookies, because there is no cross-domain trust
146             # we should remove authorization header too, but then access to the
147             # protected site will probably not be available at all (see BUGS section)
148             my @del;
149             push @del,$1 while ( $hdr =~s{^(Cookie|Cookie2):[ \t]*(.*(?:\n[ \t].*)*)\n}{}im );
150             if (@del) {
151             $self->run_callback([
152             IMP_LOG,0,0,0,IMP_LOG_INFO,
153             "removed cross-origin session credentials (@del) for request @origin -> @target"
154             ]);
155             # return changed header
156             return $hdr;
157             }
158              
159             # nothing changed
160             return undef;
161             }
162              
163             # find out if response header contains delegation through a redirect
164             sub _analyze_rphdr {
165             my ($self,$hdr) = @_;
166             # we are only interested in temporal redirects
167             $hdr =~m{\AHTTP/1\.[01] 30[237]} or return;
168              
169             my @location = _gethdr($hdr,'Location',$rx_host_from_url)
170             or return; # no redirect
171             if ( @location > 1 ) {
172             # invalid: multiple conflicting redirects
173             $self->run_callback(
174             [ IMP_LOG,0,0,0,IMP_LOG_WARNING,
175             "conflicting redirects in response\n".$hdr ],
176             [ IMP_DENY,0, "conflicting redirects in response" ]
177             );
178             return;
179             }
180             my $location = $location[0];
181             my $target = $self->{target} or return;
182             return if $target eq $location; # no cross-domain
183              
184             $target = _rootdom($target);
185             $location = _rootdom($location);
186             return if $target eq $location; # not considered cross-domain too
187              
188             _delegate($target,$location,'redirect');
189             }
190              
191             sub _gethdr {
192             my ($hdr,$key,$rx) = @_;
193             my @val;
194             for ( $hdr =~m{^\Q$key\E:[ \t]*(.*(?:\n[ \t].*)*)}mgi ) {
195             s{\r\n}{}g;
196             s{\s+$}{};
197             s{^\s+}{};
198             push @val, m{$rx};
199             }
200             my %v;
201             return grep { ! $v{$_}++ } @val;
202             }
203              
204             BEGIN {
205             if ( eval { require WWW::CSP::PublicDNSSuffix } ) {
206             *_rootdom = sub {
207             my ($rest,$tld) = WWW::CSP::PublicDNSSuffix::public_suffix( shift );
208             return $rest =~m{([^.]+)$} ? "$1.$tld" : undef;
209             }
210             } elsif ( eval { require Mozilla::PublicSuffix }) {
211             *_rootdom = sub {
212             my $host = shift;
213             my $suffix = Mozilla::PublicSuffix::public_suffix($host);
214             return $host =~m{([^\.]+\.\Q$suffix)} ? $1:undef,
215             }
216             } elsif ( my $suffix = eval {
217             require Domain::PublicSuffix;
218             Domain::PublicSuffix->new
219             }) {
220             *_rootdom = sub { return $suffix->get_root_domain( shift ) }
221             } else {
222             die "need one of Domain::PublicSuffix, Mozilla::PublicSuffix or WWW::CSP::PublicDNSSuffix"
223             }
224             }
225              
226             1;
227             __END__