File Coverage

blib/lib/Limper.pm

Criterion	Covered	Total	%
statement	14	174	8.0
branch	0	94	0.0
condition	0	83	0.0
subroutine	5	34	14.7
pod	18	24	75.0
total	37	409	9.0

package Limper;
$Limper::VERSION = '0.013';
use 5.10.0;
use strict;
use warnings;

use IO::Socket;

use Exporter qw/import/;
our @EXPORT = qw/get post put del trace options patch any status headers request response config hook limp/;
our @EXPORT_OK = qw/info warning rfc1123date/;

# data stored here
my $request = {};
my $response = {};
my $config = {};
my $hook = {};
my $conn;

# route subs
my $route = {};
sub get     { push @{$route->{GET}},     @_; @_ }
sub post    { push @{$route->{POST}},    @_; @_ }
sub put     { push @{$route->{PUT}},     @_; @_ }
sub del     { push @{$route->{DELETE}},  @_; @_ }
sub trace   { push @{$route->{TRACE}},   @_; @_ }
sub options { push @{$route->{OPTIONS}}, @_; @_ }
sub patch   { push @{$route->{PATCH}},   @_; @_ }
sub any     { push @{$route->{$_}},      @_ for keys %$route }

# for send_response()
my $reasons = {
    100 => 'Continue',
    101 => 'Switching Protocols',
    200 => 'OK',
    201 => 'Created',
    202 => 'Accepted',
    203 => 'Non-Authoritative Information',
    204 => 'No Content',
    205 => 'Reset Content',
    206 => 'Partial Content',
    300 => 'Multiple Choices',
    301 => 'Moved Permanently',
    302 => 'Found',
    303 => 'See Other',
    304 => 'Not Modified',
    305 => 'Use Proxy',
    307 => 'Temporary Redirect',
    400 => 'Bad Request',
    401 => 'Unauthorized',
    402 => 'Payment Required',
    403 => 'Forbidden',
    404 => 'Not Found',
    405 => 'Method Not Allowed',
    406 => 'Not Acceptable',
    407 => 'Proxy Authentication Required',
    408 => 'Request Time-out',
    409 => 'Conflict',
    410 => 'Gone',
    411 => 'Length Required',
    412 => 'Precondition Failed',
    413 => 'Request Entity Too Large',
    414 => 'Request-URI Too Large',
    415 => 'Unsupported Media Type',
    416 => 'Requested range not satisfiable',
    417 => 'Expectation Failed',
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
    504 => 'Gateway Time-out',
    505 => 'HTTP Version not supported',
};

# for get_request()
my $method_rx = qr/(?: OPTIONS | GET | HEAD | POST | PUT | DELETE | TRACE | CONNECT )/x;
my $version_rx = qr{HTTP/\d+\.\d+};
my $uri_rx = qr/[^ ]+/;

# Returns current time or passed timestamp as an HTTP 1.1 date
my @months = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
my @days = qw/Sun Mon Tue Wed Thu Fri Sat/;
sub rfc1123date {
    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = @_ ? gmtime $_[0] : gmtime;
    sprintf '%s, %02d %s %4d %02d:%02d:%02d GMT', $days[$wday], $mday, $months[$mon], $year + 1900, $hour, $min, $sec;
}

# Formats date like "2014-08-17 00:12:41" in local time.
sub date {
    my ($sec, $min, $hour, $mday, $mon, $year) = localtime;
    sprintf '%04d-%02d-%02d %02d:%02d:%02d', $year + 1900, $mon, $mday, $hour, $min, $sec;
}

# Trivially log to STDOUT or STDERR
sub info    { say  date, ' ', @_ }
sub warning { warn date, ' ', @_ }

