Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: eede14b552
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 394 lines (336 sloc) 12.29 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393
# 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 $.req_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) {
    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, but Rakudo and netcat end the session after every request.
class HTTP::Daemon::ClientConn {
    has HTTP::Request $.request is rw;
    has Bool $!gave_request;
    has $.socket;
    
    method get_request {
        if defined $!gave_request { return undef; }
        else {
            $!gave_request = Bool::True;
            my $buf = $.socket.recv();
            say $buf;
            my @lines = split("\x0D\x0A", $buf);
            my Str $line = @lines.shift();
            my @fields = $line.split(' ');
            # $*ERR.say: "-------------------";
            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 ),
                req_method => @fields[0],
                query => %query,
            );
        }
    }

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

    # the method servers should mainly use for normal page output
    method send_response( $self: 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: ) { $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\n"); }

    # 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( $self: Str $filename ) {
        $self.send_basic_header;
        $self.send_crlf;
        $self.send_file( $filename );
    }

    # now tested with /favicon.ico
    method send_file( Str $filename ) {
        my $contents = slurp( $filename );
        $.socket.send($contents);
        $.socket.close();
    }

    # not sure whether this and the next method might be inefficient
    multi method send_error( Int $status ) {
        my %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 = (
            '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 $.host;
    has Int $.port;
    has Bool $!running;
    has Bool $!accepted;

    method daemon {
        $!running = Bool::True;

        # hack until we can get real CALLER support
        my %callerns := Q:PIR {{ $P0 = getinterp
                %r = $P0['namespace';1] }};

        my $listener = IO::Socket::INET.socket(2, 1, 6)\
                                       .bind($.host, $.port)\
                                       .listen();
        while $!running {
            my $work = $listener.accept();
            my HTTP::Daemon::ClientConn $c .= new( :socket($work) );

            # call request($c) in the caller's namespace
            %callerns<request>($c);
        }
    }

    # Where to find this server - used for messages, logs, hyperlinks
    method url { return "http://{$.host}:{$.port}/"; }

    # accept() waits for a browser connection and request and then
    # returns. Because netcat exits after a single receive + transmit,
    # this routine is different than the normal endless loop. It sets a
    # flag when it has returned one client connection and always returns
    # undef when called a second time, because by then the netcat client
    # connection will be gone.
    # This is also why netcat/socat cannot do HTTP 1.1 chunked transfer.
    method accept {
        if defined $!accepted { return undef; }
        else {
            $!accepted = Bool::True;
            my HTTP::Daemon::ClientConn $clientconn .= new;
            return $clientconn;
        }
    }
}

=begin pod

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

=head1 SYNOPSIS

 git clone git://github.com/eric256/perl6-examples.git
 cd perl6-examples/lib/HTTP
 perl6 Configure
 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;
defined @*ARGS[0] && @*ARGS[0] eq '--request' ?? request() !! daemon();

# handle a single browser request, executed in a child process of netcat
sub request {
    my HTTP::Daemon $d .= new;
    while my HTTP::Daemon::ClientConn $c = $d.accept {
        while my HTTP::Request $r = $c.get_request {
            if $r.req_method eq 'GET' {
                given $r.url.path {
                    when '/' { root_dir( $c, $r ); }
                    when / ^ \/pub\/ $ / { pub_dir( $c, $r ); }
                }
            }
            else {
                $c.send_error('RC_FORBIDDEN');
            }
        }
    }
}

# start the main server and enter the endless loop in the inner daemon.
sub daemon {
    my HTTP::Daemon $d .= new( host=>'127.0.0.1', port=>2080 );
    say "Browse this Perl 6 web server at {$d.url}";
    $d.daemon();
}

# called from sub request for the '/' url
sub root_dir( HTTP::Daemon::ClientConn $c, HTTP::Request $r ) {
    my $content = q[<html><head><title>Hello</title>
<body><h1>Rakudo web server</h1>
Hello, world! This is root. Go to <a href="/pub/">pub</a>.
</body></html>];
    $c.send_response( $content );
}

# called from sub request for the '/pub/' url
sub pub_dir( HTTP::Daemon::ClientConn $c, HTTP::Request $r ) {
    my $content = q[<html><head><title>Hello</title>
<body><h1>Rakudo web server</h1>
Hello again, this is pub. Go <a href="/">Home</a>.
</body></html>];
    $c.send_response( $content );
}
=end code

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

use v6;
use HTTP::Daemon;
defined @*ARGS[0] && @*ARGS[0] eq '--request' ?? request() !! daemon();

sub request {
    my HTTP::Daemon $d .= new;
    while my HTTP::Daemon::ClientConn $c = $d.accept {
        while my HTTP::Request $r = $c.get_request {
            if $r.req_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');
            }
        }
    }
}

sub daemon {
    my HTTP::Daemon $d .= new( host=>'127.0.0.1', port=>2080 );
    say "Browse this Perl 6 web server at {$d.url}";
    $d.daemon();
}
=end code

=head1 DEPENDENCIES
The Daemon start a subprocess with C<perl6> so the Rakudo C<perl6> fake
executable must be in a search path directory, or symbolically linked to
one. For example, in Linux:

 sudo ln -s -f /path/to/rakudo/perl6 /usr/local/bin/
 perl6 -v # just checking that perl6 is now in the search path

Temporarily (see L<#TODO>) HTTP::Daemon depends on the L<man:socat>
utility to receive and send on a TCP port.
On Debian based Linux distributions, this should set it up:

 sudo apt-get install socat

On BSD systems including OSX:

 sudo port install socat

=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.

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

L<socat|http://www.dest-unreach.org/socat/> provides the Sockets that
Parrot and Rakudo lack.
Its predecessor L<man:netcat(1)> was called the TCP/IP swiss army knife.

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

Something went wrong with that request. Please try again.