#! perl # optional depends=tcp # http server sub send { my $self = $_[0]; $self->{wbuf} .= $_[1]; $self->{ww} ||= AE::io $self->{fh}, 1, sub { my $len = syswrite $self->{fh}, $self->{wbuf}; substr $self->{wbuf}, 0, $len, ""; delete $self->{ww} unless length $self->{wbuf}; }; } sub fatal { my ($self) = @_; $self->send ("HTTP/1.1 500 internal error\015\012"); delete $self->{rw}; } sub respond { $_[0]->send ("HTTP/1.1 $_[1]\015\012" . "content-length: " . (0 + length $_[2]) . "\015\012" . "access-control-allow-origin: *\015\012" . $_[0]{ohdr} . "$_[3]\015\012$_[2]"); } my $cache_headers = "cache-control: max-age=8640000\015\012" . "etag: \"0\"\015\012"; sub content_type { return "content-type: image/png\015\012" if $_[0] =~ /^\x89PNG/; return "content-type: image/jpeg\015\012" if $_[0] =~ /^......JFIF/s; return "content-type: audio/wav\015\012" if $_[0] =~ /^RIFF/; return "content-type: audio/ogg\015\012" if $_[0] =~ /^OggS/; return "content-type: text/html\015\012" if $_[0] =~ /^; "content-type: text/plain\015\012" } sub handle_req { my ($self) = @_; while ($self->{rbuf} =~ s/^( (?: [^\015]+ | . )+? )\015\012\015\012//xs) { my $req = $1; # we ignore headers atm. $req =~ m%^GET (\S+) HTTP/([0-9.]+)\015\012%i or return $self->fatal; my $uri = $1; my $http = $2; if ($http == 1.0) { if ($req =~ /^connection\s*:\s*keep-alive/mi) { $self->{ohdr} = "connection: keep-alive\015\012"; } else { $self->{ohdr} = "connection: close\015\012"; delete $self->{rw}; } } $uri =~ s%^http://[^/]*%%i; # just in case cf::debug "HTTP GET: $self->{id} $uri"; if ($uri =~ m%^/([0-9a-f]+)(M?)$%) { # faces my $want_meta = $2; my $idx = $cf::FACEHASH{pack "H*", $1}; $idx or do { $self->respond ("404 illegal face name"), next }; if ($req =~ /if-none-match/i) { # dirtiest hack evar $self->respond ("304 not modified", "", $cache_headers); next; } my $type = cf::face::get_type $idx, 1; my $data = cf::face::get_data $idx, 1; (my $meta, $data) = unpack "(w/a*)*", $data if $type & 1; if ($want_meta) { if ($type & 1) { $self->respond ("200 OK", $meta, "content-type: text/plain\015\012" . $cache_headers); } else { $self->respond ("404 type $type has no metadata"); } } else { $self->respond ("200 OK", $data, (content_type $data) . $cache_headers); } } elsif (my $idx = (cf::face::find "res/http$uri") || (cf::face::find "res/http${uri}index.html")) { my $data = cf::face::get_data $idx, 1; $self->respond ("200 OK", $data, (content_type $data) . $cache_headers); } elsif (cf::face::find "res/http$uri/index.html") { $self->respond ("302 dirslash", "", "location: $uri/\015\012"); } elsif ($uri eq "/debug") { # for debugging my @body = "
"; for my $type (6, 5, 4, 3, 2, 1, 0) { push @body, "