#!/usr/bin/perl -w

###----------------------------------------###
###     httpd server class                 ###
###----------------------------------------###

use base qw(Net::Server::Single);
use strict;
use Cwd 'getcwd';

@ARGV == 3 or die "usage: simple-httpd <document root> <log dir> <port>\n";
my ($DOCUMENT_ROOT, $SERVER_ROOT, $PORT) = @ARGV;

### run the server
__PACKAGE__->run;
exit;

###----------------------------------------------------------------###

### set up some server parameters
sub configure_hook {
  my $self = shift;

  my $root = $self->{server_root} = $SERVER_ROOT;

  $self->{server}->{port}     = "*:$PORT";   # port and addr to bind
  # running as nobody will make all tests to fail when running as root and in /root (access denied -> 404)
  if (getcwd() !~ m!^/root/!) {
      $self->{server}->{user}     = 'nobody'; # user to run as
      $self->{server}->{group}    = 'nogroup' if -e '/etc/mageia-release'; # group to run as
  }
  $self->{server}->{log_file} = "$root/server.log";


  $self->{document_root} = $DOCUMENT_ROOT;
  $self->{access_log}    = "$root/access.log";
  $self->{error_log}     = "$root/error.log";

  $self->{default_index} = [ qw(index.html index.htm main.htm) ];

  $self->{mime_types} = {
    html => 'text/html',
    htm  => 'text/html',
    gif  => 'image/gif',
    jpg  => 'image/jpeg',
  };
  $self->{mime_default} = 'text/plain';

}

sub post_configure_hook {
  my $self = shift;

  open(STDERR, ">>". $self->{error_log})  || die "Couldn't open STDERR: $!";
  open(ACCESS, ">>". $self->{access_log}) || die "Couldn't open ACCESS: $!";
  my $old = select ACCESS;
  $| = 1;
  select STDERR;
  $| = 1;
  select $old;
}


### process the request
sub process_request {
  my $self = shift;

  local %ENV = ();
  local $self->{needs_header} = 1;

  ### read the first line of response
  my $line = <STDIN> || return $self->error(400, "No Data");
  $line =~ s/[\r\n]+$//;
  if ($line !~ /^ (\w+) \ + (\S+) \ + (HTTP\/[01].\d) $ /x) {
    return $self->error(400, "Bad request $line");
  }
  my ($method, $req, $protocol) = ($1, $2, $3);
  print ACCESS join(" ", time, $method, $req)."\n";

  ### read in other headers
  $self->read_headers || return $self->error(400, "Strange headers");

  ### do we support the type
  if ($method !~ /GET|POST|HEAD/) {
    return $self->error(400, "Unsupported Method");
  }
  $ENV{REQUEST_METHOD} = $method;

  ### can we read that request
  if ($req !~ m|^ (?:http://[^/]+)? (.*) $|x) {
    return $self->error(400, "Malformed URL");
  }
  $ENV{REQUEST_URI} = $1;

  ### parse out the uri and query string
  my $uri = '';
  $ENV{QUERY_STRING} = '';
  if ($ENV{REQUEST_URI} =~ m|^ ([^\?]+) (?:\?(.+))? $|x) {
    $ENV{QUERY_STRING} = defined($2) ? $2 : '';
    $uri = $1;
  }

  ### clean up uri
  if ($uri =~ /[\ \;]/) {
    return $self->error(400, "Malformed URL");
  }
  $uri =~ s/%(\w\w)/chr(hex($1))/eg;
  1 while $uri =~ s|^\.\./+||; # can't go below doc root


  ### at this point the uri should be ready to use
  $uri = "$self->{document_root}$uri";

  ### see if there's an index page
  if (-d $uri) {
    foreach (@{ $self->{default_index} }){
      if (-e "$uri/$_") {
        $uri = "$uri/$_";
        last;
      }
    }
  }

  ### error 404
  if (! -e $uri) {
    return $self->error(404, "file not found");

  ### directory listing
  } elsif (-d $uri) {
    ### need work on this
    print $self->content_type('text/html'),"\r\n";
    print "Directory listing not supported";

  }

  ### spit it out
  open(my $fh, "<$uri") || return $self->error(500, "Can't open file [$!]");

  my ($type) = $uri =~ /([^\.]+)$/;
  $type = $self->{mime_types}->{$type} || $self->{mime_default};

  print $self->status(200), $self->content_type($type), "\r\n";

  print STDOUT $_ while read $fh, $_, 8192;
  close $fh;

}

sub read_headers {
  my $self = shift;

  $self->{headers} = {};

  while (defined($_ = <STDIN>)) {
    s/[\r\n]+$//;
    last unless length $_;
    return 0 if ! /^ ([\w\-]+) :[\ \t]+ (.+) $/x;
    my $key = "HTTP_" . uc($1);
    $key =~ tr/-/_/;
    $self->{headers}->{$key} = $2;
  }

  return 1;
}

sub content_type {
  my ($self, $type) = @_;
  $self->http_header;
  return "Content-type: $type\r\n";
}

sub fatal_hook  {
  my ($self, $msg, $pkg, $file, $number, ) = @_;
  # error message, the package, file, and line number.
  print $self->status($number, $msg), "\r\n";
  warn "Error - msg='$msg', pkg='$pkg', file='$file', nb='$number'\n";
  return;
}

sub error{
  my ($self, $number, $msg) = @_;
  print $self->status($number, $msg), "\r\n";
  warn "Error - $number - $msg\n";
}

sub status {
  my ($self, $number, $msg) = @_;
  $msg = '' if ! defined $msg;
  return if $self->http_header($number);
  return "Status $number: $msg\r\n";
}

sub http_header {
  my $self = shift;
  my $number = shift || 200;
  return if ! delete $self->{needs_header};
  print "HTTP/1.0 $number\r\n";
  return 1;
}

1;