# This lib/HTTP/Daemon file contains definitions for HTTP::Daemon,
# HTTP::Daemon::ClientConn, HTTP::Request and HTTP::Response.
# Normally each class would be in a separate file, they were combined
# here for convenience.

# only a subset emulation of the Perl 5 HTTP::Headers design - no tuits!

class HTTP::Headers {
    has %!header_values;
    method header( Str $fieldname ) {
        return %!header_values{ $fieldname };
    }
    method header_field_names {
        return %!header_values.keys;
    }
}

class HTTP::url {
    has $.path;
}

class HTTP::Request {
    has HTTP::Headers $!headers;
    has HTTP::url     $!req_url;
    has Str           $.uurl;
    has Str           $.request_method  is rw;
    has Str           %.query is rw;

    method url {
        return $!req_url;
    }
    method header( Str $fieldname ) {
        return $!headers.header( $fieldname );
    }
    method header_field_names {
        return $!headers.header_field_names;
    }
}

class HTTP::Response {
}

sub urldecode($text) {
    my %hex;
#   state %hex;
    unless %hex {
        for 0..255 {
            my $h = $_.fmt('%02X');
            %hex{lc $h} = chr $_;
            %hex{uc $h} = chr $_;
        }
    }
    return $text.subst('+', ' ', :g).subst(/\%(<[0..9a..fA..F]>**{2})/, {%hex{$/[0]}}, :g);
}

# This maintains the connected TCP session and handles chunked data transfer.
class HTTP::Daemon::ClientConn {
    has HTTP::Request $.request is rw;
    has Bool $!gave_request;
    has $.socket;
    
    method get_request {
        if defined $!gave_request { return Mu; }
        else {
            $!gave_request = Bool::True;
            my $buf = $.socket.recv();
            my @lines = split("\x0D\x0A", $buf);
            my Str $line = @lines.shift();
            my @fields = $line.split(' ');
            my Str $headerline;
            my %headers;
            repeat {
                $headerline = @lines.shift();
                # $*ERR.say: "HEADERLINE: $headerline";
                # if $headerline ~~ HTTP::headerline {
                #     my $key   = $/<key>;
                #     my $value = $/<value>;
                #     $*ERR.say: "MATCHED! KEY '$key'  VALUE '$value'";
                # }
                # sorry, below isn't perlish, but above is broken
                my $index = $headerline.index(':');
                if $index {
                    my $key   = $headerline.substr( 0, $index );
                    my $value = $headerline.substr( $index + 2 );
                    %headers{$key} = $value;
                }
            } until $headerline eq ""; # blank line terminates
            # deal with body
            my %query;
            given %headers<Content-Type> // '' {
                when 'application/x-www-form-urlencoded' {
                    my $body = @lines.join('');
                    for $body.split(/<[&;]>/) -> $pair {
                        $pair ~~ /$<name>=(.*)\=$<value>=(.*)/ or next;
                        %query{urldecode($/<name>)} = urldecode($/<value>);
                    }
                }
                when '' {
                    # no content-type... not a problem
                }
                when * {
                    warn 'unknown content-type in request';
                }
            }
            return HTTP::Request.new(
                req_url => HTTP::url.new( path=>@fields[1] ),
                headers => HTTP::Headers.new(
                               header_values => %headers ),
                request_method => @fields[0],
                query   => %query,
            );
        }
    }

    method close {
        $.socket.close();
    }

    # the method servers should mainly use for normal page output
    method send_response( Str $content ) {
        self.send_basic_header;
        self.send_crlf;
        $.socket.send($content);
        $.socket.close();
    }

    # provided for Perl 5 compatibility, send_response calls this
    method send_basic_header() { self.send_status_line; }

    # normally not called directly, send_basic_header calls this
    multi method send_status_line(
        Int $status?   = 200,
        Str $message?  = 'OK',
        Str $protocol? = 'HTTP/1.0'
    ) {
        $.socket.send("$protocol $status $message");
        self.send_crlf;
    }

    # the internet newline is 0x0D 0x0A, "\n" would vary between OSes
    method send_crlf { $.socket.send("\x0D\x0A"); }

    # now tested with /favicon.ico
    method send_file_response( Str $filename ) {
        self.send_basic_header;
        self.send_crlf;
        self.send_file( $filename );
    }

    # now tested with /favicon.ico
    method send_file( Str $filename ) {
        my $file = open( $filename, :bin<True> );
        my $contents = $file.read( 1000000 );
        $file.close;
#       my $contents = slurp( $filename, :bin<True> );
        $.socket.send($contents);
        $.socket.close();
    }

    # not sure whether this and the next method might be inefficient
    multi method send_error( Int $status ) {
        my %message = (
#       state %message = (
            200 => 'OK',
            403 => 'RC_FORBIDDEN',
            404 => 'RC_NOTFOUND',
            500 => 'RC_INTERNALERROR',
            501 => 'RC_NOTIMPLEMENTED'
        );
        self.send_error( $status, %message{$status} );
    }

    # seems inefficient
    multi method send_error( Str $message ) {
        my %status = (
#       state %status = (
            'OK'                => 200,
            'RC_FORBIDDEN'      => 403,
            'RC_NOTFOUND'       => 404,
            'RC_INTERNALERROR'  => 500,
            'RC_NOTIMPLEMENTED' => 501
        );
        self.send_error( %status{$message}, $message );
    }

    multi method send_error( Int $status, Str $message ) {
        self.send_status_line( $status, $message );
        self.send_crlf;
        $.socket.send("<title>$status $message</title>");
        $.socket.send("<h1>$status $message</h1>");
        $.socket.close();
    }

    method send_headers(*%headers) {
        for %headers.kv -> $k, $v {
            $.socket.send("$k: $v");
            self.send_crlf;
        }
    }
}

