diff --git a/META6.json b/META6.json index c133ea4..6bc2a6e 100644 --- a/META6.json +++ b/META6.json @@ -19,9 +19,11 @@ "raku": "6.d", "provides": { "Humming-Bird::Core": "lib/Humming-Bird/Core.rakumod", - "Humming-Bird::HTTPServer": "lib/Humming-Bird/HTTPServer.rakumod", + "Humming-Bird::Backend": "lib/Humming-Bird/Backend.rakumod", + "Humming-Bird::Backend::HTTPServer": "lib/Humming-Bird/Backend/HTTPServer.rakumod", "Humming-Bird::Middleware": "lib/Humming-Bird/Middleware.rakumod", - "Humming-Bird::Advice": "lib/Humming-Bird/Advice.rakumod" + "Humming-Bird::Advice": "lib/Humming-Bird/Advice.rakumod", + "Humming-Bird::Glue": "lib/Humming-Bird/Glue.rakumod" }, "resources": [ ], @@ -42,5 +44,5 @@ "Test::Util::ServerPort", "Cro::HTTP::Client" ], - "version": "2.2.0" + "version": "3.0.0" } diff --git a/README.md b/README.md index b7c1f74..98189e2 100644 --- a/README.md +++ b/README.md @@ -12,8 +12,9 @@ Humming-Bird was inspired mainly by [Sinatra](https://sinatrarb.com), and [Expre things minimal, allowing the user to pull in things like templating engines, and ORM's on their own terms. ## Features -Humming-Bird has 2 simple layers, at its core we have `Humming-Bird::HTTPServer` which handles all of the low-level HTTP bits. Then you have the -routing stack that handles: routing, middleware, error handling, cookies, etc. +Humming-Bird has 2 simple layers, at the lowest levels we have `Humming-Bird::Glue` which is a simple "glue-like" layer for interfacing with +`Humming-Bird::Backend`'s. +Then you have the actual application logic in `Humming-Bird::Core` that handles: routing, middleware, error handling, cookies, etc. - Powerful function composition based routing and application logic - Routers @@ -28,6 +29,8 @@ routing stack that handles: routing, middleware, error handling, cookies, etc. - Static files served have their content type infered - Request/Response stash's for inter-layer route talking +- Swappable backends + **Note**: Humming-Bird is not meant to face the internet directly. Please use a reverse proxy such as httpd or NGiNX. ## How to install @@ -44,9 +47,9 @@ zef install Humming-Bird ``` ## Performance -Around ~20% faster than Ruby's `Sinatra`, and only improving as time goes on! -See [this](https://github.com/rawleyfowler/Humming-Bird/issues/43#issuecomment-1454252501) for a more detailed performance preview. +See [this](https://github.com/rawleyfowler/Humming-Bird/issues/43#issuecomment-1454252501) for a more detailed performance preview +vs. Ruby's Sinatra using `Humming-Bird::Backend::HTTPServer`. ## Examples @@ -151,6 +154,20 @@ get('/no-firefox', -> $request, $response { }, [ &middleware-logger, &block-firefox ]); ``` +#### Swappable Backends +```raku +use v6.d; + +use Humming-Bird::Core; + +get('/, -> $request, $response { + $response.html('This request has been logged!'); +}); + +# Run on a different backend, assuming: +listen(:backend(Humming-Bird::Backend::MyBackend)); +``` + More examples can be found in the [examples](https://github.com/rawleyfowler/Humming-Bird/tree/main/examples) directory. ## Design diff --git a/lib/Humming-Bird/Backend.rakumod b/lib/Humming-Bird/Backend.rakumod new file mode 100644 index 0000000..b998f02 --- /dev/null +++ b/lib/Humming-Bird/Backend.rakumod @@ -0,0 +1,10 @@ +use v6.d; + +unit role Humming-Bird::Backend; + +has Int:D $.port = 8080; +has Int:D $.timeout is required; + +method listen(&handler) { + die "{ self.^name } does not properly implement Humming-Bird::Backend."; +} diff --git a/lib/Humming-Bird/Backend/HTTPServer.rakumod b/lib/Humming-Bird/Backend/HTTPServer.rakumod new file mode 100644 index 0000000..f5dcbed --- /dev/null +++ b/lib/Humming-Bird/Backend/HTTPServer.rakumod @@ -0,0 +1,145 @@ +use v6; + +# This code is based on the excellent code by the Raku community, adapted to work with Humming-Bird. +# https://github.com/raku-community-modules/HTTP-Server-Async + +# A simple, single-threaded asynchronous HTTP Server. + +use Humming-Bird::Backend; +use Humming-Bird::Glue; + +unit class Humming-Bird::Backend::HTTPServer does Humming-Bird::Backend; + +my constant $DEFAULT-RN = "\r\n\r\n".encode.Buf; +my constant $RN = "\r\n".encode.Buf; + +has Channel:D $.requests .= new; +has Lock $!lock .= new; +has @!connections; + +method !timeout { + start { + react { + whenever Supply.interval(1) { + CATCH { default { warn $_ } } + $!lock.protect({ + @!connections = @!connections.grep({ !$_.defined }); # Remove dead connections + for @!connections.grep({ now - $_ >= $!timeout }) { + { + $_ = True; + $_.write(Blob.new); + $_.close; + + CATCH { default { warn $_ } } + } + } + }); + } + } + } +} + +method !respond(&handler) { + start { + react { + whenever $.requests -> $request { + CATCH { default { .say } } + my $hb-request = Humming-Bird::Glue::Request.decode($request.decode); + my Humming-Bird::Glue::Response $response = &handler($hb-request); + $request.write: $response.encode; + $request = True with $hb-request.header('keep-alive'); + } + } + } +} + +method !handle-request($data is rw, $index is rw, $connection) { + my $request = { + :$connection, + data => Buf.new + }; + + my @header-lines = Buf.new($data[0..$index]).decode.lines.tail(*-1).grep({ .chars }); + return unless @header-lines.elems; + + $request ~= $data.subbuf(0, $index); + + my $content-length = $data.elems - $index; + for @header-lines -> $header { + my ($key, $value) = $header.split(': ', 2, :skip-empty); + given $key.lc { + when 'content-length' { + $content-length = +$value // ($data.elems - $index); + } + when 'transfer-encoding' { + if $value.chomp.lc.index('chunked') !~~ Nil { + my Int $i; + my Int $b; + while $i < $data.elems { + $i++ while $data[$i] != $RN[0] + && $data[$i+1] != $RN[1] + && $i + 1 < $data.elems; + + last if $i + 1 >= $data.elems; + + $b = :16($data[0..$i].decode); + last if $data.elems < $i + $b; + if $b == 0 { + try $data .= subbuf(3); + last; + } + + $i += 2; + $request ~= $data.subbuf($i, $i+$b-3); + try $data .= subbuf($i+$b+2); + $i = 0; + } + } + } + } + } + + $request ~= $data.subbuf($index, $content-length+4); + $.requests.send: $request; +} + +method listen(&handler) { + react { + self!timeout; + self!respond(&handler); + + whenever IO::Socket::Async.listen('0.0.0.0', $.port) -> $connection { + my %connection-map := { + socket => $connection, + last-active => now + } + + $!lock.protect({ @!connections.push: %connection-map }); + + whenever $connection.Supply: :bin -> $bytes { + my Buf $data .= new; + my Int:D $idx = 0; + my $req; + + CATCH { default { .say } } + $data ~= $bytes; + %connection-map = now; + while $idx++ < $data.elems - 4 { + # Read up to headers + $idx--, last if $data[$idx] == $DEFAULT-RN[0] + && $data[$idx+1] == $DEFAULT-RN[1] + && $data[$idx+2] == $DEFAULT-RN[2] + && $data[$idx+3] == $DEFAULT-RN[3]; + } + + $idx += 4; + + self!handle-request($data, $idx, %connection-map); + } + + CATCH { default { .say; $connection.close; %connection-map = True } } + } + } +} + +# vim: expandtab shiftwidth=4 diff --git a/lib/Humming-Bird/Core.rakumod b/lib/Humming-Bird/Core.rakumod index f3e13be..99f8ac5 100644 --- a/lib/Humming-Bird/Core.rakumod +++ b/lib/Humming-Bird/Core.rakumod @@ -2,340 +2,12 @@ use v6.d; use strict; use HTTP::Status; -use DateTime::Format::RFC2822; -use MIME::Types; -use URI::Encode; - -use Humming-Bird::HTTPServer; +use Humming-Bird::Backend::HTTPServer; +use Humming-Bird::Glue; unit module Humming-Bird::Core; -our constant $VERSION = '2.2.0'; - -# Mime type parser from MIME::Types -my constant $mime = MIME::Types.new; - -### UTILITIES -sub trim-utc-for-gmt(Str:D $utc --> Str:D) { $utc.subst(/"+0000"/, 'GMT') } -sub now-rfc2822(--> Str:D) { - trim-utc-for-gmt: DateTime.now(formatter => DateTime::Format::RFC2822.new()).utc.Str; -} - -### REQUEST/RESPONSE SECTION -enum HTTPMethod is export ; - -# Convert a string to HTTP method, defaults to GET -sub http-method-of-str(Str:D $method --> HTTPMethod:D) { - 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(@header_block --> Map:D) { - Map.new(@header_block.map(*.trim.split(': ', 2, :skip-empty).map(*.trim)).map({ [@^a[0].lc, @^a[1]] }).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 encode(--> Str:D) { - 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 decode(Str:D $cookie-string) { # We decode "simple" cookies only, since they come from the requests - Map.new: $cookie-string.split(/\s/, 2, :skip-empty) - .map(*.split('=', 2, :skip-empty)) - .map(-> ($name, $value) { $name => Cookie.new(:$name, :$value) }) - .flat; - } -} - -my subset Body where * ~~ Buf:D | Str:D; -class HTTPAction { - has $.context-id; - has %.headers; - has %.cookies; - has %.stash; # The stash is never encoded or decoded. It exists purely for internal talking between middlewares, request handlers, etc. - has Body:D $.body is rw = ""; - - # Find a header in the action, return (Any) if not found - multi method header(Str:D $name --> Str) { - my $lc-name = $name.lc; - return Nil without %.headers{$lc-name}; - %.headers{$lc-name}; - } - - multi method header(Str:D $name, Str:D $value) { - %.headers{$name.lc} = $value; - self; - } - - multi method cookie(Str:D $name --> Cookie) { - return Nil without %.cookies{$name}; - %.cookies{$name}; - } - - method log(Str:D $message, :$file = $*OUT) { - $file.print: "[Context: { self.context-id }] | [Time: { DateTime.now }] | $message\n"; - self; - } -} - -my sub parse-urlencoded(Str:D $urlencoded --> Map:D) { - $urlencoded.split('&', :skip-empty).map(&uri_decode_component)>>.split('=', 2, :skip-empty)>>.map(-> $a, $b { $b.contains(',') ?? slip $a => $b.split(',', :skip-empty) !! slip $a => $b }) - .flat - .Map; -} - -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; - has $!content; - - # Attempts to parse the body to a Map or return an empty map if we can't decode it - method content(--> Map:D) { - use JSON::Fast; - - state $prev-body = $.body; - - return $!content if $!content && ($prev-body eqv $.body); - return $!content = Map.new unless self.header('Content-Type'); - - try { - CATCH { - default { - warn "Encountered Error: $_;\n\n Failed trying to parse a body of type { self.header('Content-Type') }"; return ($!content = Map.new) - } - } - - if self.header('Content-Type').ends-with: 'json' { - $!content = from-json(self.body).Map; - } elsif self.header('Content-Type').ends-with: 'urlencoded' { - $!content = parse-urlencoded(self.body); - } - - return $!content; - } - - $!content = Map.new; - } - - method param(Str:D $param --> Str) { - return Nil without %!params{$param}; - %!params{$param}; - } - - method queries { - return %!query; - } - - multi method query { - return %!query; - } - multi method query(Str:D $query_param --> Str) { - return Nil without %!query{$query_param}; - %!query{$query_param}; - } - - submethod decode(Str:D $raw-request --> Request:D) { - use URI::Encode; - # 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(/\s/, :skip-empty); - - my $method = http-method-of-str($method_raw); - - # Find query params - my %query; - if uri_decode_component($path) ~~ m:g /\w+"="(<-[&]>+)/ { - %query = Map.new($<>.map({ .split('=', 2) }).flat); - $path = $path.split('?', 2)[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", 2, :skip-empty); - my $body = ""; - - # Lose the request line and parse an assoc list of headers. - my %headers = decode-headers(@split_request[0].split("\r\n", :skip-empty).skip(1)); - - # Body should only exist if either of these headers are present. - with %headers || %headers { - $body = @split_request[1] || $body; - } - - # Absolute uris need their path encoded differently. - without %headers { - my $abs-uri = $path; - $path = $abs-uri.match(/^'http' 's'? '://' <[A..Z a..z \w \. \- \_ 0..9]>+ <('/'.*)>? $/).Str; - %headers = $abs-uri.match(/^'http''s'?'://'(<-[/]>+)'/'?.* $/)[0].Str; - } - - my %cookies; - # Parse cookies - with %headers { - %cookies := Cookie.decode(%headers); - } - - my $context-id = rand.Str.subst('0.', '').substr: 0, 5; - - Request.new(:$path, :$method, :$version, :%query, :$body, :%headers, :%cookies, :$context-id); - } -} - -class Response is HTTPAction is export { - has HTTP::Status $.status is required; - has Request:D $.initiator is required handles ; - - 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; - } - multi method cookie(Str:D $name, Str:D $value, :$expires, :$secure) { - my $cookie = Cookie.new(:$name, :$value, :$expires, :$secure); - %.cookies{$name} = $cookie; - self; - } - - proto method status(|) {*} - multi method status(--> HTTP::Status) { $!status } - multi method status(Int:D $status --> Response:D) { - $!status = HTTP::Status($status); - self; - } - multi method status(HTTP::Status:D $status --> Response:D) { - $!status = $status; - self; - } - - # Redirect to a given URI, :$permanent allows for a 308 status code vs a 307 - method redirect(Str:D $to, :$permanent, :$temporary) { - self.header('Location', $to); - self.status(303); - - self.status(307) if $temporary; - self.status(308) if $permanent; - - self; - } - - method html(Str:D $body --> Response:D) { - $.write($body, 'text/html'); - self; - } - - # Write a JSON string to the body of the request - method json(Str:D $body --> Response:D) { - $.write($body, 'application/json'); - self; - } - - # Set a file to output. - method file(Str:D $file --> Response:D) { - my $text = $file.IO.slurp(:bin); - my $mime-type = $mime.type($file.IO.extension) // 'text/plain'; - try { - CATCH { - $mime-type = 'application/octet-stream' if $mime-type eq 'text/plain'; - return $.blob($text, $mime-type); - } - # Decode will fail if it's a binary file - $.write($text.decode, $mime-type); - } - self; - } - - # Write a blob or buffer - method blob(Buf:D $body, Str:D $content-type = 'application/octet-stream', --> Response:D) { - $.body = $body; - self.header('Content-Type', $content-type); - self; - } - # Alias for blob - multi method write(Buf:D $body, Str:D $content-type = 'application/octet-stream', --> Response:D) { - self.blob($body, $content-type); - } - # Write a string to the body of the response, optionally provide a content type - multi method write(Str:D $body, Str:D $content-type = 'text/plain', --> Response:D) { - $.body = $body; - self.header('Content-Type', $content-type); - self; - } - multi method write(Failure $body, Str:D $content-type = 'text/plain', --> Response:D) { - self.write($body.Str ~ "\n" ~ $body.backtrace, $content-type); - self.status(500); - self; - } - - # Set content type of the response - method content-type(Str:D $type --> Response) { - self.header('Content-Type', $type); - self; - } - - # $with_body is for HEAD requests. - method encode(Bool:D $with-body = True --> Buf:D) { - my $out = sprintf("HTTP/1.1 %d $!status\r\n", $!status.code); - my $body-size = $.body ~~ Buf:D ?? $.body.bytes !! $.body.chars; - - if $body-size > 0 && self.header('Content-Type') && self.header('Content-Type') !~~ /.*'octet-stream'.*/ { - %.headers ~= '; charset=utf8'; - } - - $out ~= sprintf("Content-Length: %d\r\n", $body-size); - $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", .encode); - } - - $out ~= "\r\n"; - - do given $.body { - when Str:D { - my $resp = $out ~ $.body; - $resp.encode.Buf if $with-body; - } - - when Buf:D { - ($out.encode ~ $.body).Buf if $with-body; - } - } - } -} +our constant $VERSION = '3.0.0'; ### ROUTING SECTION my constant $PARAM_IDX = ':'; @@ -564,7 +236,7 @@ sub group(@routes, @middlewares) is export { multi sub static(Str:D $path, Str:D $static-path, @middlewares = List.new) is export { static($path, $static-path.IO, @middlewares) } multi sub static(Str:D $path, IO::Path:D $static-path, @middlewares = List.new) is export { - my sub callback(Request:D $request, Response:D $response) { + my sub callback(Humming-Bird::Glue::Request:D $request, Humming-Bird::Glue::Response:D $response) { return $response.status(400) if $request.path.contains: '..'; my $cut-size = $path.ends-with('/') ?? $path.chars !! $path.chars + 1; my $file = $static-path.add($request.path.substr: $cut-size, $request.path.chars); @@ -607,24 +279,14 @@ sub routes(--> Hash:D) is export { %ROUTES.clone; } -sub handle($raw-request) { - my Request:D $request = Request.decode($raw-request); - my Bool:D $keep-alive = False; - my &advice = [o] @ADVICE; # Advice are Response --> Response - - with $request.header('Connection') { - $keep-alive = .lc eq 'keep-alive'; - } - - # If the request is HEAD, we shouldn't return the body - my Bool:D $should-show-body = !($request.method === HEAD); - # We need $should_show_body because the Content-Length header should remain on a HEAD request - return (&advice(dispatch-request($request)).encode($should-show-body), $keep-alive); +sub handle(Humming-Bird::Glue::Request:D $request) { + return ([o] @ADVICE).(dispatch-request($request)); } -sub listen(Int:D $port, :$no-block, :$timeout) is export { - my $timeout-real = $timeout // 3; # Sockets are closed after 3 seconds of inactivity - my $server = HTTPServer.new(:$port, timeout => $timeout-real); +sub listen(Int:D $port, :$no-block, :$timeout = 3, :$backend = Humming-Bird::Backend::HTTPServer) is export { + my $server = $backend.new(:$port, :$timeout); + + say "Humming-Bird listening on port http://localhost:$port"; if $no-block { start { $server.listen(&handle); @@ -633,77 +295,3 @@ sub listen(Int:D $port, :$no-block, :$timeout) is export { $server.listen(&handle); } } - -=begin pod -=head1 Humming-Bird::Core - -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. - -=head2 Exported subroutines - -=head3 get, post, put, patch, delete - -=for code - get('/home', -> $request, $response { - $response.html('

Hello World

'); - }); - - post('/users', -> $request, $response { - my $text = sprintf("Hello: %s", $request.body); - $response.write($text); # Content type defaults to text/plain - }); - - delete ... - put ... - patch ... - head ... - -Register an HTTP route, and a C that takes a Request and a Response. -It is expected that the route handler returns a valid C, in this case C<.html> returns -the response object for easy chaining. Bodies of requests can be parsed using C<.content> which -will attempt to parse the request based on the content-type, this only supports JSON and urlencoded -requests at the moment. - -=head3 group - -=for code -# Add middleware to a few routes -group([ - &get.assuming('/', -> $request, $response { - $response.html('Index'); - }), - - &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 of middleware in the last parameter. -Group takes a C of route functions partially applied to their route and callback, then a C - of middleware to apply to the routes. - -=head3 listen - -=for code - listen(8080); - -Start the server, after you've declared your routes. It will listen in a given port. - -=head3 routes - -=for code - routes(); - -Returns a read-only version of the currently stored routes. - -=head3 HTTPMethod - - Simply an ENUM that contains the major HTTP methods allowed by Humming-Bird. - -=end pod - - # vim: expandtab shiftwidth=4 diff --git a/lib/Humming-Bird/Glue.rakumod b/lib/Humming-Bird/Glue.rakumod new file mode 100644 index 0000000..b6428c4 --- /dev/null +++ b/lib/Humming-Bird/Glue.rakumod @@ -0,0 +1,329 @@ +use HTTP::Status; +use MIME::Types; +use URI::Encode; +use DateTime::Format::RFC2822; + +unit module Humming-Bird::Glue; + +# Mime type parser from MIME::Types +my constant $mime = MIME::Types.new; + +enum HTTPMethod is export ; + +# Converts a string of headers "KEY: VALUE\r\nKEY: VALUE\r\n..." to a map of headers. +my sub decode-headers(@header_block --> Map:D) { + Map.new(@header_block.map(*.trim.split(': ', 2, :skip-empty).map(*.trim)).map({ [@^a[0].lc, @^a[1]] }).flat); +} + +sub trim-utc-for-gmt(Str:D $utc --> Str:D) { $utc.subst(/"+0000"/, 'GMT') } +sub now-rfc2822(--> Str:D) { + trim-utc-for-gmt: DateTime.now(formatter => DateTime::Format::RFC2822.new()).utc.Str; +} + +# Convert a string to HTTP method, defaults to GET +sub http-method-of-str(Str:D $method --> HTTPMethod:D) { + given $method.lc { + when 'get' { GET } + when 'post' { POST; } + when 'put' { PUT } + when 'patch' { PATCH } + when 'delete' { DELETE } + when 'head' { HEAD } + default { GET } + } +} + +my 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 encode(--> Str:D) { + 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 decode(Str:D $cookie-string) { # We decode "simple" cookies only, since they come from the requests + Map.new: $cookie-string.split(/\s/, 2, :skip-empty) + .map(*.split('=', 2, :skip-empty)) + .map(-> ($name, $value) { $name => Cookie.new(:$name, :$value) }) + .flat; + } +} + +my subset Body where * ~~ Buf:D | Str:D; +class HTTPAction { + has $.context-id; + has %.headers; + has %.cookies; + has %.stash; # The stash is never encoded or decoded. It exists purely for internal talking between middlewares, request handlers, etc. + has Body:D $.body is rw = ""; + + # Find a header in the action, return (Any) if not found + multi method header(Str:D $name --> Str) { + my $lc-name = $name.lc; + return Nil without %.headers{$lc-name}; + %.headers{$lc-name}; + } + + multi method header(Str:D $name, Str:D $value) { + %.headers{$name.lc} = $value; + self; + } + + multi method cookie(Str:D $name --> Cookie) { + return Nil without %.cookies{$name}; + %.cookies{$name}; + } + + method log(Str:D $message, :$file = $*OUT) { + $file.print: "[Context: { self.context-id }] | [Time: { DateTime.now }] | $message\n"; + self; + } +} + +my sub parse-urlencoded(Str:D $urlencoded --> Map:D) { + $urlencoded.split('&', :skip-empty).map(&uri_decode_component)>>.split('=', 2, :skip-empty)>>.map(-> $a, $b { $b.contains(',') ?? slip $a => $b.split(',', :skip-empty) !! slip $a => $b }) + .flat + .Map; +} + +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; + has $!content; + + # Attempts to parse the body to a Map or return an empty map if we can't decode it + method content(--> Map:D) { + use JSON::Fast; + + state $prev-body = $.body; + + return $!content if $!content && ($prev-body eqv $.body); + return $!content = Map.new unless self.header('Content-Type'); + + try { + CATCH { + default { + warn "Encountered Error: $_;\n\n Failed trying to parse a body of type { self.header('Content-Type') }"; return ($!content = Map.new) + } + } + + if self.header('Content-Type').ends-with: 'json' { + $!content = from-json(self.body).Map; + } elsif self.header('Content-Type').ends-with: 'urlencoded' { + $!content = parse-urlencoded(self.body); + } + + return $!content; + } + + $!content = Map.new; + } + + method param(Str:D $param --> Str) { + return Nil without %!params{$param}; + %!params{$param}; + } + + method queries { + return %!query; + } + + multi method query { + return %!query; + } + multi method query(Str:D $query_param --> Str) { + return Nil without %!query{$query_param}; + %!query{$query_param}; + } + + submethod decode(Str:D $raw-request --> Request:D) { + use URI::Encode; + # 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(/\s/, :skip-empty); + + my $method = http-method-of-str($method_raw); + + # Find query params + my %query; + if uri_decode_component($path) ~~ m:g /\w+"="(<-[&]>+)/ { + %query = Map.new($<>.map({ .split('=', 2) }).flat); + $path = $path.split('?', 2)[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", 2, :skip-empty); + my $body = ""; + + # Lose the request line and parse an assoc list of headers. + my %headers = decode-headers(@split_request[0].split("\r\n", :skip-empty).skip(1)); + + # Body should only exist if either of these headers are present. + with %headers || %headers { + $body = @split_request[1] || $body; + } + + # Absolute uris need their path encoded differently. + without %headers { + my $abs-uri = $path; + $path = $abs-uri.match(/^'http' 's'? '://' <[A..Z a..z \w \. \- \_ 0..9]>+ <('/'.*)>? $/).Str; + %headers = $abs-uri.match(/^'http''s'?'://'(<-[/]>+)'/'?.* $/)[0].Str; + } + + my %cookies; + # Parse cookies + with %headers { + %cookies := Cookie.decode(%headers); + } + + my $context-id = rand.Str.subst('0.', '').substr: 0, 5; + + Request.new(:$path, :$method, :$version, :%query, :$body, :%headers, :%cookies, :$context-id); + } +} + +class Response is HTTPAction is export { + has HTTP::Status $.status is required; + has Request:D $.initiator is required handles ; + + 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; + } + multi method cookie(Str:D $name, Str:D $value, :$expires, :$secure) { + my $cookie = Cookie.new(:$name, :$value, :$expires, :$secure); + %.cookies{$name} = $cookie; + self; + } + + proto method status(|) {*} + multi method status(--> HTTP::Status) { $!status } + multi method status(Int:D $status --> Response:D) { + $!status = HTTP::Status($status); + self; + } + multi method status(HTTP::Status:D $status --> Response:D) { + $!status = $status; + self; + } + + # Redirect to a given URI, :$permanent allows for a 308 status code vs a 307 + method redirect(Str:D $to, :$permanent, :$temporary) { + self.header('Location', $to); + self.status(303); + + self.status(307) if $temporary; + self.status(308) if $permanent; + + self; + } + + method html(Str:D $body --> Response:D) { + $.write($body, 'text/html'); + self; + } + + # Write a JSON string to the body of the request + method json(Str:D $body --> Response:D) { + $.write($body, 'application/json'); + self; + } + + # Set a file to output. + method file(Str:D $file --> Response:D) { + my $text = $file.IO.slurp(:bin); + my $mime-type = $mime.type($file.IO.extension) // 'text/plain'; + try { + CATCH { + $mime-type = 'application/octet-stream' if $mime-type eq 'text/plain'; + return $.blob($text, $mime-type); + } + # Decode will fail if it's a binary file + $.write($text.decode, $mime-type); + } + self; + } + + # Write a blob or buffer + method blob(Buf:D $body, Str:D $content-type = 'application/octet-stream', --> Response:D) { + $.body = $body; + self.header('Content-Type', $content-type); + self; + } + # Alias for blob + multi method write(Buf:D $body, Str:D $content-type = 'application/octet-stream', --> Response:D) { + self.blob($body, $content-type); + } + # Write a string to the body of the response, optionally provide a content type + multi method write(Str:D $body, Str:D $content-type = 'text/plain', --> Response:D) { + $.body = $body; + self.header('Content-Type', $content-type); + self; + } + multi method write(Failure $body, Str:D $content-type = 'text/plain', --> Response:D) { + self.write($body.Str ~ "\n" ~ $body.backtrace, $content-type); + self.status(500); + self; + } + + # Set content type of the response + method content-type(Str:D $type --> Response) { + self.header('Content-Type', $type); + self; + } + + # $with_body is for HEAD requests. + method encode(Bool:D $with-body = True --> Buf:D) { + my $out = sprintf("HTTP/1.1 %d $!status\r\n", $!status.code); + my $body-size = $.body ~~ Buf:D ?? $.body.bytes !! $.body.chars; + + if $body-size > 0 && self.header('Content-Type') && self.header('Content-Type') !~~ /.*'octet-stream'.*/ { + %.headers ~= '; charset=utf8'; + } + + $out ~= sprintf("Content-Length: %d\r\n", $body-size); + $out ~= sprintf("Date: %s\r\n", now-rfc2822); + $out ~= "X-Server: Humming-Bird (Raku)\r\n"; + + for %.headers.pairs { + $out ~= sprintf("%s: %s\r\n", .key, .value); + } + + for %.cookies.values { + $out ~= sprintf("Set-Cookie: %s\r\n", .encode); + } + + $out ~= "\r\n"; + + do given $.body { + when Str:D { + my $resp = $out ~ $.body; + $resp.encode.Buf if $with-body; + } + + when Buf:D { + ($out.encode ~ $.body).Buf if $with-body; + } + } + } +} diff --git a/lib/Humming-Bird/HTTPServer.rakumod b/lib/Humming-Bird/HTTPServer.rakumod deleted file mode 100644 index b5e1832..0000000 --- a/lib/Humming-Bird/HTTPServer.rakumod +++ /dev/null @@ -1,148 +0,0 @@ -use v6; - -# This code is based on the excellent code by the Raku community with a few adjustments and code style changes. -# https://github.com/raku-community-modules/HTTP-Server-Async - -my constant $DEFAULT-RN = "\r\n\r\n".encode.Buf; -my constant $RN = "\r\n".encode.Buf; - -class Humming-Bird::HTTPServer is export { - has Int:D $.port = 8080; - has Int:D $.timeout is required; - has Channel:D $.requests .= new; - has Lock $!lock .= new; - has @!connections; - - method !timeout { - start { - react { - whenever Supply.interval(1) { - CATCH { default { warn $_ } } - $!lock.protect({ - @!connections = @!connections.grep({ !$_.defined }); # Remove dead connections - for @!connections.grep({ now - $_ >= $!timeout }) { - { - $_ = True; - $_.write(Blob.new); - $_.close; - - CATCH { default { warn $_ } } - } - } - }); - } - } - } - } - - method !respond(&handler) { - start { - react { - whenever $.requests -> $request { - CATCH { default { .say } } - my ($response, $keep-alive) = &handler($request.decode); - $request.write: $response; - $request = True unless $keep-alive; - } - } - } - } - - method !handle-request($data is rw, $index is rw, $connection) { - my $request = { - :$connection, - data => Buf.new - }; - - my @header-lines = Buf.new($data[0..$index]).decode.lines.tail(*-1).grep({ .chars }); - return unless @header-lines.elems; - - $request ~= $data.subbuf(0, $index); - - my $content-length = $data.elems - $index; - for @header-lines -> $header { - my ($key, $value) = $header.split(': ', 2, :skip-empty); - given $key.lc { - when 'content-length' { - $content-length = +$value // ($data.elems - $index); - } - when 'transfer-encoding' { - if $value.chomp.lc.index('chunked') !~~ Nil { - my Int $i; - my Int $b; - while $i < $data.elems { - $i++ while $data[$i] != $RN[0] - && $data[$i+1] != $RN[1] - && $i + 1 < $data.elems; - - last if $i + 1 >= $data.elems; - - $b = :16($data[0..$i].decode); - last if $data.elems < $i + $b; - if $b == 0 { - try $data .= subbuf(3); - last; - } - - $i += 2; - $request ~= $data.subbuf($i, $i+$b-3); - try $data .= subbuf($i+$b+2); - $i = 0; - } - } - } - } - } - - $request ~= $data.subbuf($index, $content-length+4); - $.requests.send: $request; - } - - method listen(&handler) { - - react { - say "Humming-Bird listening on port http://localhost:$.port"; - - self!timeout; - self!respond(&handler); - - whenever IO::Socket::Async.listen('0.0.0.0', $.port) -> $connection { - my %connection-map := { - socket => $connection, - last-active => now - } - - $!lock.protect({ @!connections.push: %connection-map }); - - whenever $connection.Supply: :bin -> $bytes { - my Buf $data .= new; - my Int:D $idx = 0; - my $req; - - CATCH { default { .say } } - $data ~= $bytes; - %connection-map = now; - while $idx++ < $data.elems - 4 { - # Read up to headers - $idx--, last if $data[$idx] == $DEFAULT-RN[0] - && $data[$idx+1] == $DEFAULT-RN[1] - && $data[$idx+2] == $DEFAULT-RN[2] - && $data[$idx+3] == $DEFAULT-RN[3]; - } - - $idx += 4; - - self!handle-request($data, $idx, %connection-map); - } - - CATCH { default { .say; $connection.close; %connection-map = True } } - } - } - } -} - -# vim: expandtab shiftwidth=4 - -=begin pod -A simple async HTTP server that does its best to follow HTTP/1.1 -=end pod diff --git a/lib/Humming-Bird/Middleware.rakumod b/lib/Humming-Bird/Middleware.rakumod index 6d3442d..404370d 100644 --- a/lib/Humming-Bird/Middleware.rakumod +++ b/lib/Humming-Bird/Middleware.rakumod @@ -1,6 +1,7 @@ use v6.d; use Humming-Bird::Core; +use Humming-Bird::Glue; use UUID::V4; diff --git a/t/01-basic.rakutest b/t/01-basic.rakutest index afb139e..3dc5996 100644 --- a/t/01-basic.rakutest +++ b/t/01-basic.rakutest @@ -3,6 +3,7 @@ use lib 'lib'; use strict; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 8; diff --git a/t/02-request_encoding.rakutest b/t/02-request_encoding.rakutest index f0638ae..f88443d 100644 --- a/t/02-request_encoding.rakutest +++ b/t/02-request_encoding.rakutest @@ -4,6 +4,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 17; diff --git a/t/03-response_decoding.rakutest b/t/03-response_decoding.rakutest index 0f80112..db15027 100644 --- a/t/03-response_decoding.rakutest +++ b/t/03-response_decoding.rakutest @@ -4,6 +4,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; use HTTP::Status; plan 5; diff --git a/t/04-middleware.rakutest b/t/04-middleware.rakutest index 44cc1e0..4c99368 100644 --- a/t/04-middleware.rakutest +++ b/t/04-middleware.rakutest @@ -4,6 +4,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 6; diff --git a/t/05-cookie.rakutest b/t/05-cookie.rakutest index fd363d6..5c50c38 100644 --- a/t/05-cookie.rakutest +++ b/t/05-cookie.rakutest @@ -4,6 +4,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 5; diff --git a/t/06-redirect.rakutest b/t/06-redirect.rakutest index a6263cb..7b506c2 100644 --- a/t/06-redirect.rakutest +++ b/t/06-redirect.rakutest @@ -2,6 +2,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; use HTTP::Status; plan 6; diff --git a/t/07-advice.rakutest b/t/07-advice.rakutest index d416f97..a52383f 100644 --- a/t/07-advice.rakutest +++ b/t/07-advice.rakutest @@ -3,10 +3,11 @@ use v6.d; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 3; -sub custom-advice(Response $response --> Response) { +sub custom-advice($response) { return $response.write('abc'); } diff --git a/t/08-static.rakutest b/t/08-static.rakutest index b75280b..e3ee3f4 100644 --- a/t/08-static.rakutest +++ b/t/08-static.rakutest @@ -3,6 +3,7 @@ use v6.d; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; use HTTP::Status; plan 6; diff --git a/t/09-routers.rakutest b/t/09-routers.rakutest index 4b968f3..804f239 100644 --- a/t/09-routers.rakutest +++ b/t/09-routers.rakutest @@ -1,6 +1,7 @@ use v6.d; use Humming-Bird::Core; +use Humming-Bird::Glue; use HTTP::Status; use Test; diff --git a/t/10-content-guessing.rakutest b/t/10-content-guessing.rakutest index c2782c3..1185c32 100644 --- a/t/10-content-guessing.rakutest +++ b/t/10-content-guessing.rakutest @@ -1,5 +1,6 @@ use v6.d; use Humming-Bird::Core; +use Humming-Bird::Glue; use Test; plan 7; diff --git a/t/11-advanced-query.rakutest b/t/11-advanced-query.rakutest index b1c7054..3cd8ad8 100644 --- a/t/11-advanced-query.rakutest +++ b/t/11-advanced-query.rakutest @@ -4,6 +4,7 @@ use lib 'lib'; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 12; diff --git a/t/12-headers.rakutest b/t/12-headers.rakutest index 5469467..7ecfd25 100644 --- a/t/12-headers.rakutest +++ b/t/12-headers.rakutest @@ -3,6 +3,7 @@ use lib 'lib'; use strict; use Test; use Humming-Bird::Core; +use Humming-Bird::Glue; plan 4;