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