1package HTTPServer; 2 3use strict; 4use warnings; 5 6use HTTP::Daemon; 7use HTTP::Status; 8use HTTP::Headers; 9use HTTP::Response; 10 11our @ISA=qw(HTTP::Daemon); 12my $VERSION = 0.01; 13 14my $CRLF = "\015\012"; # "\r\n" is not portable 15my $log = undef; 16 17sub run { 18 my ($self, $urls, $synch_callback) = @_; 19 my $initialized = 0; 20 21 while (1) { 22 if (!$initialized) { 23 $synch_callback->(); 24 $initialized = 1; 25 } 26 my $con = $self->accept(); 27 print STDERR "Accepted a new connection\n" if $log; 28 while (my $req = $con->get_request) { 29 #my $url_path = $req->url->path; 30 my $url_path = $req->url->as_string; 31 if ($url_path =~ m{/$}) { # append 'index.html' 32 $url_path .= 'index.html'; 33 } 34 #if ($url_path =~ m{^/}) { # remove trailing '/' 35 # $url_path = substr ($url_path, 1); 36 #} 37 if ($log) { 38 print STDERR "Method: ", $req->method, "\n"; 39 print STDERR "Path: ", $url_path, "\n"; 40 print STDERR "Available URLs: ", "\n"; 41 foreach my $key (keys %$urls) { 42 print STDERR $key, "\n"; 43 } 44 } 45 if (exists($urls->{$url_path})) { 46 print STDERR "Serving requested URL: ", $url_path, "\n" if $log; 47 next unless ($req->method eq "HEAD" || $req->method eq "GET"); 48 49 my $url_rec = $urls->{$url_path}; 50 $self->send_response($req, $url_rec, $con); 51 } else { 52 print STDERR "Requested wrong URL: ", $url_path, "\n" if $log; 53 $con->send_error($HTTP::Status::RC_FORBIDDEN); 54 last; 55 } 56 } 57 print STDERR "Closing connection\n" if $log; 58 $con->close; 59 } 60} 61 62sub send_response { 63 my ($self, $req, $url_rec, $con) = @_; 64 65 # create response 66 my ($code, $msg, $headers); 67 my $send_content = ($req->method eq "GET"); 68 if (exists $url_rec->{'auth_method'}) { 69 ($send_content, $code, $msg, $headers) = 70 $self->handle_auth($req, $url_rec); 71 } elsif (!$self->verify_request_headers ($req, $url_rec)) { 72 ($send_content, $code, $msg, $headers) = 73 ('', 400, 'Mismatch on expected headers', {}); 74 } else { 75 ($code, $msg) = @{$url_rec}{'code', 'msg'}; 76 $headers = $url_rec->{headers}; 77 } 78 my $resp = HTTP::Response->new ($code, $msg); 79 print STDERR "HTTP::Response: \n", $resp->as_string if $log; 80 81 while (my ($name, $value) = each %{$headers}) { 82 # print STDERR "setting header: $name = $value\n"; 83 $resp->header($name => $value); 84 } 85 print STDERR "HTTP::Response with headers: \n", $resp->as_string if $log; 86 87 if ($send_content) { 88 my $content = $url_rec->{content}; 89 if (exists($url_rec->{headers}{"Content-Length"})) { 90 # Content-Length and length($content) don't match 91 # manually prepare the HTTP response 92 $con->send_basic_header($url_rec->{code}, $resp->message, $resp->protocol); 93 print $con $resp->headers_as_string($CRLF); 94 print $con $CRLF; 95 print $con $content; 96 next; 97 } 98 if ($req->header("Range") && !$url_rec->{'force_code'}) { 99 $req->header("Range") =~ m/bytes=(\d*)-(\d*)/; 100 my $content_len = length($content); 101 my $start = $1 ? $1 : 0; 102 my $end = $2 ? $2 : ($content_len - 1); 103 my $len = $2 ? ($2 - $start) : ($content_len - $start); 104 if ($len > 0) { 105 $resp->header("Accept-Ranges" => "bytes"); 106 $resp->header("Content-Length" => $len); 107 $resp->header("Content-Range" 108 => "bytes $start-$end/$content_len"); 109 $resp->header("Keep-Alive" => "timeout=15, max=100"); 110 $resp->header("Connection" => "Keep-Alive"); 111 $con->send_basic_header(206, 112 "Partial Content", $resp->protocol); 113 print $con $resp->headers_as_string($CRLF); 114 print $con $CRLF; 115 print $con substr($content, $start, $len); 116 } else { 117 $con->send_basic_header(416, "Range Not Satisfiable", 118 $resp->protocol); 119 $resp->header("Keep-Alive" => "timeout=15, max=100"); 120 $resp->header("Connection" => "Keep-Alive"); 121 print $con $CRLF; 122 } 123 next; 124 } 125 # fill in content 126 $content = $self->_substitute_port($content) if defined $content; 127 $resp->content($content); 128 print STDERR "HTTP::Response with content: \n", $resp->as_string if $log; 129 } 130 131 $con->send_response($resp); 132 print STDERR "HTTP::Response sent: \n", $resp->as_string if $log; 133} 134 135# Generates appropriate response content based on the authentication 136# status of the URL. 137sub handle_auth { 138 my ($self, $req, $url_rec) = @_; 139 my ($send_content, $code, $msg, $headers); 140 # Catch failure to set code, msg: 141 $code = 500; 142 $msg = "Didn't set response code in handle_auth"; 143 # Most cases, we don't want to send content. 144 $send_content = 0; 145 # Initialize headers 146 $headers = {}; 147 my $authhdr = $req->header('Authorization'); 148 149 # Have we sent the challenge yet? 150 unless ($url_rec->{auth_challenged} || $url_rec->{auth_no_challenge}) { 151 # Since we haven't challenged yet, we'd better not 152 # have received authentication (for our testing purposes). 153 if ($authhdr) { 154 $code = 400; 155 $msg = "You sent auth before I sent challenge"; 156 } else { 157 # Send challenge 158 $code = 401; 159 $msg = "Authorization Required"; 160 $headers->{'WWW-Authenticate'} = $url_rec->{'auth_method'} 161 . " realm=\"wget-test\""; 162 $url_rec->{auth_challenged} = 1; 163 } 164 } elsif (!defined($authhdr)) { 165 # We've sent the challenge; we should have received valid 166 # authentication with this one. A normal server would just 167 # resend the challenge; but since this is a test, wget just 168 # failed it. 169 $code = 400; 170 $msg = "You didn't send auth after I sent challenge"; 171 if ($url_rec->{auth_no_challenge}) { 172 $msg = "--auth-no-challenge but no auth sent." 173 } 174 } else { 175 my ($sent_method) = ($authhdr =~ /^(\S+)/g); 176 unless ($sent_method eq $url_rec->{'auth_method'}) { 177 # Not the authorization type we were expecting. 178 $code = 400; 179 $msg = "Expected auth type $url_rec->{'auth_method'} but got " 180 . "$sent_method"; 181 } elsif (($sent_method eq 'Digest' 182 && &verify_auth_digest($authhdr, $url_rec, \$msg)) 183 || 184 ($sent_method eq 'Basic' 185 && &verify_auth_basic($authhdr, $url_rec, \$msg))) { 186 # SUCCESSFUL AUTH: send expected message, headers, content. 187 ($code, $msg) = @{$url_rec}{'code', 'msg'}; 188 $headers = $url_rec->{headers}; 189 $send_content = 1; 190 } else { 191 $code = 400; 192 } 193 } 194 195 return ($send_content, $code, $msg, $headers); 196} 197 198sub verify_auth_digest { 199 return undef; # Not yet implemented. 200} 201 202sub verify_auth_basic { 203 require MIME::Base64; 204 my ($authhdr, $url_rec, $msgref) = @_; 205 my $expected = MIME::Base64::encode_base64($url_rec->{'user'} . ':' 206 . $url_rec->{'passwd'}, ''); 207 my ($got) = $authhdr =~ /^Basic (.*)$/; 208 if ($got eq $expected) { 209 return 1; 210 } else { 211 $$msgref = "Wanted ${expected} got ${got}"; 212 return undef; 213 } 214} 215 216sub verify_request_headers { 217 my ($self, $req, $url_rec) = @_; 218 219 return 1 unless exists $url_rec->{'request_headers'}; 220 for my $hdrname (keys %{$url_rec->{'request_headers'}}) { 221 my $rhdr = $req->header ($hdrname); 222 my $ehdr = $url_rec->{'request_headers'}{$hdrname}; 223 unless (defined $rhdr && $rhdr =~ $ehdr) { 224 $rhdr = '' unless defined $rhdr; 225 print STDERR "\n*** Mismatch on $hdrname: $rhdr =~ $ehdr\n"; 226 return undef; 227 } 228 } 229 230 return 1; 231} 232 233sub _substitute_port { 234 my $self = shift; 235 my $ret = shift; 236 $ret =~ s/{{port}}/$self->sockport/eg; 237 return $ret; 238} 239 2401; 241 242# vim: et ts=4 sw=4 243 244