/[suikacvs]/test/html-webhacc/cc.cgi
Suika

Diff of /test/html-webhacc/cc.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.59 by wakaba, Mon Jul 21 12:56:33 2008 UTC revision 1.60 by wakaba, Sat Jul 26 11:27:25 2008 UTC
# Line 33  use CGI::Carp qw[fatalsToBrowser]; Line 33  use CGI::Carp qw[fatalsToBrowser];
33    $out->html_header;    $out->html_header;
34    $out->unset_flush;    $out->unset_flush;
35    
   my $input = get_input_document ($http);  
   $out->input ($input);  
   
36    require WebHACC::Result;    require WebHACC::Result;
37    my $result = WebHACC::Result->new;    my $result = WebHACC::Result->new;
   $result->output ($out);  
38    $result->{conforming_min} = 1;    $result->{conforming_min} = 1;
39    $result->{conforming_max} = 1;    $result->{conforming_max} = 1;
40      $result->output ($out);
41    
42    $out->html ('<script src="../cc-script.js"></script>');    require WebHACC::Input;
43      my $input = WebHACC::Input->get_document ($http => $result => $out);
44    
45    check_and_print ($input => $result => $out);    check_and_print ($input => $result => $out);
46        
# Line 123  sub check_and_print ($$$) { Line 121  sub check_and_print ($$$) {
121    $out->input ($original_input);    $out->input ($original_input);
122  } # check_and_print  } # check_and_print
123    
 sub get_input_document ($) {  
   my $http = shift;  
   
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
   
   require Encode;  
   my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));  
   my $r = WebHACC::Input->new;  
   if (defined $request_uri and length $request_uri) {  
     my $uri = $dom->create_uri_reference ($request_uri);  
     unless ({  
              http => 1,  
             }->{lc $uri->uri_scheme}) {  
       $r = WebHACC::Input::Error->new;  
       $r->{uri} = $request_uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = 'URL scheme not allowed';  
     }  
   
     require Message::Util::HostPermit;  
     my $host_permit = new Message::Util::HostPermit;  
     $host_permit->add_rule (<<EOH);  
 Allow host=suika port=80  
 Deny host=suika  
 Allow host=suika.fam.cx port=80  
 Deny host=suika.fam.cx  
 Deny host=localhost  
 Deny host=*.localdomain  
 Deny ipv4=0.0.0.0/8  
 Deny ipv4=10.0.0.0/8  
 Deny ipv4=127.0.0.0/8  
 Deny ipv4=169.254.0.0/16  
 Deny ipv4=172.0.0.0/11  
 Deny ipv4=192.0.2.0/24  
 Deny ipv4=192.88.99.0/24  
 Deny ipv4=192.168.0.0/16  
 Deny ipv4=198.18.0.0/15  
 Deny ipv4=224.0.0.0/4  
 Deny ipv4=255.255.255.255/32  
 Deny ipv6=0::0/0  
 Allow host=*  
 EOH  
     unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {  
       my $r = WebHACC::Input::Error->new;  
       $r->{uri} = $request_uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = 'Connection to the host is forbidden';  
       return $r;  
     }  
   
     require LWP::UserAgent;  
     my $ua = WDCC::LWPUA->new;  
     $ua->{wdcc_dom} = $dom;  
     $ua->{wdcc_host_permit} = $host_permit;  
     $ua->agent ('Mozilla'); ## TODO: for now.  
     $ua->parse_head (0);  
     $ua->protocols_allowed ([qw/http/]);  
     $ua->max_size (1000_000);  
     my $req = HTTP::Request->new (GET => $request_uri);  
     $req->header ('Accept-Encoding' => 'identity, *; q=0');  
     my $res = $ua->request ($req);  
     ## TODO: 401 sets |is_success| true.  
     if ($res->is_success or $http->get_parameter ('error-page')) {  
       $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!  
       $r->{uri} = $res->request->uri;  
       $r->{request_uri} = $request_uri;  
   
       ## TODO: More strict parsing...  
       my $ct = $res->header ('Content-Type');  
       if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {  
         $r->{charset} = lc $1;  
         $r->{charset} =~ tr/\\//d;  
         $r->{official_charset} = $r->{charset};  
       }  
   
       my $input_charset = $http->get_parameter ('charset');  
       if (defined $input_charset and length $input_charset) {  
         $r->{charset_overridden}  
             = (not defined $r->{charset} or $r->{charset} ne $input_charset);  
         $r->{charset} = $input_charset;  
       }  
   
       ## TODO: Support for HTTP Content-Encoding  
   
       $r->{s} = ''.$res->content;  
   
       require Whatpm::ContentType;  
       ($r->{official_type}, $r->{media_type})  
           = Whatpm::ContentType->get_sniffed_type  
               (get_file_head => sub {  
                  return substr $r->{s}, 0, shift;  
                },  
                http_content_type_byte => $ct,  
                has_http_content_encoding =>  
                    defined $res->header ('Content-Encoding'),  
                supported_image_types => {});  
     } else {  
       $r->{uri} = $res->request->uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = $res->status_line;  
     }  
   
     $r->{header_field} = [];  
     $res->scan (sub {  
       push @{$r->{header_field}}, [$_[0], $_[1]];  
     });  
     $r->{header_status_code} = $res->code;  
     $r->{header_status_text} = $res->message;  
   } else {  
     $r->{s} = ''.$http->get_parameter ('s');  
     $r->{uri} = q<thismessage:/>;  
     $r->{request_uri} = q<thismessage:/>;  
     $r->{base_uri} = q<thismessage:/>;  
     $r->{charset} = ''.$http->get_parameter ('_charset_');  
     $r->{charset} =~ s/\s+//g;  
     $r->{charset} = 'utf-8' if $r->{charset} eq '';  
     $r->{official_charset} = $r->{charset};  
     $r->{header_field} = [];  
   
     require Whatpm::ContentType;  
     ($r->{official_type}, $r->{media_type})  
         = Whatpm::ContentType->get_sniffed_type  
             (get_file_head => sub {  
                return substr $r->{s}, 0, shift;  
              },  
              http_content_type_byte => undef,  
              has_http_content_encoding => 0,  
              supported_image_types => {});  
   }  
   
   my $input_format = $http->get_parameter ('i');  
   if (defined $input_format and length $input_format) {  
     $r->{media_type_overridden}  
         = (not defined $r->{media_type} or $input_format ne $r->{media_type});  
     $r->{media_type} = $input_format;  
   }  
   if (defined $r->{s} and not defined $r->{media_type}) {  
     $r->{media_type} = 'text/html';  
     $r->{media_type_overridden} = 1;  
   }  
   
   if ($r->{media_type} eq 'text/xml') {  
     unless (defined $r->{charset}) {  
       $r->{charset} = 'us-ascii';  
       $r->{official_charset} = $r->{charset};  
     } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {  
       $r->{charset_overridden} = 0;  
     }  
   }  
   
   if (length $r->{s} > 1000_000) {  
     $r->{error_status_text} = 'Entity-body too large';  
     delete $r->{s};  
     return $r;  
   }  
   
   $r->{inner_html_element} = $http->get_parameter ('e');  
   
   return $r;  
 } # get_input_document  
   
 package WDCC::LWPUA;  
 BEGIN { push our @ISA, 'LWP::UserAgent'; }  
   
 sub redirect_ok {  
   my $ua = shift;  
   unless ($ua->SUPER::redirect_ok (@_)) {  
     return 0;  
   }  
   
   my $uris = $_[1]->header ('Location');  
   return 0 unless $uris;  
   my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);  
   unless ({  
            http => 1,  
           }->{lc $uri->uri_scheme}) {  
     return 0;  
   }  
   unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {  
     return 0;  
   }  
   return 1;  
 } # redirect_ok  
   
124  =head1 AUTHOR  =head1 AUTHOR
125    
126  Wakaba <w@suika.fam.cx>.  Wakaba <w@suika.fam.cx>.
Legend:
Removed from v.1.59  
changed lines
  Added in v.1.60
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24