#! 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"
. "$_[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/;
"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;
$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 = $1;
my $idx = $cf::FACEHASH{pack "H*", $2};
$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 ($uri eq "/debug") { # for debugging
my @body = "";
for my $type (6, 5, 4, 3, 2, 1, 0) {
push @body, "$type
";
for (1 .. cf::face::faces_size - 1) {
next if $type != cf::face::get_type $_;
my $name = cf::face::get_name $_;
my $id = unpack "H*", cf::face::get_chksum $_, 1;
push @body, "$_ $name ($id)";
push @body, " (meta)" if $type & 1;
push @body, "
";
}
}
push @body, "";
$self->respond ("200 OK", (join "", @body), "Content-Type: text/html\015\012");
} elsif ($uri eq "/ws" && defined &ext::ws::server) {
&ext::ws::server ($self->{id}, $self->{fh}, "$req\015\012\015\012$self->{rbuf}");
%$self = ();
} else {
$self->respond ("404 not found");
}
}
}
our $DETECTOR = ext::tcp::register http => 64, sub {
# regex avoids conflict with websockets, which use /ws
m{^(?i:GET|HEAD|OPTIONS) \ (?! (?i:http://[^/]+)? /ws \ ) }x
}, sub {
my $self = bless {
id => $_[0],
fh => $_[1],
rbuf => $_[2],
wbuf => "",
};
$self->{rw} = AE::io $self->{fh}, 0, sub {
my $len = sysread $self->{fh}, $self->{rbuf}, 4096, length $self->{rbuf};
if ($len == 0) {
delete $self->{rw};
} else {
$self->handle_req;
delete $self->{rw} if length $self->{rbuf} > 8192; # headers too long
}
};
$self->handle_req; # in the unlikely case of the buffer already forming a valid request
};
cf::register_exticmd http_faceurl => sub {
my ($ns) = @_;
"/"
};