grammar HTTP::headerline {
    regex TOP { <key> ':' <.sp>* <value> }
    regex key { \S+ }
    regex value { .+ } # or should that be .* to allow an "empty" value?
}

class HTTP::Daemon
{
    has Str $.url;
    has IO::Socket::INET $!listener;

    method new ( :$LocalAddr = 'localhost', :$LocalPort = 8888 ) {
        self.bless( self.CREATE(),
            listener => IO::Socket::INET.socket(2, 1, 6)\
                                        .bind($LocalAddr, $LocalPort)\
                                        .listen(),
            url => "http://{$LocalAddr}:{$LocalPort}/"
#           url => "http://$LocalAddr:$LocalPort/"
        );
    }

    method accept {
        my $work = $!listener.accept();
        my HTTP::Daemon::ClientConn $c .= new( :socket($work) );
        return $c;
    }
}

=begin pod

=head1 NAME
HTTP::Daemon - a (very) simple web server using Rakudo Perl 6

=head1 SYNOPSIS

 # Clone/build HTTP::Daemon using proto
 ./proto install http-daemon
 cd ../http-daemon

 # Clone/build HTTP::Daemon manually
 git clone git://gitorious.org/http-daemon/mainline.git http-daemon
 cd http-daemon

 # Start a daemon on localhost at the default port
 perl6 Configure.pl
 make help
 make LOCALADDR=127.0.0.1 run

=head1 DESCRIPTION
You can make your own web server using L<doc:HTTP::Daemon> without using
Apache, IIS or any kind of mod_perl. You control (almost) everything the
web server does, let modules do the low level work and concentrate on
functional design. If your site is fairly code intensive, this solution
might be more efficient than sending all your data through another
server process.

Why bother when Apache is so popular? Think embedded web server, or
maybe an application web front end, or web services. Custom stuff.

This module shows how easily you can write a simple web server. Beware
though, writing an advanced web server is hard and might result in
Internet security breaches.

=head1 EXAMPLES
=head2 Small but working
=begin code
#!/usr/local/bin/perl6
use HTTP::Daemon;

my HTTP::Daemon $d .= new;
say "see {$d.url}";
while my HTTP::Daemon::ClientConn $c = $d.accept {
    while my HTTP::Request $r = $c.get_request {
        if $r.method eq 'GET' {
            given $r.url.path {
                when '/' {
                    $c.send_response( '<html><body>This is root.<br/>' ~
                        'Go to <a href="pub">pub</a></body></html>' ); }
                when '/pub' {
                    $c.send_response( '<html><body>This is pub.<br/>' ~
                        'Go to <a href="/">root</a></body></html>' ); }
                default {
                    $c.send_error('RC_NOTFOUND'); }
            }
        }
        else {
            $c.send_error('RC_FORBIDDEN');
        }
        warn "{$r.method} {$r.url.path}";
    }
}
=end code

=head2 Perl 5 HTTP::Daemon example converted to Perl 6
=begin code
#!/usr/local/bin/perl6

use v6;
use HTTP::Daemon;

my HTTP::Daemon $d .= new;
say "Please contact me at: <URL:{$d.url}>";
while my $c = $d.accept {
    while my $r = $c.get_request {
        if $r.method eq 'GET' and $r.url.path eq "/xyzzy" {
            # remember, this is *not* recommended practice :-)
            $c.send_file_response( '/etc/passwd' );
        }
        else {
            $c.send_error('RC_FORBIDDEN');
        }
    }
    $c.close;
    undefine $c;
}
=end code

=head1 BUGS
This L<doc:HTTP::Daemon> may fail with certain Rakudo revisions, it
worked with the Rakudo of 2009-04-07 and Parrot r37973; more recently
Rakudo of 2009-05-29 and Parrot r39224 were also found to work.

=head1 SEE ALSO
The Makefile comments describe additional testing options.

HTTP 1.1 (L<http://www.ietf.org/rfc/rfc2616.txt>) describes all methods
and status codes.

=head1 AUTHOR
Martin Berends (mberends on CPAN github #perl6 and @autoexec.demon.nl).

=end pod
