#!/usr/bin/perl -w use strict; $| = 1; my $now = time; my $path = $ENV{'PATH_INFO'}; my $host_name = lc($ENV{'HTTP_HOST'}); my $script_name = $ENV{'SCRIPT_NAME'}; my $triple_dot_date = read_cookie ('tripledot'); my $normal_date = read_cookie ('normal'); $path = '' if (not defined $path); my $path_date = $path; $path_date =~ s#^/\d+-\d+-##o; my $base_domain = $host_name; $base_domain =~ s/\.+$//og; my $body_tag = ''; if ((not $path) or ($path_date < ($now - 120))) { my $cookie = make_cookie ({ -name => 'normal', -value => $now, -path => '/', -expires => $now+864000 }); print <<"EOF"; Status: 302 Temporarily Moved $cookie Location: http://${base_domain}...${script_name}/1-$$-$now EOF } elsif (($host_name eq "${base_domain}...") and ($path =~ m#^/1-\d+-\d+$#o)) { my $cookie = make_cookie ({ -name => 'tripledot', -value => $now, -path => '/', -domain => '...', -expires => $now+864000 }); print <<"EOF"; Status: 302 Temporarily Moved $cookie Location: http://${base_domain}$script_name/2-$$-$now EOF } elsif (($host_name eq "${base_domain}") and ($path =~ m#^/2-\d+-\d+$#o)) { my $cookie = make_cookie ({ -name => 'normal', -value => $now, -path => '/', -expires => $now+864000 }); print <<"EOF"; Status: 302 Temporarily Moved $cookie Location: http://${base_domain}...$script_name/3-$$-$now EOF } elsif (($host_name eq "${base_domain}...") and ($path =~ m#^/3-\d+-\d+$#o)) { if ($triple_dot_date) { print <<"EOF"; Status: 302 Temporarily Moved Location: http://${base_domain}$script_name/4-$$-$now EOF } else { print <<"EOF"; Status: 302 Temporarily Moved Location: http://${base_domain}$script_name/5-$$-$now EOF } } elsif (($host_name eq $base_domain) and ($path =~m#^/4-\d+-\d+$#o)) { &print_vulnerable($1); } elsif (($host_name eq $base_domain) and ($path =~m#^/5-\d+-\d+$#o)) { &print_safe; } else { print <<"EOF"; Content-Type: text/html Hen...ne... $body_tag

Hen...ne...

Something went seriously wrong - this message should never appear. It probably indicates that your web browser did something like strip a trailing '.' character off of the domain.

host_name=$host_name
base_domain=$base_domain
path=$path
path_date=$path_date
script_name=$script_name
triple_dot_date=$triple_dot_date
EOF } sub print_vulnerable { my ($cookie_value) = @_; print <<"EOF"; Content-Type: text/html Your browser is currently vulnerable to triple dot cookies

Your browser tests as vulnerable

Your browser is vulnerable to 'triple dot' cookies. This means that by bouncing you off a domain ending in '...', a cookie can be set that can be shared with any web server on the Internet.

Turning off cookies completely or setting them so you are notified for every cookie request is the only way to avoid this bug.

EOF } sub print_safe { print <<"EOF"; Content-Type: text/html Browser is currently safe from triple dot cookies

Your browser is NOT vulnerable to 'triple dot' cookies

Congratulations. Your browser is NOT vulnerable to 'triple dot' cookies at this moment.

EOF if ($normal_date) { print <<"EOF";

We were able to set a regular cookie however, so you are probably safe against this attack in general.

EOF } else { print <<"EOF";

This does not mean your browser does not have the bug, however. Since you apparently refuse all cookies we simply can't detect whether you would be subject to it if you turned on cookies. If you want to find out if your browser has this bug, turn cookies on and then click on this link: TEST BROWSER.

EOF } print <<"EOF"; EOF } sub read_cookie { my ($want_name) = @_; return () if (not exists $ENV{'HTTP_COOKIE'}); my @results = (); my $cookie = $ENV{'HTTP_COOKIE'}; my (@pairs) = split(/;/o,$cookie); my $pair; foreach $pair (@pairs) { my ($name,$value) = split(/=/o,$pair,2); push (@results,$value) if ($name eq $want_name); } return (@results); } sub make_cookie { my ($parms) = @_; my $name = $parms->{-name}; my $value = $parms->{-value}; my $path = $parms->{-path}; my $domain = $parms->{-domain}; my $expires = $parms->{-expires}; if (defined ($expires) and ($expires ne '')) { my $date_string = cookie_date($expires); $expires = "; expires=\"$date_string\""; } else { $expires = ''; } if (defined ($path) and ($path ne '')) { $path = "; path=$path"; } else { $path = ""; } if (defined ($domain) and ($domain ne '')) { $domain ="; domain=$domain"; } else { $domain = ''; } return "Set-Cookie: ${name}=${value}$path$domain$expires"; } sub cookie_date { my ($tick) = @_; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst, $month,$wkday); ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=gmtime($tick); $wkday = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat')[$wday]; $month = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mon]; $sec = "0$sec" if (length($sec) < 2); $min = "0$min" if (length($min) < 2); $hour = "0$hour" if (length($hour) < 2); $mday = "0$mday" if (length($mday) < 2); $year += 1900; return ("$wkday, ${mday}-${month}-${year} ${hour}\:${min}\:${sec} GMT"); }