sub timeout {
    eval {
        local $SIG{ALRM} = sub { die "alarm\n" };
        alarm($config->{timeout} // 5);
        $_ = $_[0]->();
        alarm 0;
    };
    $@ ? ($conn->close and undef) : $_;
}

sub bad_request {
    warning "[$request->{remote_host}] bad request: $_[0]";
    $response = { status => 400, body => 'Bad Request' };
    send_response($request->{method} // '' eq 'HEAD', 'close');
}

# Returns a processed request as a hash, or sends a 400 and closes if invalid.
sub get_request {
    $request = { headers => {}, remote_host => $conn->peerhost // 'localhost' };
    $response = { headers => {} };
    my ($request_line, $headers_done, $chunked);
    while (1) {
        defined(my $line = timeout(sub { $conn->getline })) or last;
        if (!defined $request_line) {
            next if $line eq "\r\n";
            ($request->{method}, $request->{uri}, $request->{version}) = $line =~ /^($method_rx) ($uri_rx) ($version_rx)\r\n/;
            return bad_request $line unless defined $request->{method};
            ($request->{scheme}, $request->{authority}, $request->{path}, $request->{query}, $request->{fragment}) =
                    $request->{uri} =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;	# from https://metacpan.org/pod/URI
            $request_line = 1;
        } elsif (!defined $headers_done) {
            if ($line =~ /^\r\n/) {
                $headers_done = 1;
            } else {
                my ($name, $value) = split /:[ \t]*/, $line, 2;
                if ($name =~ /\r\n/) {
                    return bad_request $line;
                }
                $value =~ s/\r\n//;
                $value = $1 if lc $name eq 'host' and $request->{version} eq 'HTTP/1.1' and $request->{uri} =~ s{^https?://(.+?)/}{/};
                if (exists $request->{headers}{lc $name}) {
                    if (ref $request->{headers}{lc $name}) {
                        push @{$request->{headers}{lc $name}}, $value;
                    } else {
                        $request->{headers}{lc $name} = [$request->{headers}{lc $name}, $value];
                    }
                } else {
                    $request->{headers}{lc $name} = $value;
                }
            }
        }
        if (defined $headers_done) {
            return if defined $chunked;
            info "[$request->{remote_host}] $request->{method} $request->{uri} $request->{version} [", $request->{headers}{'user-agent'} // '', ']';
            return bad_request 'Host header missing' if $request->{version} eq 'HTTP/1.1' and (!exists $request->{headers}{host} or ref $request->{headers}{host});
            for (keys %{$request->{headers}}) {
                if ($_ eq 'expect' and lc $request->{headers}{$_} eq '100-continue' and $request->{version} eq 'HTTP/1.1') {
                    $conn->print("HTTP/1.1 100 Continue\r\n\r\n");	# this does not check if route is valid. just here to comply.
                } elsif ($_ eq 'content-length') {
                    timeout(sub { $conn->read($request->{body}, $request->{headers}{$_}) });
                    last;
                } elsif ($_ eq 'transfer-encoding' and lc $request->{headers}{$_} eq 'chunked') {
                    my $length = my $offset = $chunked = 0;
                    do {
                        $_ = timeout(sub { $conn->getline });
                        $length = hex((/^([A-Fa-f0-9]+)(?:;.*)?\r\n/)[0]);
                        timeout(sub { $conn->read($request->{body}, $length + 2, $offset) }) if $length;
                        $offset += $length;
                    } while $length;
                    $request->{body} =~ s/\r\n$//;
                    undef $headers_done; # to get optional footers, and another blank line
                }
            }
            last if defined $headers_done;
        }
    }
}

# Finds and calls the appropriate route sub, or sends a 404 response.
sub handle_request {
    my $head = 1;
    (defined $request->{method} and $request->{method} eq 'HEAD') ? ($request->{method} = 'GET') : ($head = 0);
    if (defined $request->{method} and exists $route->{$request->{method}}) {
        for (my $i = 0; $i < @{$route->{$request->{method}}}; $i += 2) {
            if ($route->{$request->{method}}[$i] eq $request->{path} ||
                        ref $route->{$request->{method}}[$i] eq 'Regexp' and $request->{path} =~ $route->{$request->{method}}[$i]) {
                $response->{body} = & { $route->{$request->{method}}[$i+1] };
                return send_response($head);
            }
        }
    }
    $response->{body} = 'This is the void';
    $response->{status} = 404;
    send_response($head);
}

# Sends a response to client. Default status is 200.
sub send_response {
    my ($head, $connection) = @_;
    $connection //= (($request->{version} // '') eq 'HTTP/1.1')
            ? lc($request->{headers}{connection} // '')
            : lc($request->{headers}{connection} // 'close') eq 'keep-alive' ? 'keep-alive' : 'close';
    $response->{status} //= 200;
    $response->{headers}{Date} = rfc1123date();
    if (defined $response->{body} and !ref $response->{body}) {
        $response->{headers}{'Content-Length'} //= length $response->{body};
        $response->{headers}{'Content-Type'} //= 'text/plain';
    }
    delete $response->{body} if $head // 0;
    $response->{headers}{Connection} = $connection if $connection eq 'close' or ($connection eq 'keep-alive' and $request->{version} ne 'HTTP/1.1');
    $response->{headers}{Server} = 'limper/' . ($Limper::VERSION // 'pre-release');
    $_->($request, $response) for @{$hook->{after}};
    return $hook->{response_handler}[0]->() if exists $hook->{response_handler};
    {
        local $\ = "\r\n";
        $conn->print(join ' ', $request->{version} // 'HTTP/1.1', $response->{status}, $response->{reason} // $reasons->{$response->{status}});
        return unless $conn->connected;
        my @headers = headers();
        $conn->print( join(': ', splice(@headers, 0, 2)) ) while @headers;
        $conn->print();
    }
    $conn->print($response->{body} // '') if defined $response->{body};
    $conn->close if $connection eq 'close';
}

sub status {
    if (defined wantarray) {
        wantarray ? ($response->{status}, $response->{reason}) : $response->{status};
    } else {
        $response->{status} = shift;
        $response->{reason} = shift if @_;
    }
}

sub headers {
    if (!defined wantarray) {
        $response->{headers}{+pop} = pop while @_;
    } else {
        my @headers;
        for my $key (keys %{ $response->{headers} }) {
            if (ref $response->{headers}{$key}) {
                push @headers, $key, $_ for @{$response->{headers}{$key}};
            } else {
                push @headers, $key, $response->{headers}{$key};
            }
        }
        @headers;
    }
}

sub request { $request }

sub response { $response }

sub config { $config }

sub hook { push @{$hook->{$_[0]}}, $_[1] }

sub limp {
    $config = shift @_ if ref $_[0] eq 'HASH';
    return $hook->{request_handler}[0] if exists $hook->{request_handler};
    my $sock = IO::Socket::INET->new(Listen => SOMAXCONN, ReuseAddr => 1, LocalAddr => 'localhost', LocalPort => 8080, Proto => 'tcp', @_)
            or die "cannot bind to port: $!";

    info 'limper started';

    for (1 .. $config->{workers} // 5) {
        defined(my $pid = fork) or die "fork failed: $!";
        while (!$pid) {
            if ($conn = $sock->accept()) {
                do {
                    eval {
                        get_request;
                        handle_request if $conn->connected;
                    };
                    if ($@) {
                        $response = { status => 500, body => $config->{debug} // 0 ? $@ : 'Internal Server Error' };
                        send_response 0, 'close';
                        warning $@;
                    }
                } while ($conn->connected);
            }
        }
    }
    1 while (wait != -1);

    my $shutdown = $sock->shutdown(2);
    my $closed = $sock->close();
    info 'shutdown ', $shutdown ? 'successful' : 'unsuccessful';
    info 'closed ', $closed ? 'successful' : 'unsuccessful';
}

1;

__END__