head

A simple imperative web framework. Similar to Opium (OCaml) and Express (JavaScript).
Humming-Bird aims to provide a simple, straight-forward HTTP Application server.
Humming-Bird is not designed to be exposed to the world-wide web without a reverse proxy,
I recommend NGiNX. This is why TLS is not implemented.


code

post('/users', -> $request, $response {
  my $text = sprintf("Hello: %s", $request.body);
  $response.write($text); # Content type defaults to text/plain
});


Register an HTTP route, and a C<Block> that takes a Request and a Response.
It is expected that the route handler returns a valid C<Response>, in this case C<.html> returns
the response object for easy chaining. There is no built in body parsers, so you'll have to
convert bodies with another library, JSON::Fast is a good option for JSON!


&get.assuming('/other', -> $request, $response {
    $response.html('Other');
})
], [ &m_logger, &my_middleware ]);


Group registers multiple routes functionally via partial application. This allows you to
group as many different routes together and feed them a C<List> of middleware in the last parameter.
Group takes a C<List> of route functions partially applied to their route and callback, then a C<List>
of middleware to apply to the routes.


Start the server, after you've declared your routes. It will listen in a given port.


Returns a read-only version of the currently stored routes.


Simply an ENUM that contains the major HTTP methods allowed by Humming-Bird.



use v6.d;
use strict;

use HTTP::Status;
use DateTime::Format::RFC2822;

use Humming-Bird::HTTPServer;

unit module Humming-Bird::Core;

our constant $VERSION = '2.0.0';

### UTILITIES
sub trim-utc-for-gmt(Str:D $utc --> Str) { $utc.subst(/"+0000"/, 'GMT') }
sub now-rfc2822(--> Str) {
    trim-utc-for-gmt: DateTime.now(formatter => DateTime::Format::RFC2822.new()).utc.Str;
}

### REQUEST/RESPONSE SECTION
enum HTTPMethod is export <GET POST PUT PATCH DELETE HEAD>;

# Convert a string to HTTP method, defaults to GET
sub http_method_of_str(Str:D $method --> HTTPMethod) {
    given $method.lc {
        when 'get' { GET; }
        when 'post' { POST; }
        when 'put' { PUT; }
        when 'patch' { PATCH; }
        when 'delete' { DELETE; }
        when 'head' { HEAD; }
        default { GET; }
    }
}

# Converts a string of headers "KEY: VALUE\r\nKEY: VALUE\r\n..." to a map of headers.
sub decode_headers(Str:D $header_block --> Map) {
    Map.new($header_block.lines.map({ .split(": ", :skip-empty) }).flat);
}

subset SameSite of Str where 'Strict' | 'Lax';

class Cookie is export {
    has Str $.name;
    has Str $.value;
    has DateTime $.expires;
    has Str $.domain;
    has Str $.path where { .starts-with('/') orelse .throw } = '/';
    has SameSite $.same-site = 'Strict';
    has Bool $.http-only = True;
    has Bool $.secure = False;

    method decode(--> Str) {
        my $expires = ~trim-utc-for-gmt($.expires.clone(formatter => DateTime::Format::RFC2822.new()).utc.Str);
        ("$.name=$.value", "Expires=$expires", "SameSite=$.same-site", "Path=$.path", $.http-only ?? 'HttpOnly' !! '', $.secure ?? 'Secure' !! '', $.domain // '')
        .grep({ .chars })
        .join('; ');
    }

    submethod encode(Str:D $cookie-string) { # We encode "simple" cookies only, since they come from the requests
        Map.new: $cookie-string
                    .split(/\s/, :skip-empty)
                    .map(*.split('=', :skip-empty))
                    .map(-> ($name, $value) { $name => Cookie.new(:$name, :$value) })
                    .flat;
    }
}

class HTTPAction {
    has %.headers is Hash;
    has %.cookies is Hash;
    has Str $.body is rw = "";

    # Find a header in the action, return (Any) if not found
    method header(Str:D $name --> Str) {
        return Nil without %.headers{$name};
        %.headers{$name};
    }

    method cookie(Str:D $name) {
        return Nil without %.cookies{$name};
        %.cookies{$name};
    }
}

class Request is HTTPAction is export {
    has Str $.path is required;
    has HTTPMethod $.method is required;
    has Str $.version is required;
    has %.params;
    has %.query;

    method param(Str:D $param --> Str) {
        return Nil without %!params{$param};
        %!params{$param};
    }

