| 1 | #! perl # optional depends=tcp |
1 | #! perl # optional depends=tcp |
| 2 | |
2 | |
| 3 | # http server - this tried to speak enough of http 1.1 (and 1.0) |
3 | # http server - this tries to speak enough of http 1.1 (and 1.0) |
| 4 | # to work with browsers. it does not even attempt to be a complete |
4 | # to work with browsers. it does not even attempt to be a complete |
| 5 | # implementation, although it should be mostly correct for that it does. |
5 | # implementation, although it should be mostly correct for that it does. |
| 6 | |
6 | |
| 7 | sub send { |
7 | sub send { |
| 8 | my $self = $_[0]; |
8 | my $self = $_[0]; |
| … | |
… | |
| 71 | $http = $3; |
71 | $http = $3; |
| 72 | |
72 | |
| 73 | $uri =~ s%^http://[^/]*%%i; # just in case |
73 | $uri =~ s%^http://[^/]*%%i; # just in case |
| 74 | $uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge; # %-decode |
74 | $uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge; # %-decode |
| 75 | |
75 | |
|
|
76 | if (0) { |
| 76 | # my %hdr; |
77 | my %hdr; |
| 77 | # |
78 | |
| 78 | # $hdr{lc $1} .= ",$2" |
79 | $hdr{lc $1} .= ",$2" |
| 79 | # while $req =~ /\G |
80 | while $req =~ /\G |
| 80 | # ([^:\000-\037]*): |
81 | ([^:\000-\037]*): |
| 81 | # [\011\040]* |
82 | [\011\040]* |
| 82 | # ((?: [^\012]+ | \012[\011\040] )*) |
83 | ((?: [^\012]+ | \012[\011\040] )*) |
| 83 | # \012 |
84 | \012 |
| 84 | # /gxc; |
85 | /gxc; |
| 85 | # |
86 | |
| 86 | # $req =~ /\G$/ |
87 | $req =~ /\G$/ |
| 87 | # or return $self->respond ("400 bad request"); |
88 | or return $self->respond ("400 bad request"); |
| 88 | # |
89 | |
| 89 | # # remove the "," prefix we added to all headers above |
90 | # remove the "," prefix we added to all headers above |
| 90 | # substr $_, 0, 1, "" |
91 | substr $_, 0, 1, "" |
| 91 | # for values %hdr; |
92 | for values %hdr; |
|
|
93 | } |
| 92 | |
94 | |
| 93 | if ($http == 1.0) { |
95 | if ($http == 1.0) { |
| 94 | if ($req =~ /^connection\s*:\s*keep-alive/mi) { |
96 | if ($req =~ /^connection\s*:\s*keep-alive/mi) { |
| 95 | $self->{ohdr} = "connection: keep-alive\015\012"; |
97 | $self->{ohdr} = "connection: keep-alive\015\012"; |
| 96 | } else { |
98 | } else { |
| … | |
… | |
| 148 | |
150 | |
| 149 | } elsif (cf::face::find "res/http$uri/index.html") { |
151 | } elsif (cf::face::find "res/http$uri/index.html") { |
| 150 | $self->respond ("302 dirslash", "", "location: $uri/\015\012"); |
152 | $self->respond ("302 dirslash", "", "location: $uri/\015\012"); |
| 151 | |
153 | |
| 152 | } elsif ($uri eq "/debug") { # for debugging |
154 | } elsif ($uri eq "/debug") { # for debugging |
| 153 | my @body = "<html><body>"; |
155 | my @body = <<EOF; |
| 154 | |
156 | <html><head><style> |
|
|
157 | th:nth-child(1) { text-align: right; } |
|
|
158 | th:nth-child(2) { text-align: left; } |
|
|
159 | th:nth-child(3) { text-align: right; } |
|
|
160 | th:nth-child(4) { text-align: left; } |
|
|
161 | th:nth-child(5) { text-align: left; } |
|
|
162 | td:nth-child(1) { text-align: right; font-family: monospace;} |
|
|
163 | td:nth-child(2) { text-align: left; font-family: monospace;} |
|
|
164 | td:nth-child(3) { text-align: right; font-family: monospace;} |
|
|
165 | td:nth-child(4) { text-align: left; } |
|
|
166 | td:nth-child(5) { text-align: left; } |
|
|
167 | </style><body> |
|
|
168 | EOF |
| 155 | for my $type (6, 5, 4, 3, 2, 1, 0) { |
169 | for my $type (6, 5, 4, 3, 2, 1, 0) { |
| 156 | push @body, "<h1>$type</h1><table><tr><th>#</th><th>csum</th><th>size</th><th>name</th><th>meta</th></tr>"; |
170 | push @body, "<h1>$type</h1><table><tr><th>#</th><th>csum</th><th>size</th><th>name</th><th>meta</th></tr>"; |
| 157 | |
171 | |
| 158 | for (1 .. cf::face::faces_size - 1) { |
172 | for (1 .. cf::face::faces_size - 1) { |
| 159 | cf::cede_to_tick; |
173 | cf::cede_to_tick; |