    method query(Str:D $query_param --> Str) {
        return Nil without %!query{$query_param};
        %!query{$query_param};
    }

    submethod encode(Str:D $raw-request --> Request) {
        # TODO: Get a better appromixmation or find smallest possible HTTP request size and short circuit if it's smaller
        # Example: GET /hello.html HTTP/1.1\r\n ~~~ Followed my some headers
        my @lines = $raw-request.lines;
        my ($method_raw, $path, $version) = @lines.head.split(' ');

        my $method = http_method_of_str($method_raw);

        # Find query params
        my %query is Hash;
        if @lines[0] ~~ m:g /<[a..z A..Z 0..9]>+"="<[a..z A..Z 0..9]>+/ {
            %query = Map.new($<>.map({ .split('=') }).flat);
            $path = $path.split('?', :skip-empty)[0];
        }

        # Break the request into the body portion, and the upper headers/request line portion
        my @split_request = $raw-request.split("\r\n\r\n", :skip-empty);
        my $body = "";

        # Lose the request line and parse an assoc list of headers.
        my %headers = Map.new(@split_request[0].split("\r\n").tail(*-1).map(*.split(': ', :skip-empty)).flat);

        # Body should only exist if either of these headers are present.
        with %headers<Content-Length> || %headers<Transfer-Encoding> {
            $body = @split_request[1] || $body;
        }

        # Absolute uris need their path encoded differently.
        without %headers<Host> {
            my $abs-uri = $path;
            $path = $abs-uri.match(/^'http' 's'? '://' <[A..Z a..z \w \. \- \_ 0..9]>+ <('/'.*)>? $/).Str;
            %headers<Host> = $abs-uri.match(/^'http''s'?'://'(<-[/]>+)'/'?.* $/)[0].Str;
        }

        my %cookies;
        # Parse cookies
        with %headers<Cookie> {
            %cookies := Cookie.encode(%headers<Cookie>);
        }

        Request.new(:$path, :$method, :$version, :%query, :$body, :%headers, :%cookies);
    }
}

class Response is HTTPAction is export {
    has HTTP::Status $.status is required;

    proto method cookie(|) {*}
    multi method cookie(Str:D $name, Cookie:D $value) {
        %.cookies{$name} = $value;
        self;
    }
    multi method cookie(Str:D $name, Str:D $value, DateTime:D $expires) {
        # Default
        my $cookie = Cookie.new(:$name, :$value, :$expires);
        %.cookies{$name} = $cookie;
        self;
    }

    proto method status(|) {*}
    multi method status(--> HTTP::Status) { $!status }
    multi method status(Int:D $status --> Response) {
        $!status = HTTP::Status($status);
        self;
    }

    # Redirect to a given URI, :$permanent allows for a 308 status code vs a 307
    method redirect(Str:D $to, :$permanent) {
        %.headers<Location> = $to;
        self.status(307) without $permanent;
        self.status(308) with $permanent;
        self;
    }

    method html(Str:D $body --> Response) {
        $.write($body, 'text/html');
    }

    # Write a JSON string to the body of the request
    method json(Str:D $body --> Response) {
        $.write($body, 'application/json');
    }

    # Set a file to output.
    method file(Str:D $file --> Response) {
        $.write($file.IO.slurp || '', 'text/plain'); # TODO: Infer type of output based on file extension
    }

    # Write a string to the body of the response, optionally provide a content type
    method write(Str:D $body, Str:D $content_type = 'text/plain', --> Response) {
        $.body = $body;
        %.headers{'Content-Type'} = $content_type;
        self;
    }

    # Set content type of the response
    method content-type(Str:D $type --> Response) {
        %.headers{'Content-Type'} = $type;
        self;
    }

    # $with_body is for HEAD requests.
    method decode(Bool:D $with_body = True --> Str) {
        my $out = sprintf("HTTP/1.1 %d $!status\r\n", $!status.code);

        $out ~= sprintf("Content-Length: %d\r\n", $.body.chars);
        $out ~= sprintf("Date: %s\r\n", now-rfc2822);
        $out ~= "X-Server: Humming-Bird v$VERSION\r\n";

        for %.headers.pairs {
            $out ~= sprintf("%s: %s\r\n", .key, .value);
        }

        for %.cookies.values {
            $out ~= sprintf("Set-Cookie: %s\r\n", .decode);
        }

        $out ~= "\r\n";
        $out ~= "$.body" if $with_body;

        $out;
    }
}

### ROUTING SECTION
my constant $PARAM_IDX = ':';

class Route is Callable {
    has Str $.path;
    has &.callback;
    has @.middlewares; # List of functions that type Request --> Request

    method CALL-ME(Request:D $req) {
        my $res = Response.new(status => HTTP::Status(200));
        if @!middlewares.elems {
            state &composition = @!middlewares.map({ .assuming($req, $res) }).reduce(-> &a, &b { &a(-> { &b }) });
            # Finally, the main callback is added to the end of the chain
            &composition(&!callback.assuming($req, $res));
        } else {
            # If there is are no middlewares, just process the callback
            &!callback($req, $res);
        }
    }
}

our %ROUTES; # TODO: Should be un-modifiable after listen is called.
our @ADVICE = [{ $^a }];
our %ERROR;

sub split_uri(Str:D $uri --> List:D) {
    my @uri_parts = $uri.split('/', :skip-empty);
    @uri_parts.prepend('/').List;
}

sub delegate_route(Route:D $route, HTTPMethod:D $meth) {
    die 'Route cannot be empty' unless $route.path;
    die "Invalid route: { $route.path }" unless $route.path.contains('/');

    my @uri_parts = split_uri($route.path);

    my %loc := %ROUTES;
    for @uri_parts -> Str $part {
        unless %loc{$part}:exists {
            %loc{$part} = Hash.new;
        }

        %loc := %loc{$part};
    }

    %loc{$meth} := $route;
    $route; # Return the route.
}

# TODO: Implement a way for the user to declare their own error handlers (maybe somekind of after middleware?)
my constant $NOT-FOUND          = Response.new(status => HTTP::Status(404)).html('404 Not Found');
my constant $METHOD-NOT-ALLOWED = Response.new(status => HTTP::Status(405)).html('405 Method Not Allowed');
my constant $BAD-REQUEST        = Response.new(status => HTTP::Status(400)).html('400 Bad request');
my constant $SERVER-ERROR       = Response.new(status => HTTP::Status(500)).html('500 Server Error');

sub dispatch-request(Request $request --> Response) {
    my @uri_parts = split_uri($request.path);
    if (@uri_parts.elems < 1) || (@uri_parts.elems == 1 && @uri_parts[0] ne '/') {
        return $BAD-REQUEST;
    }

    my %loc := %ROUTES;
    for @uri_parts -> $uri {
        my $possible_param = %loc.keys.first: *.starts-with($PARAM_IDX);

        if  %loc{$uri}:!exists && !$possible_param {
            return $NOT-FOUND;
        } elsif $possible_param && !%loc{$uri} {
            $request.params{$possible_param.match(/<[A..Z a..z 0..9 \- \_]>+/).Str} = $uri;
            %loc := %loc{$possible_param};
        } else {
            %loc := %loc{$uri};
        }
    }

    # For HEAD requests we should return a GET request. The decoder will delete the body
    if $request.method === HEAD {
        if %loc{GET}:exists {
            return %loc{GET}($request);
        } else {
            return $METHOD-NOT-ALLOWED;
        }
    }

    # If we don't support the request method on this route.
    without %loc{$request.method} {
        return $METHOD-NOT-ALLOWED;
    }

    my Response $response;
    try {
        # This is how we pass to error handlers.
        CATCH {
            when %ERROR{.^name}:exists { return %ERROR{.^name}($_);  }
            default { return $SERVER-ERROR; }
        }

        $response = %loc{$request.method}($request);
        return $response;
    }
}

sub get(Str $path, &callback, @middlewares = List.new) is export {
    delegate_route(Route.new(:$path, :&callback, :@middlewares), GET);
}

sub put(Str $path, &callback, @middlewares = List.new) is export {
    delegate_route(Route.new(:$path, :&callback, :@middlewares), PUT);
}

sub post(Str $path, &callback, @middlewares = List.new) is export {
    delegate_route(Route.new(:$path, :&callback, :@middlewares), POST);
}

sub patch(Str $path, &callback, @middlewares = List.new) is export {
    delegate_route(Route.new(:$path, :&callback, :@middlewares), PATCH);
}

sub delete(Str $path, &callback, @middlewares = List.new) is export {
    delegate_route(Route.new(:$path, :&callback, :@middlewares), DELETE);
}

sub group(@routes, @middlewares) is export {
    .(@middlewares) for @routes;
}

multi sub advice(--> List:D) is export {
    @ADVICE.clone;
}

multi sub advice(@advice) is export {
    @ADVICE.append: @advice;
}

multi sub advice(&advice) is export {
    @ADVICE.push: &advice;
}

sub error($type, &handler) is export {
    %ERROR{$type.^name} = &handler;
}

sub routes(--> Hash:D) is export {
    %ROUTES.clone;
}

sub handle($raw-request) {
    my Request $request = Request.encode($raw-request);
    my Bool $keep-alive = False;
    my &advice = [o] @ADVICE; # Advice are Response --> Response

    with $request.headers<Connection> {
        $keep-alive = $_.lc eq 'keep-alive';
    }

    # If the request is HEAD, we shouldn't return the body
    my Bool $should-show-body = not ($request.method === HEAD);
    # We need $should_show_body because the Content-Length header should remain on a HEAD request
    return (&advice(dispatch-request($request)).decode($should-show-body), $keep-alive);
}

sub listen(Int:D $port, :$no-block) is export {
    my $server = HTTPServer.new(:$port);
    if $no-block {
        do start {
            $server.listen(&handle);
        }
    } else {
        $server.listen(&handle);
    }
}

# vim: expandtab shiftwidth=4


root

HTTPServer

Advice

React

=begin React :component<HeaderCol> :id<menu> 
=para L<Documentation|/doc/introduction>
=para L<Modules| /mods>
=para L<Examples| file:../examples/index.podlite>
=para L<Download |file:../download/index.podlite>
=para L<About|file:../about/index.podlite>
=para 🔍 K<⌘K>/K<ctrl-K>
=end React


=begin React :component<HeaderCol> :id<footer>  
=begin nested :!nested
=item1 B<Language>
    =item2 L<Get started|file:../getting-started/getting-started.podlite>
    =item2 L<Why Raku?|/doc/language/faq#Why-should-I-learn-Raku-What's-so-great-about-it>
    =item2 L<Try Raku|https://glot.io/new/raku>
    =item2 L<Raku cheat sheet|https://github.com/Raku/mu/blob/master/docs/Perl6/Cheatsheet/cheatsheet.txt>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<Raku on Exercism|https://exercism.org/tracks/raku>
    =item2 L<Wikipedia|https://en.wikipedia.org/wiki/Raku_(programming_language)>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>

=end nested
=begin nested :!nested

=item1 B<L<Documentation|/doc>>
    =item2 L<Getting started, Migration guides from other languages, & Tutorials | file:../doc/introduction.podlite>
    =item2 L<Language References|file:../doc/reference.podlite>
    =item2 L<Type Reference| file:../doc/types.podlite>
    =item2 L<Miscellaneous| file:../doc/miscellaneous.podlite>
    =item2 L<FAQs (Frequently Asked Questions)|/doc/language/faq>
    =item2 L<Community|/doc/language/community>
    =item2 L<The list of all documents|file:../doc/index.podlite>

=item1 B<Resources>
    =item2 L<The Raku Guide|https://raku.guide/>
    =item2 L<Books |https://perl6book.com/>
    =item2 L<Rosetta Code | https://www.raku.org/community/rosettacode>

=end nested
=begin nested :!nested

=item1 B<Resoures>
    =item2 L<Download | file:../download/index.podlite>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>

=item1 B<Learning>
    =item2 L<The Raku Guide|https://raku.guide/>
    =item2 L<Wikibook |https://en.wikibooks.org/wiki/Raku_Programming>
    =item2 L<Books |https://perl6book.com/>
    =item2 L<Rosetta Code | https://www.raku.org/community/rosettacode>
    =item2 L<Learn Raku in Y minutes|https://learnxinyminutes.com/docs/raku/>
    =item2 L<Golfing |https://github.com/AlexDaniel/raku-golf-cheatsheet>
=end nested
=begin nested :!nested

=item1 B<Explore>
    =item2 L<Raku Blog Aggregator|https://planet.raku.org/>
    =item2 L<Rakudo Weekly|https://rakudoweekly.blog/>
    =item2 L<The Weekly Challenge |https://perlweeklychallenge.org/>
    =item2 L<Raku Advent Calendar|https://raku-advent.blog/>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>
    =item2 L<empty|#>

=end nested
=end React


=begin React :component<CookieConsent> :id<CookieConsent> :buttonCaption("Got it!")
=para
This website uses cookies for analytics.
=end React


Core

Humming-Bird::Core

Exported subroutines

get, post, put, patch, delete

group

listen

routes

HTTPMethod

Humming-Bird::Core v2.0.0

Authors

License

Dependencies

Test Dependencies

Provides

Documentation