├── .gitignore ├── .travis.yml ├── LICENSE ├── META6.json ├── README.md ├── bin ├── crustup └── crustup.bat ├── eg ├── crust-request.p6w ├── dump-env.p6w ├── hello.p6w └── mojo.p6w ├── lib ├── Crust.pm6 ├── Crust │ ├── App │ │ ├── Directory.pm6 │ │ ├── File.pm6 │ │ └── URLMap.pm6 │ ├── Builder.pm6 │ ├── Handler.pod │ ├── Handler │ │ ├── FastCGI.pm6 │ │ └── HTTP │ │ │ ├── Easy.pm6 │ │ │ └── Server │ │ │ └── Tiny.pm6 │ ├── Headers.pm6 │ ├── MIME.pm6 │ ├── Middleware.pm6 │ ├── Middleware │ │ ├── AccessLog.pm6 │ │ ├── Auth │ │ │ └── Basic.pm6 │ │ ├── Conditional.pm6 │ │ ├── ContentLength.pm6 │ │ ├── ErrorDocument.pm6 │ │ ├── Lint.pm6 │ │ ├── ReverseProxy.pm6 │ │ ├── Runtime.pm6 │ │ ├── StackTrace.pm6 │ │ ├── Static.pm6 │ │ └── XFramework.pm6 │ ├── Request.pm6 │ ├── Request │ │ └── Upload.pm6 │ ├── Response.pm6 │ ├── Runner.pm6 │ ├── Test.pm6 │ ├── Test │ │ └── MockHTTP.pm6 │ └── Utils.pm6 └── HTTP │ └── Message │ └── P6W.pm6 ├── share ├── #foo ├── baybridge.jpg └── face.jpg └── t ├── Crust-App ├── directory.t ├── file.t └── urlmap.t ├── Crust-Builder ├── basic.t ├── middleware.t └── mount.t ├── Crust-Handler └── HTTP-Server-Tiny.t ├── Crust-Middleware ├── accesslog.t ├── auth_basic.t ├── conditional.t ├── content-length.t ├── error-document.t ├── lint.t ├── reverse-proxy.t ├── runtime.t ├── stack-trace.t ├── static.foo ├── static.t └── xframework.t ├── Crust-Test ├── 2args.t └── hello.t ├── HTTP-Message-P6W ├── content-length.t ├── error.t ├── host.t ├── path-info.t ├── res.t └── utf8-req.t ├── crust ├── data │ └── 001-content.dat ├── headers.t ├── mime │ ├── add-type.t │ ├── basic.t │ └── fallback.t ├── request.t ├── response.t └── utils.t ├── dat └── query.txt └── lib ├── SupplierBuffer.pm6 └── Test └── TCP.pm6 /.gitignore: -------------------------------------------------------------------------------- 1 | /blib/ 2 | **/.precomp/ 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | perl6: 3 | - latest 4 | install: 5 | - rakudobrew build-zef 6 | - zef install --/test --test-depends --depsonly . 7 | script: 8 | - prove -vr -e 'perl6 -Ilib' t/ 9 | sudo: false 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The Artistic License 2.0 2 | 3 | Copyright (c) 2000-2015, The Perl Foundation. 4 | 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | This license establishes the terms under which a given free software 11 | Package may be copied, modified, distributed, and/or redistributed. 12 | The intent is that the Copyright Holder maintains some artistic 13 | control over the development of that Package while still keeping the 14 | Package available as open source and free software. 15 | 16 | You are always permitted to make arrangements wholly outside of this 17 | license directly with the Copyright Holder of a given Package. If the 18 | terms of this license do not permit the full use that you propose to 19 | make of the Package, you should contact the Copyright Holder and seek 20 | a different licensing arrangement. 21 | 22 | Definitions 23 | 24 | "Copyright Holder" means the individual(s) or organization(s) 25 | named in the copyright notice for the entire Package. 26 | 27 | "Contributor" means any party that has contributed code or other 28 | material to the Package, in accordance with the Copyright Holder's 29 | procedures. 30 | 31 | "You" and "your" means any person who would like to copy, 32 | distribute, or modify the Package. 33 | 34 | "Package" means the collection of files distributed by the 35 | Copyright Holder, and derivatives of that collection and/or of 36 | those files. A given Package may consist of either the Standard 37 | Version, or a Modified Version. 38 | 39 | "Distribute" means providing a copy of the Package or making it 40 | accessible to anyone else, or in the case of a company or 41 | organization, to others outside of your company or organization. 42 | 43 | "Distributor Fee" means any fee that you charge for Distributing 44 | this Package or providing support for this Package to another 45 | party. It does not mean licensing fees. 46 | 47 | "Standard Version" refers to the Package if it has not been 48 | modified, or has been modified only in ways explicitly requested 49 | by the Copyright Holder. 50 | 51 | "Modified Version" means the Package, if it has been changed, and 52 | such changes were not explicitly requested by the Copyright 53 | Holder. 54 | 55 | "Original License" means this Artistic License as Distributed with 56 | the Standard Version of the Package, in its current version or as 57 | it may be modified by The Perl Foundation in the future. 58 | 59 | "Source" form means the source code, documentation source, and 60 | configuration files for the Package. 61 | 62 | "Compiled" form means the compiled bytecode, object code, binary, 63 | or any other form resulting from mechanical transformation or 64 | translation of the Source form. 65 | 66 | 67 | Permission for Use and Modification Without Distribution 68 | 69 | (1) You are permitted to use the Standard Version and create and use 70 | Modified Versions for any purpose without restriction, provided that 71 | you do not Distribute the Modified Version. 72 | 73 | 74 | Permissions for Redistribution of the Standard Version 75 | 76 | (2) You may Distribute verbatim copies of the Source form of the 77 | Standard Version of this Package in any medium without restriction, 78 | either gratis or for a Distributor Fee, provided that you duplicate 79 | all of the original copyright notices and associated disclaimers. At 80 | your discretion, such verbatim copies may or may not include a 81 | Compiled form of the Package. 82 | 83 | (3) You may apply any bug fixes, portability changes, and other 84 | modifications made available from the Copyright Holder. The resulting 85 | Package will still be considered the Standard Version, and as such 86 | will be subject to the Original License. 87 | 88 | 89 | Distribution of Modified Versions of the Package as Source 90 | 91 | (4) You may Distribute your Modified Version as Source (either gratis 92 | or for a Distributor Fee, and with or without a Compiled form of the 93 | Modified Version) provided that you clearly document how it differs 94 | from the Standard Version, including, but not limited to, documenting 95 | any non-standard features, executables, or modules, and provided that 96 | you do at least ONE of the following: 97 | 98 | (a) make the Modified Version available to the Copyright Holder 99 | of the Standard Version, under the Original License, so that the 100 | Copyright Holder may include your modifications in the Standard 101 | Version. 102 | 103 | (b) ensure that installation of your Modified Version does not 104 | prevent the user installing or running the Standard Version. In 105 | addition, the Modified Version must bear a name that is different 106 | from the name of the Standard Version. 107 | 108 | (c) allow anyone who receives a copy of the Modified Version to 109 | make the Source form of the Modified Version available to others 110 | under 111 | 112 | (i) the Original License or 113 | 114 | (ii) a license that permits the licensee to freely copy, 115 | modify and redistribute the Modified Version using the same 116 | licensing terms that apply to the copy that the licensee 117 | received, and requires that the Source form of the Modified 118 | Version, and of any works derived from it, be made freely 119 | available in that license fees are prohibited but Distributor 120 | Fees are allowed. 121 | 122 | 123 | Distribution of Compiled Forms of the Standard Version 124 | or Modified Versions without the Source 125 | 126 | (5) You may Distribute Compiled forms of the Standard Version without 127 | the Source, provided that you include complete instructions on how to 128 | get the Source of the Standard Version. Such instructions must be 129 | valid at the time of your distribution. If these instructions, at any 130 | time while you are carrying out such distribution, become invalid, you 131 | must provide new instructions on demand or cease further distribution. 132 | If you provide valid instructions or cease distribution within thirty 133 | days after you become aware that the instructions are invalid, then 134 | you do not forfeit any of your rights under this license. 135 | 136 | (6) You may Distribute a Modified Version in Compiled form without 137 | the Source, provided that you comply with Section 4 with respect to 138 | the Source of the Modified Version. 139 | 140 | 141 | Aggregating or Linking the Package 142 | 143 | (7) You may aggregate the Package (either the Standard Version or 144 | Modified Version) with other packages and Distribute the resulting 145 | aggregation provided that you do not charge a licensing fee for the 146 | Package. Distributor Fees are permitted, and licensing fees for other 147 | components in the aggregation are permitted. The terms of this license 148 | apply to the use and Distribution of the Standard or Modified Versions 149 | as included in the aggregation. 150 | 151 | (8) You are permitted to link Modified and Standard Versions with 152 | other works, to embed the Package in a larger work of your own, or to 153 | build stand-alone binary or bytecode versions of applications that 154 | include the Package, and Distribute the result without restriction, 155 | provided the result does not expose a direct interface to the Package. 156 | 157 | 158 | Items That are Not Considered Part of a Modified Version 159 | 160 | (9) Works (including, but not limited to, modules and scripts) that 161 | merely extend or make use of the Package, do not, by themselves, cause 162 | the Package to be a Modified Version. In addition, such works are not 163 | considered parts of the Package itself, and are not subject to the 164 | terms of this license. 165 | 166 | 167 | General Provisions 168 | 169 | (10) Any use, modification, and distribution of the Standard or 170 | Modified Versions is governed by this Artistic License. By using, 171 | modifying or distributing the Package, you accept this license. Do not 172 | use, modify, or distribute the Package, if you do not accept this 173 | license. 174 | 175 | (11) If your Modified Version has been derived from a Modified 176 | Version made by someone other than you, you are nevertheless required 177 | to ensure that your Modified Version complies with the requirements of 178 | this license. 179 | 180 | (12) This license does not grant you the right to use any trademark, 181 | service mark, tradename, or logo of the Copyright Holder. 182 | 183 | (13) This license includes the non-exclusive, worldwide, 184 | free-of-charge patent license to make, have made, use, offer to sell, 185 | sell, import and otherwise transfer the Package with respect to any 186 | patent claims licensable by the Copyright Holder that are necessarily 187 | infringed by the Package. If you institute patent litigation 188 | (including a cross-claim or counterclaim) against any party alleging 189 | that the Package constitutes direct or contributory patent 190 | infringement, then this Artistic License to you shall terminate on the 191 | date that such litigation is filed. 192 | 193 | (14) Disclaimer of Warranty: 194 | THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS 195 | IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 196 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 197 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL 198 | LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL 199 | BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL 200 | DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF 201 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 202 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "authors" : [ 3 | "Tokuhiro Matsuno" 4 | ], 5 | "build-depends" : [ ], 6 | "depends" : [ 7 | "Base64", 8 | "HTTP::Server::Tiny", 9 | "Cookie::Baker", 10 | "File::Temp", 11 | "HTTP::MultiPartParser", 12 | "Hash::MultiValue", 13 | "Getopt::Tiny", 14 | "HTTP::Easy", 15 | "URI::Escape", 16 | "HTTP::UserAgent", 17 | "Backtrace::AsHTML", 18 | "Apache::LogFormat" 19 | ], 20 | "description" : "Perl6 Superglue for Web frameworks and Web Servers", 21 | "license" : "Artistic-2.0", 22 | "name" : "Crust", 23 | "perl" : "6", 24 | "provides" : { 25 | "Crust" : "lib/Crust.pm6", 26 | "Crust::App::Directory" : "lib/Crust/App/Directory.pm6", 27 | "Crust::App::File" : "lib/Crust/App/File.pm6", 28 | "Crust::App::URLMap" : "lib/Crust/App/URLMap.pm6", 29 | "Crust::Builder" : "lib/Crust/Builder.pm6", 30 | "Crust::Handler::FastCGI" : "lib/Crust/Handler/FastCGI.pm6", 31 | "Crust::Handler::HTTP::Easy" : "lib/Crust/Handler/HTTP/Easy.pm6", 32 | "Crust::Handler::HTTP::Server::Tiny" : "lib/Crust/Handler/HTTP/Server/Tiny.pm6", 33 | "Crust::Headers" : "lib/Crust/Headers.pm6", 34 | "Crust::MIME" : "lib/Crust/MIME.pm6", 35 | "Crust::Middleware" : "lib/Crust/Middleware.pm6", 36 | "Crust::Middleware::AccessLog" : "lib/Crust/Middleware/AccessLog.pm6", 37 | "Crust::Middleware::Auth::Basic" : "lib/Crust/Middleware/Auth/Basic.pm6", 38 | "Crust::Middleware::Conditional" : "lib/Crust/Middleware/Conditional.pm6", 39 | "Crust::Middleware::ContentLength" : "lib/Crust/Middleware/ContentLength.pm6", 40 | "Crust::Middleware::ErrorDocument" : "lib/Crust/Middleware/ErrorDocument.pm6", 41 | "Crust::Middleware::Lint" : "lib/Crust/Middleware/Lint.pm6", 42 | "Crust::Middleware::ReverseProxy" : "lib/Crust/Middleware/ReverseProxy.pm6", 43 | "Crust::Middleware::Runtime" : "lib/Crust/Middleware/Runtime.pm6", 44 | "Crust::Middleware::StackTrace" : "lib/Crust/Middleware/StackTrace.pm6", 45 | "Crust::Middleware::Static" : "lib/Crust/Middleware/Static.pm6", 46 | "Crust::Middleware::XFramework" : "lib/Crust/Middleware/XFramework.pm6", 47 | "Crust::Request" : "lib/Crust/Request.pm6", 48 | "Crust::Request::Upload" : "lib/Crust/Request/Upload.pm6", 49 | "Crust::Response" : "lib/Crust/Response.pm6", 50 | "Crust::Runner" : "lib/Crust/Runner.pm6", 51 | "Crust::Test" : "lib/Crust/Test.pm6", 52 | "Crust::Test::MockHTTP" : "lib/Crust/Test/MockHTTP.pm6", 53 | "Crust::Utils" : "lib/Crust/Utils.pm6", 54 | "HTTP::Message::P6W" : "lib/HTTP/Message/P6W.pm6" 55 | }, 56 | "resources" : [ ], 57 | "source-url" : "git://github.com/tokuhirom/p6-Crust.git", 58 | "tags" : [ ], 59 | "test-depends" : [ 60 | "HTTP::Tinyish" 61 | ], 62 | "version" : "0.0.1" 63 | } 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/tokuhirom/p6-Crust.svg?branch=master)](https://travis-ci.org/tokuhirom/p6-Crust) 2 | 3 | NAME 4 | ==== 5 | 6 | Crust - Perl6 Superglue for Web frameworks and Web Servers 7 | 8 | DESCRIPTION 9 | =========== 10 | 11 | Crust is a set of tools for using the P6W stack. It contains middleware components, and utilities for Web application frameworks. Crust is like Perl5's Plack, Ruby's Rack, Python's Paste for WSGI. 12 | 13 | See [P6W](https://github.com/zostay/P6W) for the P6W (former known as P6SGI) specification. 14 | 15 | MODULES AND UTILITIES 16 | ===================== 17 | 18 | Crust::Handler 19 | -------------- 20 | 21 | Crust::Handler and its subclasses contains adapters for web servers. We have adapters for the built-in standalone web server HTTP::Easy::PSGI, and HTTP::Server::Tiny included in the core Crust distribution. 22 | 23 | See [Crust::Handler](Crust::Handler) when writing your own adapters. 24 | 25 | Crust::Middleware 26 | ----------------- 27 | 28 | P6W middleware is a P6W application that wraps an existing P6W application and plays both side of application and servers. From the servers the wrapped code reference still looks like and behaves exactly the same as P6W applications. 29 | 30 | Crust::Request, Crust::Response 31 | ------------------------------- 32 | 33 | Crust::Request gives you a nice wrapper API around P6W $env hash to get headers, cookies and query parameters much like Apache::Request in mod_perl. 34 | 35 | Crust::Response does the same to construct the response array reference. 36 | 37 | .p6w files 38 | ---------- 39 | 40 | A P6W application is a code reference but it's not easy to pass code reference via the command line or configuration files, so Crust uses a convention that you need a file named "app.p6w" or similar, which would be loaded (via perl6's core function "EVALFILE") to return the P6W application code reference. 41 | 42 | # Hello.p6w 43 | my $app = sub ($env) { 44 | # ... 45 | return $status, $headers, $body; 46 | }; 47 | 48 | If you use a web framework, chances are that they provide a helper utility to automatically generate these ".p6w" files for you, such as: 49 | 50 | # MyApp.p6w 51 | use MyApp; 52 | my $app = sub { MyApp->run_p6w(@_) }; 53 | 54 | It's important that the return value of ".p6w" file is the code reference. See "eg/" directory for more examples of ".p6w" files. 55 | 56 | An Alternative to .p6w files 57 | ============================ 58 | 59 | As an alternative to using EVAL, you can take advantage of Perl's Callable type which will return a code reference as well, making Crust happy. 60 | 61 | Here is an example of an implmentation using a Callable class in place of any .p6w files and having to call a "crustup" script. You can call this directly from the command line, just like you would "crustup". 62 | 63 | use v6; 64 | 65 | use Crust::Runner; 66 | 67 | class MyApp does Callable 68 | { 69 | has $.status is rw; 70 | has @.headers is rw; 71 | has @.body is rw; 72 | 73 | method CALL-ME(%env) { 74 | self.call(%env); 75 | } 76 | 77 | method call(%env) { 78 | 79 | $.status = 200; 80 | @.headers = [ 'Content-Type' => 'text/html' ]; 81 | @.body = [ 'Hi', 82 | 'I just want you to see me', 83 | '', 84 | ]; 85 | 86 | return $.status, @.headers, @.body; 87 | } 88 | } 89 | 90 | my $runner = Crust::Runner.new; 91 | $runner.parse-options(@*ARGS); 92 | $runner.run(MyApp.new); 93 | 94 | AUTHORS 95 | ======= 96 | 97 | * Tokuhiro Matsuno 98 | 99 | * mattn 100 | 101 | * Shoichi Kaji 102 | 103 | * Daisuke Maki 104 | 105 | * moznion 106 | 107 | * Kentaro Kuribayashi 108 | 109 | * Tim Smith 110 | 111 | * fayland 112 | 113 | INSTALL AND TEST 114 | ================ 115 | 116 | Install dependencies with 117 | 118 | zef install --deps-only . 119 | 120 | And then test with 121 | 122 | prove -Ilib --exec "perl6 -Ilib" -r t 123 | 124 | (provided `prove` is installed via Perl5's `Test::Harness`) 125 | 126 | Or better 127 | 128 | zef test . 129 | 130 | (this will use available test facilities, including the one above) 131 | 132 | COPYRIGHT AND LICENSE 133 | ===================== 134 | 135 | Copyright 2015 Tokuhiro Matsuno 136 | 137 | This library is free software; you can redistribute it and/or modify it under the Artistic License 2.0. 138 | -------------------------------------------------------------------------------- /bin/crustup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6-m 2 | use v6; 3 | 4 | use Crust::Runner; 5 | 6 | # EXPERIMENTAL FEATURE 7 | # p6w file can detect whether it is invoked by some p6w runner script or not 8 | # via environment variable P6W_CONTAINER 9 | %*ENV = "crust"; 10 | 11 | my $runner = Crust::Runner.new; 12 | $runner.parse-options(@*ARGS); 13 | $runner.run(); 14 | 15 | =begin pod 16 | 17 | =head1 NAME 18 | 19 | crustup - Run P6W application with Crust handlers 20 | 21 | =head1 SYNOPSIS 22 | 23 | # read your app from app.p6w file 24 | crustup 25 | 26 | # choose .p6w file from ARGV[0] (or with -a option) 27 | crustup hello.p6w 28 | 29 | # switch server implementation with --server (or -s) 30 | crustup --server HTTP::Server::Simple --port 9090 --host 127.0.0.1 test.p6w 31 | 32 | =head1 DESCRIPTION 33 | 34 | crustup is a command line utility to run P6W applications from the 35 | command line. 36 | 37 | =end pod 38 | -------------------------------------------------------------------------------- /bin/crustup.bat: -------------------------------------------------------------------------------- 1 | @ perl6 %~dpn0 %* 2 | -------------------------------------------------------------------------------- /eg/crust-request.p6w: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Crust::Request; 4 | 5 | sub app($env) { 6 | my $req = Crust::Request.new($env); 7 | return 200, [], [$req.path-info]; 8 | } 9 | -------------------------------------------------------------------------------- /eg/dump-env.p6w: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | sub app(%env) { 4 | my @lines; 5 | for %env.kv -> $key, $value { 6 | push @lines, "$key => $value" 7 | } 8 | my $content = @lines.join("\n").encode; 9 | return 200, ['content-length' => $content.bytes], [$content]; 10 | } 11 | -------------------------------------------------------------------------------- /eg/hello.p6w: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | sub app($env) { 4 | if ($env && $env eq '/exit') { 5 | say 'good bye!'; 6 | exit; 7 | } 8 | return 200, ['Content-Type' => 'text/plain'], ["hello!!!\n"]; 9 | } 10 | 11 | -------------------------------------------------------------------------------- /eg/mojo.p6w: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Template::Mojo; 4 | use Crust::Request; 5 | 6 | my $tmpl = Template::Mojo.new(q:heredoc/END/); 7 | % my ($name) = @_; 8 | 9 | 10 | Hello, <%= $name %> 11 |
12 | 13 | 14 |
15 | 16 | END 17 | 18 | sub app($env) { 19 | my $req = Crust::Request.new($env); 20 | given $req.path-info { 21 | when "/" { 22 | my $content = $tmpl.render($req.query-parameters // 'unknown'); 23 | return 200, [ 'Content-Type' => 'text/html; charset=utf-8' ], [$content]; 24 | } 25 | when "/upload" { 26 | my $content = $req.uploads.path.slurp(:bin); 27 | $content.perl.say; 28 | return 200, 29 | [ 30 | 'Content-Type' => 'text/plain', 31 | 'content-length' => $content.bytes, 32 | ], 33 | [$content]; 34 | } 35 | default { 36 | return 400, [], ['not found']; 37 | } 38 | } 39 | } 40 | 41 | -------------------------------------------------------------------------------- /lib/Crust.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Crust; 3 | 4 | 5 | =begin pod 6 | 7 | =head1 NAME 8 | 9 | Crust - Perl6 Superglue for Web frameworks and Web Servers 10 | 11 | =head1 DESCRIPTION 12 | 13 | Crust is a set of tools for using the P6W stack. It contains middleware 14 | components, and utilities for Web application frameworks. 15 | Crust is like Perl5's Plack, Ruby's Rack, Python's Paste for WSGI. 16 | 17 | See L for the P6W (former known as P6SGI) specification. 18 | 19 | =head1 MODULES AND UTILITIES 20 | 21 | =head2 Crust::Handler 22 | 23 | Crust::Handler and its subclasses contains adapters for web servers. We 24 | have adapters for the built-in standalone web server HTTP::Easy::PSGI, 25 | and HTTP::Server::Tiny included in the core Crust distribution. 26 | 27 | See L when writing your own adapters. 28 | 29 | =head2 Crust::Middleware 30 | 31 | P6W middleware is a P6W application that wraps an existing P6W 32 | application and plays both side of application and servers. From the 33 | servers the wrapped code reference still looks like and behaves exactly 34 | the same as P6W applications. 35 | 36 | =head2 Crust::Request, Crust::Response 37 | 38 | Crust::Request gives you a nice wrapper API around P6W $env hash to get 39 | headers, cookies and query parameters much like Apache::Request in 40 | mod_perl. 41 | 42 | Crust::Response does the same to construct the response array reference. 43 | 44 | =head2 .p6w files 45 | 46 | A P6W application is a code reference but it's not easy to pass code 47 | reference via the command line or configuration files, so Crust uses a 48 | convention that you need a file named "app.p6w" or similar, which would 49 | be loaded (via perl6's core function "EVALFILE") to return the P6W application 50 | code reference. 51 | 52 | # Hello.p6w 53 | my $app = sub ($env) { 54 | # ... 55 | return $status, $headers, $body; 56 | }; 57 | 58 | If you use a web framework, chances are that they provide a helper utility 59 | to automatically generate these ".p6w" files for you, such as: 60 | 61 | # MyApp.p6w 62 | use MyApp; 63 | my $app = sub { MyApp->run_p6w(@_) }; 64 | 65 | It's important that the return value of ".p6w" file is the code 66 | reference. See "eg/" directory for more examples of ".p6w" files. 67 | 68 | =head1 An Alternative to .p6w files 69 | 70 | As an alternative to using EVAL, you can take advantage of Perl's Callable type which will return a code reference as well, making Crust happy. 71 | 72 | Here is an example of an implmentation using a Callable class in place of any .p6w files and having to call a "crustup" script. You can call this directly from the command line, just like you would "crustup". 73 | 74 | use v6; 75 | 76 | use Crust::Runner; 77 | 78 | class MyApp does Callable 79 | { 80 | has $.status is rw; 81 | has @.headers is rw; 82 | has @.body is rw; 83 | 84 | method CALL-ME(%env) { 85 | self.call(%env); 86 | } 87 | 88 | method call(%env) { 89 | 90 | $.status = 200; 91 | @.headers = [ 'Content-Type' => 'text/html' ]; 92 | @.body = [ 'Hi', 93 | 'I just want you to see me', 94 | '', 95 | ]; 96 | 97 | return $.status, @.headers, @.body; 98 | } 99 | } 100 | 101 | my $runner = Crust::Runner.new; 102 | $runner.parse-options(@*ARGS); 103 | $runner.run(MyApp.new); 104 | 105 | =head1 AUTHORS 106 | 107 | =item Tokuhiro Matsuno 108 | 109 | =item mattn 110 | 111 | =item Shoichi Kaji 112 | 113 | =item Daisuke Maki 114 | 115 | =item moznion 116 | 117 | =item Kentaro Kuribayashi 118 | 119 | =item Tim Smith 120 | 121 | =item fayland 122 | 123 | =head1 COPYRIGHT AND LICENSE 124 | 125 | Copyright 2015 Tokuhiro Matsuno 126 | 127 | This library is free software; you can redistribute it and/or modify it under the Artistic License 2.0. 128 | 129 | =end pod 130 | -------------------------------------------------------------------------------- /lib/Crust/App/Directory.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::App::File; 3 | use Crust::MIME; 4 | use Crust::Utils; 5 | 6 | unit class Crust::App::Directory is Crust::App::File; 7 | 8 | our $dir_file = Q:b "%s%s%s%s"; 9 | our $dir_page = Q:to 'PAGE'; 10 | 11 | %s 12 | 13 | 20 | 21 |

%s

22 |
23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | %s 31 |
NameSizeTypeLast Modified
32 |
33 | 34 | PAGE 35 | 36 | has Str $.dir; 37 | 38 | method should-handle(Str $dir) { 39 | $dir.IO.d || $dir.IO.f; 40 | } 41 | 42 | method call(Hash $env) { 43 | # Directory traversal should be avoided by Crust::App::File.locate-file. 44 | # It should be returned as the root directory. 45 | start { 46 | sub { 47 | my ($file, $path-info, $error-res) = $!dir || self.locate-file($env); 48 | return |$error-res if $error-res; 49 | 50 | return self.serve-path($env, $file) if $file.IO.f; 51 | return self.serve-dir($env, $file); 52 | }.(); 53 | }; 54 | } 55 | 56 | method serve-dir(Hash $env, Str $dir) { 57 | my $path = $env || ''; 58 | return 59 | 301, 60 | [ 61 | 'Content-Type' => "text/plain", 62 | 'Location' => "/{{$dir}}/" 63 | ], 64 | [""] unless $path.ends-with('/'); 65 | 66 | my Str $files; 67 | $files ~= sprintf($dir_file, '..', '..', '', '', ''); 68 | for $dir.IO.dir -> $file { 69 | my $ct = $file.d ?? '' !! Crust::MIME.mime-type($file.absolute) || 'text/plain'; 70 | my $size = $file.d ?? '' !! $file.s; 71 | my $name = encode-html($file.basename); 72 | $files ~= sprintf($dir_file, $name, $name, $size, $ct, DateTime.new($file.modified)); 73 | } 74 | 75 | my $page = sprintf($dir_page, $path, $path, $files); 76 | return 77 | 200, 78 | [ 79 | 'Content-Type' => 'text/html; charset=utf-8' 80 | ], 81 | [$page] 82 | ; 83 | } 84 | 85 | =begin pod 86 | 87 | =head1 NAME 88 | 89 | Crust::App::Directory - Serve static files from document root with directory index 90 | 91 | =head1 SYNOPSIS 92 | 93 | > crustup -MCrust::App::Directory -e 'Crust::App::Directory.new' 94 | 95 | =head1 DESCRIPTION 96 | 97 | Crust::App::Directory is perl6 port of perl5 Plack::App::Directory. 98 | 99 | =head1 SEE ALSO 100 | 101 | L 102 | 103 | =head1 AUTHOR 104 | 105 | Yasuhiro Matsumoto 106 | 107 | =head1 ORIGNAL AUTHOR 108 | 109 | This module is port of Perl5's Palck::App::Directory. 110 | Tatsuhiko Miyagawa is an original author of Plack::App::Directory. 111 | 112 | =end pod 113 | -------------------------------------------------------------------------------- /lib/Crust/App/File.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Crust::App::File does Callable; 3 | use Crust::MIME; 4 | use Crust::Utils; 5 | 6 | # TODO: need to set path-info for Crust::App::CGIBin etc... 7 | 8 | has Str $.root; 9 | has Str $.file; 10 | has $.content-type; # Could be Str/Callable 11 | has Str $.encoding; 12 | 13 | method should-handle(Str $file) { 14 | $file.IO.f; 15 | } 16 | 17 | method CALL-ME($env) { 18 | self.call($env); 19 | } 20 | 21 | method call(Hash $env) { 22 | start { 23 | sub { 24 | my ($file, $path-info, $error-res) = $!file || self.locate-file($env); 25 | return |$error-res if $error-res; 26 | 27 | return self.serve-path($env, $file); 28 | }.(); 29 | }; 30 | } 31 | 32 | method locate-file(Hash $env) { 33 | my $path = $env || ''; 34 | if $path ~~ /\0/ { 35 | return Nil, Nil, self!return_400; 36 | } 37 | 38 | my $docroot = $!root || "."; 39 | my @path = $path.split(/<[\\/]>/); 40 | 41 | if @path { 42 | @path.shift if @path[0] eq ''; 43 | } else { 44 | @path = "."; 45 | } 46 | 47 | if grep /^ \. ** 2 /, @path { 48 | return Nil, Nil, self!return_403; 49 | } 50 | 51 | my ($file, @path-info); 52 | while @path { 53 | my $try = IO::Spec::Unix.catfile($docroot, |@path); 54 | if self.should-handle($try) { 55 | $file = $try; 56 | last; 57 | } elsif !self.allow-path-info { 58 | last; 59 | } 60 | @path-info.unshift( @path.pop ); 61 | } 62 | unless $file { 63 | return Nil, Nil, self!return_404; 64 | } 65 | unless $file.IO.r { 66 | return Nil, Nil, self!return_403; 67 | } 68 | 69 | return $file, join("/", "", |@path-info); 70 | } 71 | 72 | method allow-path-info() { False } 73 | 74 | method serve-path(Hash $env, Str $file) { 75 | my $content-type = $!content-type || Crust::MIME.mime-type($file) || 'text/plain'; 76 | if $content-type ~~ Callable { 77 | $content-type = $content-type($file); 78 | } 79 | 80 | if $content-type ~~ /^ text '/' / { 81 | $content-type ~= "; charset=" ~ ( $!encoding || "utf-8" ); 82 | } 83 | 84 | my $fh = try { open $file, :bin } or self!return_403; 85 | 86 | return 87 | 200, 88 | [ 89 | 'Content-Type' => $content-type, 90 | 'Content-Length' => $file.IO.s, 91 | 'Last-Modified' => format-datetime-rfc1123(DateTime.new($file.IO.modified)), 92 | ], 93 | $fh, 94 | ; 95 | } 96 | 97 | method !return_403() { 98 | return 403, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['forbidden']; 99 | } 100 | method !return_400() { 101 | return 400, ['Content-Type' => 'text/plain', 'Content-Length' => 11], ['Bad Request']; 102 | } 103 | method !return_404() { 104 | return 404, ['Content-Type' => 'text/plain', 'Content-Length' => 9], ['not found']; 105 | } 106 | 107 | =begin pod 108 | 109 | =head1 NAME 110 | 111 | Crust::App::File - Serve static files from root directory 112 | 113 | =head1 SYNOPSIS 114 | 115 | > crustup -MCrust::App::File -e 'Crust::App::File.new' 116 | 117 | =head1 DESCRIPTION 118 | 119 | Crust::App::File is perl6 port of perl5 Plack::App::File. 120 | 121 | =head1 SEE ALSO 122 | 123 | L 124 | 125 | =head1 AUTHOR 126 | 127 | Shoichi Kaji 128 | 129 | =head1 ORIGNAL AUTHOR 130 | 131 | This module is port of Perl5's Palck::App::File. 132 | Tatsuhiko Miyagawa is an original author of Plack::App::File. 133 | 134 | =end pod 135 | -------------------------------------------------------------------------------- /lib/Crust/App/URLMap.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::App::URLMap does Callable; 4 | 5 | has Array $!mapping; 6 | has @!sorted-mapping; 7 | 8 | multi method map(Str $location, Callable $callable) { 9 | my $loc = $location; 10 | my Str $host = ""; 11 | if $loc ~~ /^ 'http' 's'? '://' (.*?) ('/' .*)/ { 12 | $host = $0.Str || ''; 13 | $loc = $1.Str || ''; 14 | } 15 | $loc = $loc.subst(/\/+ $/, ''); 16 | $!mapping.push: {host => $host, loc => $loc, app => $callable}; 17 | return self; 18 | } 19 | 20 | method CALL-ME($env) { 21 | self.call($env); 22 | } 23 | 24 | method call(Hash $env) { 25 | if !@!sorted-mapping { 26 | @!sorted-mapping = $!mapping.sort: { -$^a.chars,-$^a.chars }; 27 | } 28 | my $path_info = $env; 29 | my $script_name = $env; 30 | 31 | my $http_host = $env; 32 | my $server_name = $env; 33 | 34 | for @!sorted-mapping.keys -> $i { 35 | my $map = @!sorted-mapping[$i]; 36 | my $path = $path_info; # copy 37 | next unless $map.chars == 0 or 38 | $http_host eq $map or 39 | $server_name eq $map; 40 | my $loc = $map; 41 | next if $loc ne '' and $path !~~ s/^ $loc //; 42 | next if $path ne '' and $path !~~ /^ '/'/; 43 | 44 | my $orig_path_info = $env; 45 | my $orig_script_name = $env; 46 | 47 | $env = $path; 48 | $env = $script_name ~~ $loc; 49 | my @res = $map($env).result; 50 | $env = $orig_path_info; 51 | $env = $orig_script_name; 52 | return start { @res }; 53 | } 54 | 55 | return start { 56 | 404, ['Content-Type' => 'text/plain'], ["Not Found"] 57 | }; 58 | } 59 | 60 | method to-app() { 61 | sub ($env) { self.call($env) } 62 | } 63 | 64 | =begin pod 65 | 66 | =head1 NAME 67 | 68 | Crust::Middleware::URLMap - Map multiple apps in different paths 69 | 70 | =head1 SYNOPSIS 71 | 72 | use Crust::Middleware::URLMap; 73 | 74 | my $urlmap = sub { ... }; # your app 75 | $urlmap = ::('Crust::Middleware::URLMap').new($app); 76 | $urlmap.map "/", sub { ... }; 77 | $urlmap.to-app; 78 | 79 | =head1 DESCRIPTION 80 | 81 | Crust::Middleware::URLMap privides URL map. 82 | 83 | This middleware is perl6 port of L. 84 | 85 | =head1 AUTHOR 86 | 87 | mattn 88 | 89 | =head1 SEE ALSO 90 | 91 | =item L 92 | 93 | =end pod 94 | -------------------------------------------------------------------------------- /lib/Crust/Builder.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Utils; 3 | use Crust::App::URLMap; 4 | use Crust::Middleware::Conditional; 5 | 6 | unit class Crust::Builder; 7 | 8 | has @!middlewares; 9 | has $!url-map; 10 | 11 | multi method add-middleware(Str $middleware, |opts) { 12 | my $middleware-class = load-class($middleware, 'Crust::Middleware'); 13 | self.add-middleware(sub ($app) { 14 | ::($middleware-class).new($app, |opts); 15 | }); 16 | } 17 | 18 | multi method add-middleware(Callable $middleware) { 19 | @!middlewares.push($middleware); 20 | } 21 | 22 | multi method add-middleware-if(Callable $condition, Str $middleware, *%args) { 23 | my $middleware-class = load-class($middleware, 'Crust::Middleware'); 24 | self.add-middleware-if($condition, sub ($app) { 25 | ::($middleware-class).new($app, |%args); 26 | }); 27 | } 28 | 29 | multi method add-middleware-if(Callable $condition, Callable $middleware) { 30 | @!middlewares.push(sub ($app) { 31 | Crust::Middleware::Conditional.new($app, :condition($condition), :builder($middleware)); 32 | }); 33 | } 34 | 35 | method mount(Str $location, Callable $app) { 36 | unless $!url-map.defined { 37 | $!url-map = Crust::App::URLMap.new; 38 | } 39 | 40 | $!url-map.map($location, $app); 41 | } 42 | 43 | method to-app(Callable $app) { 44 | if $app.defined { 45 | self.wrap($app) 46 | } elsif $!url-map.defined { 47 | $!url-map = $!url-map.to-app; 48 | self.wrap($!url-map); 49 | } else { 50 | die "to-app() is called without mount(). No application to build."; 51 | } 52 | } 53 | 54 | method wrap(Callable $app) returns Callable { 55 | if $!url-map.defined && $app !~~ $!url-map { 56 | die "WARNING: wrap() and mount() can't be used altogether in Crust::Builder.\n" ~ 57 | "WARNING: This causes all previous mount() mappings to be ignored."; 58 | } 59 | 60 | my Callable $_app = $app; 61 | for @!middlewares.reverse -> $mw { 62 | $_app = $mw.($_app); 63 | } 64 | 65 | return $_app; 66 | } 67 | 68 | ### DSL 69 | 70 | my $_add = my $_add-if = my $_mount = sub (|) { 71 | die "enable/mount should be called inside builder {} block"; 72 | } 73 | 74 | sub enable($middleware, |opts) is export { 75 | $_add.($middleware, |opts); 76 | } 77 | 78 | sub enable-if(Callable $condition, $middleware, |opts) is export { 79 | $_add-if.($condition, $middleware, |opts); 80 | } 81 | 82 | sub mount(Str $location, Callable $block) is export { 83 | $_mount.($location, $block); 84 | } 85 | 86 | sub builder(Callable $block) is export { 87 | my $builder = Crust::Builder.new; 88 | 89 | my $mount-is-called; 90 | my $url-map = Crust::App::URLMap.new; 91 | 92 | temp $_mount = sub (Str $location, Callable $block) { 93 | $mount-is-called++; 94 | $url-map.map($location, $block); 95 | return $url-map; 96 | }; 97 | 98 | temp $_add = sub ($middleware, |opts) { 99 | $builder.add-middleware($middleware, |opts); 100 | }; 101 | 102 | temp $_add-if = sub (Callable $condition, $middleware, |opts) { 103 | $builder.add-middleware-if($condition, $middleware, |opts); 104 | }; 105 | 106 | my $app = $block.(); 107 | 108 | if $mount-is-called { 109 | if $app !~~ $url-map { 110 | die "WARNING: You used mount() in a builder block, but the last line (app) isn't using mount().\n" ~ 111 | "WARNING: This causes all mount() mappings to be ignored.\n"; 112 | } else { 113 | $app = $app.to-app; 114 | } 115 | } 116 | 117 | $builder.to-app($app); 118 | } 119 | 120 | =begin pod 121 | 122 | =head1 NAME 123 | 124 | Crust::Builder - Utility to enable Crust middlewares 125 | 126 | =head1 SYNOPSIS 127 | 128 | # in .p6w 129 | use Crust::Builder; 130 | 131 | my $app = sub { ... }; 132 | 133 | builder { 134 | enable "AccessLog", format => "combined"; 135 | enable "ContentLength"; 136 | enable "+My::Crust::Middleware"; 137 | $app; 138 | }; 139 | 140 | # use URLMap 141 | builder { 142 | mount "/foo", builder { 143 | enable "Foo"; 144 | $app; 145 | }; 146 | 147 | mount "/bar", $app2; 148 | mount "http://example.com/", builder { $app3 }; 149 | }; 150 | 151 | # using OO interface 152 | my $builder = Crust::Builder.new; 153 | $builder.add-middleware('Foo', opt => 1); 154 | $builder.add-middleware('Bar'); 155 | $builder.wrap($app); 156 | 157 | =head1 DESCRIPTION 158 | 159 | Crust::Builder gives you a quick domain specific language (DSL) to 160 | wrap your application with Crust::Middleware. 161 | This utility is inspired by L. 162 | 163 | Whenever you call C on any middleware, the middleware app is 164 | pushed to the stack inside the builder, and then reversed when it 165 | actually creates a wrapped application handler. 166 | C<"Crust::Middleware::"> is added as a prefix by default. So: 167 | 168 | builder { 169 | enable "Foo"; 170 | enable "Bar", opt => "val"; 171 | $app; 172 | }; 173 | 174 | is syntactically equal to: 175 | 176 | $app = Crust::Middleware::Bar.new($app, opt => "val"); 177 | $app = Crust::Middleware::Foo.new($app); 178 | 179 | In other words, you're supposed to C middleware from outer to inner. 180 | 181 | =head1 INLINE MIDDLEWARE 182 | 183 | Crust::Builder allows you to code middleware inline using a nested 184 | code reference. 185 | 186 | If the first argument to C is a code reference, it will be 187 | passed an C<$app> and should return another code reference 188 | which is a P6W application that consumes C<%env> at runtime. So: 189 | 190 | builder { 191 | enable sub ($app) { 192 | return sub (%env) { 193 | # do preprocessing 194 | my @res = $app(%env); 195 | # do postprocessing 196 | return @res; 197 | }; 198 | }; 199 | $app; 200 | }; 201 | 202 | =head1 URLMap support 203 | 204 | Crust::Builder has a native support for L via the C method. 205 | 206 | use Crust::Builder; 207 | my $app = builder { 208 | mount "/foo", $app1; 209 | mount "/bar", builder { 210 | enable "Foo"; 211 | $app2; 212 | }; 213 | }; 214 | 215 | See L's C method to see what they mean. With 216 | C you can't use C as a DSL, for the obvious reason :) 217 | 218 | B: Once you use C in your builder code, you have to use 219 | C for all the paths, including the root path (C). You can't 220 | have the default app in the last line of C like: 221 | 222 | my $app = sub (%env) { 223 | ... 224 | }; 225 | 226 | builder { 227 | mount "/foo", sub (%env) { ... }; 228 | $app; # THIS DOESN'T WORK 229 | }; 230 | 231 | You'll get warnings saying that your mount configuration will be 232 | ignored. Instead you should use C<< mount "/" => ... >> in the last 233 | line to set the default fallback app. 234 | 235 | builder { 236 | mount "/foo", sub (%env) { ... }; 237 | mount "/", $app; 238 | } 239 | 240 | Note that the C DSL returns a whole new P6W application, which means 241 | 242 | =item * 243 | 244 | C should normally the last statement of a C<.p6w> 245 | file, because the return value of C is the application that 246 | is actually executed. 247 | 248 | =item * 249 | 250 | You can nest your C blocks, mixed with C statements (see L 251 | above): 252 | 253 | builder { 254 | mount "/foo" => builder { 255 | mount "/bar" => $app; 256 | } 257 | } 258 | 259 | will locate the C<$app> under C, since the inner C 260 | block puts it under C and it results in a new P6W application 261 | which is located under C because of the outer C block. 262 | 263 | =head1 CONDITIONAL MIDDLEWARE SUPPORT 264 | 265 | You can use C to conditionally enable middleware based on 266 | the runtime environment. 267 | 268 | builder { 269 | enable-if -> %env { 270 | %env eq '127.0.0.1' 271 | }, 'AccessLog', format => "combined"; 272 | $app; 273 | }; 274 | 275 | See L for details. 276 | 277 | =head1 OBJECT ORIENTED INTERFACE 278 | 279 | Object oriented interface supports the same functionality with the DSL 280 | version in a clearer interface, probably with more typing required. 281 | 282 | # With mount 283 | my $builder = Crust::Builder.new; 284 | $builder.add-middleware('Foo', opt => 1); 285 | $builder.mount('/foo', $foo-app); 286 | $builder.mount('/', $root-app); 287 | $builder.to-app; 288 | 289 | # Nested builders. Equivalent to: 290 | # builder { 291 | # mount '/foo', builder { 292 | # enable 'Foo'; 293 | # $app; 294 | # }; 295 | # mount '/' => $app2; 296 | # }; 297 | 298 | my $builder-out = Crust::Builder.new; 299 | my $builder-in = Crust::Builder.new; 300 | $builder-in.add-middleware('Foo'); 301 | $builder-out.mount("/foo", $builder-in.wrap($app)); 302 | $builder-out.mount("/", $app2); 303 | $builder-out.to-app; 304 | 305 | # conditional. You can also directly use Crust::Middleware::Conditional 306 | my $builder = Crust::Builder.new; 307 | $builder.add-middleware-if(sub (%sub) { %sub eq '127.0.0.1' }, 'AccessLog'); 308 | $builder.wrap($app); 309 | 310 | =head1 AUTHOR 311 | 312 | moznion 313 | 314 | =head1 SEE ALSO 315 | 316 | =item L 317 | 318 | =item L 319 | 320 | =item L 321 | 322 | =end pod 323 | 324 | -------------------------------------------------------------------------------- /lib/Crust/Handler.pod: -------------------------------------------------------------------------------- 1 | =begin pod 2 | 3 | =head1 NAME 4 | 5 | Crust::Handler - Connects P6W applications and Web servers 6 | 7 | =head1 SYNOPSIS 8 | 9 | use v6; 10 | unit class Crust::Handler::AwesomeWebServer; 11 | 12 | method new(*%opt) { 13 | return self.bless(|%opt); 14 | } 15 | 16 | method run(Crust::Handler::AwesomeWebServer:D: Callable $app) { 17 | # launch the AwesomeWebServer and run $app in the loop 18 | } 19 | 20 | # then from command line 21 | crustup -s AwesomeWebServer -a app.p6w 22 | 23 | 24 | =head1 DESCRIPTION 25 | 26 | Crust::Handler defines an adapter (connector) interface to adapt L and L to various P6W web servers, such as FCGI and Standalone for HTTP::Server::PSGI. 27 | 28 | It is an empty class, and as long as they implement the methods defined as an Server adapter interface, they do not need to inherit Crust::Handler. 29 | 30 | If you write a new handler for existing web servers, I recommend you to include the full name of the server module after Crust::Handler prefix, like Crust::Handler::Net::Server::Coro if you write a handler for Net::Server::Coro. That way you'll be using plackup command line option like: 31 | 32 | plackup -s Net::Server::Coro 33 | 34 | that makes it easy to figure out which web server you're going to use. 35 | 36 | =end pod 37 | -------------------------------------------------------------------------------- /lib/Crust/Handler/FastCGI.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Handler::FastCGI; 4 | 5 | require FastCGI::NativeCall; 6 | require FastCGI::NativeCall::PSGI; 7 | 8 | has $!psgi; 9 | 10 | method new(*%args) { 11 | my $socket = %args // %*ENV // '/var/www/run/p6w-fcgi.sock'; 12 | my $backlog = %args // %*ENV // 5; 13 | self.bless()!initialize(:$socket, :$backlog); 14 | } 15 | 16 | method !initialize(:$socket, :$backlog) { 17 | my $sock = &::("FastCGI::NativeCall::OpenSocket")($socket, $backlog); 18 | $!psgi = ::("FastCGI::NativeCall::PSGI").new(::("FastCGI::NativeCall").new($sock)); 19 | self; 20 | } 21 | 22 | method run(Crust::Handler::FastCGI:D: Callable $app) { 23 | $!psgi.app($app); 24 | $!psgi.run; 25 | } 26 | 27 | =begin pod 28 | 29 | =head1 NAME 30 | 31 | Crust::Handler::FastCGI - Crust adapter for FastCGI::NativeCall::PSGI 32 | 33 | =head1 SYNOPSIS 34 | 35 | crustup \ 36 | -s FastCGI -MFastCGI::NativeCall -MFastCGI::NativeCall::PSGI \ 37 | [--socket /PATH/TO/APP.SOCK] [--backlog INT] \ 38 | app.p6w 39 | 40 | =end pod 41 | -------------------------------------------------------------------------------- /lib/Crust/Handler/HTTP/Easy.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Handler::HTTP::Easy; 4 | 5 | use HTTP::Easy::PSGI; 6 | 7 | has $!http; 8 | 9 | method new(*%args) { 10 | self.bless()!initialize(%args); 11 | } 12 | 13 | method !initialize(%args) { 14 | $!http = HTTP::Easy::PSGI.new(|%args); 15 | self; 16 | } 17 | 18 | method run(Crust::Handler::HTTP::Easy:D: Callable $app) { 19 | $!http.handle($app); 20 | } 21 | 22 | =begin pod 23 | 24 | =head1 NAME 25 | 26 | Crust::Handler::HTTP::Easy - Crust adapter for HTTP::Easy::PSGI 27 | 28 | =head1 SYNOPSIS 29 | 30 | crustup -s HTTP::Easy app.p6w 31 | 32 | =end pod 33 | -------------------------------------------------------------------------------- /lib/Crust/Handler/HTTP/Server/Tiny.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Handler::HTTP::Server::Tiny; 4 | 5 | use HTTP::Server::Tiny; 6 | 7 | has %.args; 8 | 9 | method new(*%args) { 10 | self.bless(args => %args); 11 | } 12 | 13 | method run(Crust::Handler::HTTP::Server::Tiny:D: Callable $app) { 14 | my $httpd = HTTP::Server::Tiny.new(|%!args); 15 | $httpd.run($app); 16 | } 17 | 18 | =begin pod 19 | 20 | =head1 NAME 21 | 22 | Crust::Handler::HTTP::Server::Tiny - Crust adapter for HTTP::Server::Tiny 23 | 24 | =head1 SYNOPSIS 25 | 26 | crustup -s HTTP::Server::Tiny app.p6w 27 | 28 | =end pod 29 | -------------------------------------------------------------------------------- /lib/Crust/Headers.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Headers; 4 | 5 | use Hash::MultiValue; 6 | 7 | has $!env = Hash::MultiValue.new; 8 | 9 | # $env is P6W's env header. 10 | method new(Hash $env) { 11 | self.bless()!initialize($env); 12 | } 13 | 14 | method !initialize(Hash $env) { 15 | for $env.kv -> $k, $v { 16 | self.header($k, $v); 17 | } 18 | self; 19 | } 20 | 21 | multi method header(Str $key) { 22 | return $!env{$key.lc}; 23 | } 24 | 25 | multi method header(Str $key, $val) { 26 | unless $val.defined { 27 | die "undefined value in header value: $key"; 28 | } 29 | $!env{$key.lc} = $val.Str; 30 | } 31 | 32 | method content-type() { 33 | self.header('content-type'); 34 | } 35 | 36 | method content-length() { 37 | self.header('content-length'); 38 | } 39 | 40 | method content-encoding() { 41 | self.header('content-encoding'); 42 | } 43 | 44 | method user-agent() { 45 | self.header('user-agent'); 46 | } 47 | 48 | method referer() { self.header('referer') } 49 | 50 | method Str() { 51 | $!env.all-kv.map(-> $k, $v { "$k: $v" }).join("\n"); 52 | } 53 | 54 | =begin pod 55 | 56 | =head1 NAME 57 | 58 | Crust::Headers - headers 59 | 60 | =head1 DESCRIPTION 61 | 62 | This is a container class for list of HTTP headers. 63 | 64 | =head1 METHODS 65 | 66 | =head2 C 67 | 68 | Create new instance from hash. 69 | 70 | =head2 C 71 | 72 | Get header value by C<$key>. 73 | 74 | =head2 C 75 | 76 | Set header value. 77 | 78 | =head2 C 79 | 80 | Get content-type header's value. 81 | 82 | =head2 C 83 | 84 | Get content-length header's value. 85 | 86 | =head2 C 87 | 88 | Get content-encoding header's value. 89 | 90 | =head2 C 91 | 92 | Get user-agent header's value. 93 | 94 | =head2 C 95 | 96 | Get referer header's value. 97 | 98 | =head1 AUTHORS 99 | 100 | Tokuhiro Matsuno 101 | 102 | =end pod 103 | -------------------------------------------------------------------------------- /lib/Crust/MIME.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Crust::MIME; 3 | 4 | # copy from Plack::MIME 5 | 6 | # stolen from rack.mime.rb 7 | our $MIME-TYPES = { 8 | ".3gp" => "video/3gpp", 9 | ".a" => "application/octet-stream", 10 | ".ai" => "application/postscript", 11 | ".aif" => "audio/x-aiff", 12 | ".aiff" => "audio/x-aiff", 13 | ".apk" => "application/vnd.android.package-archive", 14 | ".asc" => "application/pgp-signature", 15 | ".asf" => "video/x-ms-asf", 16 | ".asm" => "text/x-asm", 17 | ".asx" => "video/x-ms-asf", 18 | ".atom" => "application/atom+xml", 19 | ".au" => "audio/basic", 20 | ".avi" => "video/x-msvideo", 21 | ".bat" => "application/x-msdownload", 22 | ".bin" => "application/octet-stream", 23 | ".bmp" => "image/bmp", 24 | ".bz2" => "application/x-bzip2", 25 | ".c" => "text/x-c", 26 | ".cab" => "application/vnd.ms-cab-compressed", 27 | ".cc" => "text/x-c", 28 | ".chm" => "application/vnd.ms-htmlhelp", 29 | ".class" => "application/octet-stream", 30 | ".com" => "application/x-msdownload", 31 | ".conf" => "text/plain", 32 | ".cpp" => "text/x-c", 33 | ".crt" => "application/x-x509-ca-cert", 34 | ".css" => "text/css", 35 | ".csv" => "text/csv", 36 | ".cxx" => "text/x-c", 37 | ".deb" => "application/x-debian-package", 38 | ".der" => "application/x-x509-ca-cert", 39 | ".diff" => "text/x-diff", 40 | ".djv" => "image/vnd.djvu", 41 | ".djvu" => "image/vnd.djvu", 42 | ".dll" => "application/x-msdownload", 43 | ".dmg" => "application/octet-stream", 44 | ".doc" => "application/msword", 45 | ".dot" => "application/msword", 46 | ".dtd" => "application/xml-dtd", 47 | ".dvi" => "application/x-dvi", 48 | ".ear" => "application/java-archive", 49 | ".eml" => "message/rfc822", 50 | ".eps" => "application/postscript", 51 | ".exe" => "application/x-msdownload", 52 | ".f" => "text/x-fortran", 53 | ".f77" => "text/x-fortran", 54 | ".f90" => "text/x-fortran", 55 | ".flv" => "video/x-flv", 56 | ".for" => "text/x-fortran", 57 | ".gem" => "application/octet-stream", 58 | ".gemspec" => "text/x-script.ruby", 59 | ".gif" => "image/gif", 60 | ".gz" => "application/x-gzip", 61 | ".h" => "text/x-c", 62 | ".hh" => "text/x-c", 63 | ".htm" => "text/html", 64 | ".html" => "text/html", 65 | ".ico" => "image/vnd.microsoft.icon", 66 | ".ics" => "text/calendar", 67 | ".ifb" => "text/calendar", 68 | ".iso" => "application/octet-stream", 69 | ".jar" => "application/java-archive", 70 | ".java" => "text/x-java-source", 71 | ".jnlp" => "application/x-java-jnlp-file", 72 | ".jpeg" => "image/jpeg", 73 | ".jpg" => "image/jpeg", 74 | ".js" => "application/javascript", 75 | ".json" => "application/json", 76 | ".log" => "text/plain", 77 | ".m3u" => "audio/x-mpegurl", 78 | ".m4v" => "video/mp4", 79 | ".man" => "text/troff", 80 | ".manifest"=> "text/cache-manifest", 81 | ".mathml" => "application/mathml+xml", 82 | ".mbox" => "application/mbox", 83 | ".mdoc" => "text/troff", 84 | ".me" => "text/troff", 85 | ".mid" => "audio/midi", 86 | ".midi" => "audio/midi", 87 | ".mime" => "message/rfc822", 88 | ".mml" => "application/mathml+xml", 89 | ".mng" => "video/x-mng", 90 | ".mov" => "video/quicktime", 91 | ".mp3" => "audio/mpeg", 92 | ".mp4" => "video/mp4", 93 | ".mp4v" => "video/mp4", 94 | ".mpeg" => "video/mpeg", 95 | ".mpg" => "video/mpeg", 96 | ".ms" => "text/troff", 97 | ".msi" => "application/x-msdownload", 98 | ".odp" => "application/vnd.oasis.opendocument.presentation", 99 | ".ods" => "application/vnd.oasis.opendocument.spreadsheet", 100 | ".odt" => "application/vnd.oasis.opendocument.text", 101 | ".ogg" => "application/ogg", 102 | ".ogv" => "video/ogg", 103 | ".p" => "text/x-pascal", 104 | ".pas" => "text/x-pascal", 105 | ".pbm" => "image/x-portable-bitmap", 106 | ".pdf" => "application/pdf", 107 | ".pem" => "application/x-x509-ca-cert", 108 | ".pgm" => "image/x-portable-graymap", 109 | ".pgp" => "application/pgp-encrypted", 110 | ".pkg" => "application/octet-stream", 111 | ".pl" => "text/x-script.perl", 112 | ".pm" => "text/x-script.perl-module", 113 | ".png" => "image/png", 114 | ".pnm" => "image/x-portable-anymap", 115 | ".ppm" => "image/x-portable-pixmap", 116 | ".pps" => "application/vnd.ms-powerpoint", 117 | ".ppt" => "application/vnd.ms-powerpoint", 118 | ".ps" => "application/postscript", 119 | ".psd" => "image/vnd.adobe.photoshop", 120 | ".py" => "text/x-script.python", 121 | ".qt" => "video/quicktime", 122 | ".ra" => "audio/x-pn-realaudio", 123 | ".rake" => "text/x-script.ruby", 124 | ".ram" => "audio/x-pn-realaudio", 125 | ".rar" => "application/x-rar-compressed", 126 | ".rb" => "text/x-script.ruby", 127 | ".rdf" => "application/rdf+xml", 128 | ".roff" => "text/troff", 129 | ".rpm" => "application/x-redhat-package-manager", 130 | ".rss" => "application/rss+xml", 131 | ".rtf" => "application/rtf", 132 | ".ru" => "text/x-script.ruby", 133 | ".s" => "text/x-asm", 134 | ".sgm" => "text/sgml", 135 | ".sgml" => "text/sgml", 136 | ".sh" => "application/x-sh", 137 | ".sig" => "application/pgp-signature", 138 | ".snd" => "audio/basic", 139 | ".so" => "application/octet-stream", 140 | ".svg" => "image/svg+xml", 141 | ".svgz" => "image/svg+xml", 142 | ".swf" => "application/x-shockwave-flash", 143 | ".t" => "text/troff", 144 | ".tar" => "application/x-tar", 145 | ".tbz" => "application/x-bzip-compressed-tar", 146 | ".tcl" => "application/x-tcl", 147 | ".tex" => "application/x-tex", 148 | ".texi" => "application/x-texinfo", 149 | ".texinfo" => "application/x-texinfo", 150 | ".text" => "text/plain", 151 | ".tif" => "image/tiff", 152 | ".tiff" => "image/tiff", 153 | ".torrent" => "application/x-bittorrent", 154 | ".tr" => "text/troff", 155 | ".txt" => "text/plain", 156 | ".vcf" => "text/x-vcard", 157 | ".vcs" => "text/x-vcalendar", 158 | ".vrml" => "model/vrml", 159 | ".war" => "application/java-archive", 160 | ".wav" => "audio/x-wav", 161 | ".webm" => "video/webm", 162 | ".wma" => "audio/x-ms-wma", 163 | ".wmv" => "video/x-ms-wmv", 164 | ".wmx" => "video/x-ms-wmx", 165 | ".woff" => "application/font-woff", 166 | ".wrl" => "model/vrml", 167 | ".wsdl" => "application/wsdl+xml", 168 | ".xbm" => "image/x-xbitmap", 169 | ".xhtml" => "application/xhtml+xml", 170 | ".xls" => "application/vnd.ms-excel", 171 | ".xml" => "application/xml", 172 | ".xpm" => "image/x-xpixmap", 173 | ".xsl" => "application/xml", 174 | ".xslt" => "application/xslt+xml", 175 | ".yaml" => "text/yaml", 176 | ".yml" => "text/yaml", 177 | ".zip" => "application/zip", 178 | }; 179 | 180 | my $fallback = sub (Str $file) { }; 181 | 182 | method mime-type(Str $file) { 183 | $file ~~ / (\.<[a..zA..Z0..9]>+) $/ or return; 184 | $MIME-TYPES{lc $/[0]} || $fallback(lc $/[0]); 185 | } 186 | 187 | method add-type(*@ext-type) { 188 | for @ext-type.map({.kv.Slip}) -> $ext, $type { 189 | $MIME-TYPES{lc $ext} = $type; 190 | } 191 | } 192 | 193 | method set-fallback(Callable $cb) { 194 | $fallback = $cb; 195 | } 196 | 197 | 198 | =begin pod 199 | 200 | =head1 NAME 201 | 202 | Crust::MIME - MIME type registry 203 | 204 | =head1 SYNOPSIS 205 | 206 | use Crust::MIME; 207 | 208 | my $mime = Crust::MIME.mime-type(".png"); # image/png 209 | 210 | # register new type(s) 211 | Crust::MIME.add-type(".foo" => "application/x-foo"); 212 | 213 | # Use MIME::Types as a fallback 214 | use MIME::Types 'by_suffix'; 215 | Crust::MIME.set-fallback(sub ($file) { (by_suffix($file))[0] }); 216 | 217 | =head1 DESCRIPTION 218 | 219 | Crust::MIME is a perl6 port of perl5 Plack::MIME. 220 | 221 | Crust::MIME is a simple MIME type registry for Plack applications. The 222 | selection of MIME types is based on Rack's Rack::Mime module. 223 | 224 | =head1 SEE ALSO 225 | 226 | L 227 | 228 | Rack::Mime L 229 | 230 | =end pod 231 | -------------------------------------------------------------------------------- /lib/Crust/Middleware.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Middleware does Callable; 4 | 5 | has Callable $.app; 6 | 7 | method new(Callable $app, |opts) { 8 | self.bless(app => $app, |opts); 9 | } 10 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/AccessLog.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Apache::LogFormat; 4 | use Crust::Middleware; 5 | 6 | unit class Crust::Middleware::AccessLog is Crust::Middleware; 7 | 8 | has $.formatter; 9 | has &.logger; 10 | 11 | method new(Callable $app, *%opts) { 12 | my Apache::LogFormat::Formatter $formatter; 13 | given %opts { 14 | when any(!.Bool, "combined") 15 | { $formatter = Apache::LogFormat.combined } 16 | when "common" { $formatter = Apache::LogFormat.common } 17 | when Apache::LogFormat::Compiler { 18 | $formatter = %opts; 19 | } 20 | default { 21 | my $c = Apache::LogFormat::Compiler.new(); 22 | $formatter = $c.compile(%opts); 23 | } 24 | } 25 | %opts:delete; 26 | 27 | %opts = $formatter; 28 | callwith($app, |%opts); 29 | } 30 | 31 | my sub content-length(@res) { 32 | for @(@res[1]) -> $pair { 33 | if $pair.key.lc eq 'content-length' { 34 | return $pair.value; 35 | } 36 | } 37 | return "-"; 38 | } 39 | 40 | method CALL-ME(%env) { 41 | start { 42 | my $t0 = DateTime.now.Instant; 43 | my @res = await $.app()(%env); 44 | 45 | # '%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"' 46 | my $logger = $.logger; 47 | if !$logger.defined { 48 | $logger = sub ($s) { %env.emit($s) }; 49 | } 50 | 51 | my $cl = content-length(@res); 52 | my $now = DateTime.now; 53 | my $line = $.formatter().format(%env, @res, $cl, $now.Instant - $t0, $now); 54 | $logger($line); 55 | 56 | @res; 57 | }; 58 | } 59 | 60 | 61 | =begin pod 62 | 63 | =head1 NAME 64 | 65 | Crust::Middleware::AccessLog - Middleware To Generate Access Logs 66 | 67 | =head1 SYNOPSIS 68 | 69 | my &app = sub(%env) { ... }; 70 | my $code = Crust::Middleware::AccessLog.new( 71 | &app, 72 | :format('combined'), 73 | :logger(-> $s { $io.print($s) }), 74 | } 75 | 76 | Or use with builder 77 | 78 | enable 'AccessLog', :format('combined'), :logger(-> $log-line { ... }); 79 | 80 | =head1 DESCRIPTION 81 | 82 | Crust::Middleware::AccessLog forwards the request to the given app and 83 | logs request and response details to the logger callback. The format 84 | can be specified using Apache-like format strings (or C or 85 | C for the default formats). If none is specified C is 86 | used. 87 | 88 | This middleware is enabled by default when you run L as a 89 | default C environment. 90 | 91 | =head1 CONFIGURATION 92 | 93 | =item format :Str 94 | 95 | enable "AccessLog", :format('combined'); 96 | enable "AccessLog", :format('common'); 97 | enable "AccessLog", :format('%h %l %u %t "%r" %>s %b "%{Referer}i" "%{User-agent}i"'); 98 | 99 | Takes a format string (or a preset template C or C) 100 | to specify the log format. This middleware uses L to 101 | generate access_log lines. See more details on perldoc L 102 | 103 | =item logger :Callable 104 | 105 | my $logger = ...; # some logging tool 106 | enable "AccessLog", 107 | :logger(-> sub ($s) { $logger->log($s ... ) }; 108 | 109 | Sets a callback to print log message to. It prints to the C 110 | output stream by default. 111 | 112 | =head1 AUTHORS 113 | 114 | Daisuke Maki 115 | 116 | =head1 SEE ALSO 117 | 118 | L, L 119 | 120 | =end pod 121 | 122 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/Auth/Basic.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Base64; 3 | use Crust::Middleware; 4 | use Crust::Utils; 5 | 6 | unit class Crust::Middleware::Auth::Basic is Crust::Middleware; 7 | 8 | has $.realm; 9 | has $.authenticator; 10 | 11 | method unauthorized () { 12 | my $authenticate = q!Basic realm="! ~ ($.realm || "restricted area") ~ q!"!; 13 | my $body = 'Authorization required'; 14 | 15 | return start { 16 | 401, 17 | [:Content-Type("text/plain"), 18 | :Content-Length(content-length($body)), 19 | :WWW-Authenticate($authenticate)], 20 | [$body] 21 | }; 22 | } 23 | 24 | method !authenticate($user, $pass, %env) { 25 | my $a = $.authenticator; 26 | given $a { 27 | when Callable { return $a.($user, $pass, %env) } 28 | when .can("authenticate") { return $a.authenticate($user, $pass, %env) } 29 | } 30 | 31 | return False; 32 | } 33 | 34 | # TODO: make the error visible to the caller? 35 | my sub decode-token($token) { 36 | # ignore them errors 37 | CATCH { default { return } }; 38 | return (decode-base64($token, :buf).decode() || ":").split(/':'/, 2); 39 | } 40 | 41 | method CALL-ME(%env) { 42 | my $hdr = %env; 43 | if ! $hdr { 44 | return self.unauthorized() 45 | } 46 | 47 | if $hdr !~~ /:i ^ 'Basic' \s+ (\S+) \s* $/ { 48 | return self.unauthorized() 49 | } 50 | 51 | my ($user, $pass) = decode-token($0.Str); 52 | if !$user { 53 | return self.unauthorized(); 54 | } 55 | 56 | if ! $pass.defined { 57 | $pass = ''; 58 | } 59 | 60 | if ! self!authenticate($user, $pass, %env) { 61 | return self.unauthorized() 62 | } 63 | 64 | %env = $user; 65 | return $.app.(%env); 66 | } 67 | 68 | =begin pod 69 | 70 | =head1 NAME 71 | 72 | Crust::Middleware::Auth::Basic - Simple basic authentication middleware 73 | 74 | =head1 SYNOPSIS 75 | 76 | use Crust::Builder; 77 | my $app = sub { ... }; 78 | 79 | my sub authen_cb($username, $password, %env) { 80 | return $username eq 'admin' && $password eq 's3cr3t'; 81 | } 82 | 83 | builder { 84 | enable "Auth::Basic", :authenticator(\&authen_cb); 85 | $app; 86 | }; 87 | 88 | =head1 DESCRIPTION 89 | 90 | Crust::Middleware::Auth::Basic is a basic authentication handler for Crust. 91 | 92 | =head1 CONFIGURATION 93 | 94 | =item authenticator :Callable | :Object 95 | 96 | :authenticator(-> $user, $pass, %env { ... }); 97 | 98 | A callback function that takes username, password and P6W environment 99 | supplied and returns whether the authentication succeeds. Required. 100 | 101 | Authenticator can also be an object that responds to C 102 | method that takes username and password and returns boolean. 103 | 104 | =item realm :Str 105 | 106 | Realm name to display in the basic authentication dialog. Defaults to I. 107 | 108 | =head1 LIMITATIONS 109 | 110 | This middleware expects that the application has a full access to the 111 | headers sent by clients in P6W environment. That is normally the case 112 | with standalone P6W web servers . 113 | 114 | However, in a web server configuration where you can't achieve this 115 | (i.e. using your application via Apache's mod_cgi), this middleware 116 | does not work since your application can't know the value of 117 | C header. 118 | 119 | If you use Apache as a web server and CGI to run your P6W 120 | application, you can either a) compile Apache with 121 | C<-DSECURITY_HOLE_PASS_AUTHORIZATION> option, or b) use mod_rewrite to 122 | pass the Authorization header to the application with the rewrite rule 123 | like following. 124 | 125 | RewriteEngine on 126 | RewriteRule .* - [E=HTTP_AUTHORIZATION:%{HTTP:Authorization},L] 127 | 128 | =head1 AUTHOR 129 | 130 | Daisuke Maki 131 | 132 | =head1 SEE ALSO 133 | 134 | L 135 | 136 | =end pod 137 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/Conditional.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Crust::Middleware; 4 | 5 | unit class Crust::Middleware::Conditional is Crust::Middleware; 6 | 7 | has Callable $!condition; 8 | has Callable $!builder; 9 | has $!middleware; 10 | 11 | submethod BUILD(:$app, *%opts) { 12 | $!condition = %opts; 13 | $!builder = %opts; 14 | $!middleware = $!builder.($app); 15 | } 16 | 17 | method CALL-ME(%env) { 18 | if $!condition(%env) { 19 | return $!middleware(%env); 20 | } 21 | 22 | return $.app()(%env); 23 | } 24 | 25 | =begin pod 26 | 27 | =head1 NAME 28 | 29 | Crust::Middleware::Conditional - Conditional wrapper for Crust middleware 30 | 31 | =head1 SYNOPSIS 32 | 33 | use Crust::Builder; 34 | 35 | builder { 36 | enable-if -> %env { 37 | %env eq '127.0.0.1' 38 | }, "AccessLog", format => "combined"; 39 | $app; 40 | }; 41 | 42 | # or using the OO interface: 43 | use Crust::Middleware::Conditional; 44 | 45 | $app = Crust::Middleware::Conditional.new( 46 | $app, 47 | condition => -> %env { 48 | %env eq '127.0.0.1'; 49 | }, 50 | builder => -> $app { 51 | Crust::Middleware::AccessLog.new($app, format => "combined"); 52 | }, 53 | ); 54 | 55 | Or use with builder 56 | 57 | builder { 58 | enable-if -> %env { %env eq '127.0.0.1' }, 'AccessLog', :format('combined'); 59 | $app; 60 | }; 61 | 62 | =head1 DESCRIPTION 63 | 64 | Crust::Middleware::Conditional is a piece of meta-middleware, to run a 65 | specific middleware component under runtime conditions. The goal of 66 | this middleware is to avoid baking runtime configuration options in 67 | individual middleware components, and rather share them as another 68 | middleware component. 69 | 70 | This middleware is inspired by L. 71 | 72 | =head1 AUTHOR 73 | 74 | moznion 75 | 76 | =head1 SEE ALSO 77 | 78 | =item L 79 | 80 | =item L 81 | 82 | =end pod 83 | 84 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/ContentLength.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Middleware; 3 | use Crust::Utils; 4 | 5 | unit class Crust::Middleware::ContentLength is Crust::Middleware; 6 | 7 | method CALL-ME(%env) { 8 | return start { 9 | my @ret = await $.app()(%env); 10 | 11 | my %headers = %(@ret[1]); 12 | if ( 13 | !status-with-no-entity-body(@ret[0]) && 14 | !%headers.defined && 15 | !%headers.defined && 16 | (my $content-length = content-length(@ret[2])).defined 17 | ) { 18 | %headers = $content-length; 19 | } 20 | @ret[1] = [%headers]; 21 | 22 | @ret 23 | }; 24 | } 25 | 26 | =begin pod 27 | 28 | =head1 NAME 29 | 30 | Crust::Middleware::ContentLength - Adds Content-Length header automatically 31 | 32 | =head1 SYNOPSIS 33 | 34 | use Crust::Middleware::ContentLength; 35 | 36 | my $app = sub { ... }; # your app 37 | $app = Crust::Middleware::ContentLength.new($app); 38 | 39 | Or use with builder 40 | 41 | enable 'ContentLength'; 42 | 43 | =head1 DESCRIPTION 44 | 45 | Crust::Middleware::ContentLength is a middleware that automatically 46 | adds C header when it's appropriate i.e. the response 47 | has a content body with calculable size (array of chunks or a filehandle). 48 | 49 | =head1 SEE ALSO 50 | 51 | =item L 52 | 53 | =item Rack::ContentLength 54 | 55 | =head1 AUTHOR 56 | 57 | moznion 58 | 59 | =end pod 60 | 61 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/ErrorDocument.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Crust::Middleware; 4 | use Crust::MIME; 5 | use HTTP::Status; 6 | 7 | unit class Crust::Middleware::ErrorDocument is Crust::Middleware; 8 | 9 | has Hash $.errors; 10 | has Bool $.sub-request; 11 | 12 | method new(Callable $app, |opts) { 13 | my %newopts = errors => {}, sub-request => False; 14 | for opts -> $opt { 15 | my $kv = $opt.key ~~ Pair ?? $opt.key !! $opt; 16 | if $kv.key eq 'sub-request' { 17 | %newopts = $kv.value; 18 | } else { 19 | %newopts{$kv.key.Str} = $kv.value; 20 | } 21 | } 22 | callwith($app, |%newopts); 23 | } 24 | 25 | method !call(%env) { 26 | my @ret = await $.app()(%env); 27 | 28 | my %headers = %(@ret[1]); 29 | my $path = $!errors{@ret[0].Str}; 30 | if !is-error(@ret[0]) || !$path.defined { 31 | return @ret; 32 | } 33 | if $!sub-request { 34 | for %headers -> $pair { 35 | unless ($pair.key ~~ /^ p6w /) { 36 | %headers{'p6wx.errordocument.' ~ $pair.key} = $pair.value; 37 | } 38 | } 39 | %env = 'GET'; 40 | %env = $path; 41 | %env = $path; 42 | %env = ''; 43 | %env:delete; 44 | 45 | my @sub_ret = await $.app()(%env); 46 | @ret = @sub_ret if @sub_ret[0] == 200; 47 | } else { 48 | %headers:delete; 49 | %headers:delete; 50 | %headers:delete; 51 | %headers = Crust::MIME.mime-type($path); 52 | 53 | @ret[2] = open $path, :bin; 54 | } 55 | 56 | @ret[1] = [%headers]; 57 | 58 | return @ret; 59 | } 60 | 61 | method CALL-ME(%env) { start { self!call(%env) } } 62 | 63 | 64 | =begin pod 65 | 66 | =head1 NAME 67 | 68 | Crust::Middleware::ErrorDocument - Set Error Document based on HTTP status code 69 | 70 | =head1 SYNOPSIS 71 | 72 | my &app = sub(%env) { ... }; 73 | my $code = Crust::Middleware::ErrorDocument.new( 74 | &app, 75 | 500 => '/uri/error/500.html', 76 | 404 => '/uri/error/404.html', 77 | } 78 | 79 | # getting sub request 80 | $code = Crust::Middleware::ErrorDocument.new( 81 | &app, 82 | 500 => '/uri/error/500.html', 83 | 404 => '/uri/error/404.html', 84 | :sub-request => True, 85 | } 86 | 87 | =end pod 88 | 89 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/Lint.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Middleware; 3 | 4 | unit class Crust::Middleware::Lint is Crust::Middleware; 5 | 6 | my sub validate-env(%env) { 7 | unless %env { 8 | die 'Missing env param: REQUEST_METHOD'; 9 | } 10 | unless %env ~~ /^<[A..Z]>+$/ { 11 | die "Invalid env param: REQUEST_METHOD(%env)"; 12 | } 13 | unless %env.defined { # allows empty string 14 | die 'Missing mandatory env param: SCRIPT_NAME'; 15 | } 16 | if %env eq '/' { 17 | die 'SCRIPT_NAME must not be /'; 18 | } 19 | unless %env.defined { # allows empty string 20 | die 'Missing mandatory env param: PATH_INFO'; 21 | } 22 | if %env ne '' && %env !~~ m!^'/'! { 23 | die "PATH_INFO must begin with / (%env)"; 24 | } 25 | unless %env.defined { 26 | die 'Missing mandatory env param: SERVER_NAME'; 27 | } 28 | if %env eq '' { 29 | die 'SERVER_NAME must not be empty string'; 30 | } 31 | unless %env.defined { 32 | die 'Missing mandatory env param: SERVER_PORT'; 33 | } 34 | if %env eq '' { 35 | die 'SERVER_PORT must not be empty string'; 36 | } 37 | if %env.defined && %env !~~ m{^HTTP'/'\d} { 38 | die "Invalid SERVER_PROTOCOL: %env"; 39 | } 40 | 41 | # TODO validate p6w.xxx 42 | 43 | if %env { 44 | die 'HTTP_CONTENT_TYPE should not exist'; 45 | } 46 | if %env { 47 | die 'HTTP_CONTENT_LENGTH should not exist'; 48 | } 49 | } 50 | 51 | my sub validate-ret(@ret) { 52 | unless @ret == 3 { 53 | die 'Response needs to be 3 element array'; 54 | } 55 | 56 | unless @ret[0] ~~ /^\d+$/ && @ret[0] >= 100 { 57 | die "Status code needs to be an integer greater than or equal to 100: @ret[0]"; 58 | } 59 | 60 | unless @ret[1].isa(List) { 61 | die "Headers needs to be an list: @ret[1]"; 62 | } 63 | my $copy = @ret[1]; 64 | { 65 | our %this-copy = $copy; 66 | %this-copy.pairup(); 67 | CATCH { 68 | default { 69 | die 'The number of response headers needs to be even, not odd(', $copy, ')'; 70 | } 71 | } 72 | } 73 | 74 | for $copy.kv -> $i, $v { 75 | my ($key, $val) = $v.kv; 76 | 77 | if $key.lc eq 'status' { 78 | die 'Response headers MUST NOT contain a key named Status'; 79 | } 80 | if $key ~~ /[<[: \r \n]> | <[- _]>]$/ { 81 | die "Response headers MUST NOT contain a key with : or newlines, or that end in - or _: $key"; 82 | } 83 | unless $key ~~ /^<[a..z A..Z]><[0..9 a..z A..Z \- _]>*$/ { 84 | die "Response headers MUST consist only of letters, digits, _ or - and MUST start with a letter: $key"; 85 | } 86 | 87 | unless $val.defined { 88 | die 'Response headers MUST be a defined string'; 89 | } 90 | 91 | if $val ~~ /<[\o00..\o37]>/ { 92 | die "Response headers MUST NOT contain characters below octal \o37: $val"; 93 | } 94 | } 95 | 96 | my $res-body = @ret[2]; 97 | unless $res-body.isa(List) || $res-body.isa(Supply) || $res-body.isa(Channel) || $res-body.isa(IO::Handle) { 98 | die 'Body is not suitable type: ' ~ $res-body.WHAT.perl; 99 | } 100 | 101 | return @ret; 102 | } 103 | 104 | method CALL-ME(%env) { 105 | validate-env(%env); 106 | my $ret = $.app()(%env); 107 | unless $ret.isa(Promise) { 108 | die "P6W app's return value must be a Promise: " ~ $ret.WHAT.perl; 109 | } 110 | my @ret = await $ret; 111 | return start { validate-ret(@ret) }; 112 | } 113 | 114 | =begin pod 115 | 116 | =head1 NAME 117 | 118 | Crust::Middleware::Lint - Validate request and response 119 | 120 | =head1 SYNOPSIS 121 | 122 | use Crust::Middleware::Lint; 123 | 124 | my $app = sub { ... }; # your app 125 | $app = Crust::Middleware::Lint.new($app); 126 | 127 | Or from crustup 128 | 129 | crustup --lint myapp.p6w 130 | 131 | Or use with builder 132 | 133 | enable 'Lint'; 134 | 135 | =head1 DESCRIPTION 136 | 137 | Crust::Middleware::Lint is a middleware component to validate request 138 | and response environment formats. You are strongly suggested to use 139 | this middleware when you develop a new framework adapter or a new P6W 140 | web server that implements the P6W interface. 141 | 142 | This middleware is inspired by L and most of code is taken from that. 143 | 144 | =head1 AUTHOR 145 | 146 | moznion 147 | 148 | =end pod 149 | 150 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/ReverseProxy.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Middleware; 3 | 4 | unit class Crust::Middleware::ReverseProxy is Crust::Middleware; 5 | 6 | has Regex $.ip-pattern = rx{\d ** 1..3 '.' \d ** 1..3 '.' \d ** 1..3 '.' \d ** 1..3}; 7 | 8 | method CALL-ME(%env) { 9 | # in apache2 httpd.conf (RequestHeader set X-Forwarded-HTTPS %{HTTPS}s) 10 | if %env { 11 | %env = %env; 12 | } 13 | if %env && %env eq 'https' { 14 | %env = 'ON'; 15 | } 16 | if (%env && %env.uc eq 'ON') || (%env && %env.uc eq 'ON') { 17 | %env = 'https'; 18 | } 19 | my $default_port = %env eq 'https' ?? 443 !! 80; 20 | 21 | # If we are running as a backend server, the user will always appear 22 | # as 127.0.0.1. Select the most recent upstream IP (last in the list) 23 | if %env { 24 | my ($ip) = %env ~~ /(<-[, \s]>+)$/; 25 | %env = $ip; 26 | } 27 | 28 | # validate remote address 29 | if $.ip-pattern.defined && %env && %env !~~ $.ip-pattern { 30 | die sprintf 'Invalid remote address has come (got: %s, expected pattern: %s)', %env, $.ip-pattern.perl; 31 | } 32 | 33 | if %env { 34 | # in apache1 ServerName example.com:443 35 | if %env { 36 | my ($host) = %env ~~ /(<-[, \s]>+)$/; 37 | if $host ~~ /^.+ ':' (\d+)$/ { 38 | %env = $0; 39 | if %env == 443 { 40 | %env = 'https'; 41 | } 42 | } 43 | %env = $host; 44 | } 45 | 46 | my ($host) = %env ~~ /(<-[, \s]>+)$/; 47 | if $host ~~ /^.+ ':' (\d+)$/ { 48 | %env = $0; 49 | } elsif %env { 50 | # in apache2 httpd.conf (RequestHeader set X-Forwarded-Port 8443) 51 | %env = %env; 52 | $host ~= ":%env"; 53 | if %env == 443 { 54 | %env = 'https'; 55 | } 56 | } else { 57 | %env = $default_port; 58 | } 59 | %env = $host; 60 | } elsif %env { 61 | my $host = %env; 62 | if $host ~~ /^.+ ':' (\d+)$/ { 63 | %env = $0; 64 | } elsif $host ~~ /^(.+)$/ { 65 | %env = $0; 66 | %env = $default_port; 67 | } 68 | } 69 | 70 | return $.app()(%env); 71 | } 72 | 73 | =begin pod 74 | 75 | =head1 NAME 76 | 77 | Crust::Middleware::ReverseProxy - Supports app to run as a reverse proxy backend 78 | 79 | =head1 SYNOPSIS 80 | 81 | use Crust::Middleware::ReverseProxy; 82 | 83 | my $app = sub { ... }; # your app 84 | $app = Crust::Middleware::ReverseProxy.new($app); 85 | 86 | Or use with builder 87 | 88 | enable 'ReverseProxy'; 89 | 90 | =head1 DESCRIPTION 91 | 92 | Crust::Middleware::ReverseProxy resets some HTTP headers, which changed by reverse-proxy. 93 | 94 | This middleware is perl6 port of L. 95 | 96 | =head1 C validation 97 | 98 | Crust::Middleware::ReverseProxy validates C by regular expression 99 | pattern (this middleware uses C as default pattern). 100 | 101 | You can specify such pattern. Pass C argument through constructor, e.g. 102 | 103 | my $app = sub { ... }; # your app 104 | $app = Crust::Middleware::ReverseProxy.new( 105 | $app, 106 | ip-pattern => rx{'127.0.0.1'}, 107 | ); 108 | 109 | If you give undefined value to C, this middleware doesn't validate C any more. 110 | 111 | =head1 AUTHOR 112 | 113 | moznion 114 | 115 | =head1 ORIGINAL AUTHORS 116 | 117 | This module is originally written by Kazuhiro Osawa as L for L. 118 | 119 | Nobuo Danjou 120 | 121 | Masahiro Nagano 122 | 123 | Tatsuhiko Miyagawa 124 | 125 | =head1 SEE ALSO 126 | 127 | =item L 128 | 129 | =end pod 130 | 131 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/Runtime.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Middleware; 3 | 4 | unit class Crust::Middleware::Runtime is Crust::Middleware; 5 | 6 | has $.header-name = 'X-Runtime'; 7 | 8 | method CALL-ME(%env) { 9 | start { 10 | my $start = now; 11 | my @ret = await $.app()(%env); 12 | 13 | my %headers = %(@ret[1]); 14 | %headers{$.header-name} = now - $start; 15 | @ret[1] = [%headers]; 16 | 17 | @ret; 18 | }; 19 | } 20 | 21 | =begin pod 22 | 23 | =head1 NAME 24 | 25 | Crust::Middleware::Runtime - Sets an X-Runtime response header 26 | 27 | =head1 SYNOPSIS 28 | 29 | use Crust::Middleware::Runtime; 30 | 31 | my $app = sub { ... }; # your app 32 | $app = Crust::Middleware::Runtime.new($app); 33 | 34 | # or with your own header-name 35 | $app = Crust::Middleware::Runtime.new($app, :header-name); 36 | 37 | Or use with builder 38 | 39 | enable 'Runtime'; 40 | 41 | =head1 DESCRIPTION 42 | 43 | Crust::Middleware::Runtime is a middleware component that sets 44 | the application's response time (in seconds) in the I HTTP response 45 | header. 46 | 47 | =head1 OPTIONS 48 | 49 | =over 4 50 | 51 | =item header_name 52 | 53 | Name of the header. Defaults to I. 54 | 55 | =back 56 | 57 | =head1 SEE ALSO 58 | 59 | =item L 60 | 61 | =head1 AUTHOR 62 | 63 | Fayland Lam 64 | 65 | =end pod 66 | 67 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/StackTrace.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Backtrace::AsHTML; 3 | use Crust::Middleware; 4 | 5 | unit class Crust::Middleware::StackTrace is Crust::Middleware; 6 | 7 | has Bool $.no-print-errors = False; 8 | 9 | method CALL-ME(%env) { 10 | start { 11 | my @ret = sub { 12 | return await $.app()(%env); 13 | 14 | CATCH { 15 | my $trace = .backtrace; 16 | default { 17 | my $text = @$trace.map({ .Str.trim }).join("\n"); 18 | my $html = $trace.as-html; 19 | %env = $text; 20 | %env = $html; 21 | 22 | %env.emit($text) unless $.no-print-errors; 23 | if (%env || '*/*') ~~ /'html'/ { 24 | return 500, ['Content-Type' => 'text/html; charset=utf-8'], [ $html ]; 25 | } 26 | return 500, ['Content-Type' => 'text/plain; charset=utf-8'], [ $text ]; 27 | } 28 | } 29 | }(); 30 | @ret.perl.say; 31 | 32 | @ret; 33 | }; 34 | } 35 | 36 | =begin pod 37 | 38 | =head1 NAME 39 | 40 | Crust::Middleware::StackTrace - Displays stack trace when your app dies 41 | 42 | =head1 SYNOPSIS 43 | 44 | use Crust::Middleware::StackTrace; 45 | 46 | my $app = sub { ... }; # your app 47 | $app = Crust::Middleware::StackTrace.new($app); 48 | 49 | Or use with builder 50 | 51 | enable 'StackTrace'; 52 | 53 | =head1 DESCRIPTION 54 | 55 | Crust::Middleware::StackTrace catches exceptions of your application 56 | and shows detailed stack trace for each exceptions. 57 | 58 | The stack trace is also stored in the environment as a plaintext and HTML under the key 59 | C and C respectively, so 60 | that middleware further up the stack can reference it. 61 | 62 | =head1 CONFIGURATION 63 | 64 | =item C 65 | 66 | $app = ::('Crust::Middleware::StackTrace').new(app => $app, no-print-errors => True); 67 | 68 | Skips printing the text stacktrace to console (C). 69 | Defaults to False, which means the text version of the 70 | stack trace error is printed to the errors handle, which usually is a 71 | standard error. 72 | 73 | =head1 SEE ALSO 74 | 75 | =item L 76 | 77 | =head1 AUTHOR 78 | 79 | moznion 80 | 81 | =end pod 82 | 83 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/Static.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::App::File; 3 | use Crust::Middleware; 4 | 5 | unit class Crust::Middleware::Static is Crust::Middleware; 6 | 7 | has $.file; 8 | has $.path; 9 | has $.root; 10 | has $.encoding; 11 | has $.pass-through; 12 | has $.content-type; 13 | 14 | submethod BUILD(:$!path, :$!root, :$!encoding, :$!content-type, :$!pass-through) { 15 | $!path //= sub ($path, %env) { return True, $path }; 16 | $!root //= "."; 17 | $!encoding //= "iso-8859-1"; 18 | $!content-type //= ""; 19 | $!file = Crust::App::File.new( 20 | :root($!root), 21 | :encoding($!encoding), 22 | :content-type($!content-type), 23 | ); 24 | } 25 | 26 | method CALL-ME(%env) { 27 | my @res = self!handle-static(%env); 28 | if @res && ! ($.pass-through && @res[0] == 404) { 29 | return start { @res }; 30 | } 31 | 32 | return $.app.(%env); 33 | } 34 | 35 | method !handle-static(%env) { 36 | my $path_match = $.path; 37 | if ! $path_match.defined { 38 | return (); 39 | } 40 | 41 | my $path = %env; 42 | my $proceed; 43 | 44 | given $path_match { 45 | when Regex { $proceed = $path ~~ $path_match } 46 | when Callable { ($proceed, $path) = $path_match($path, %env) } 47 | } 48 | 49 | if !$proceed { 50 | return (); 51 | } 52 | 53 | temp %env = $path; 54 | my @res = await $!file.(%env); 55 | return @res; 56 | } 57 | -------------------------------------------------------------------------------- /lib/Crust/Middleware/XFramework.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Middleware; 3 | 4 | unit class Crust::Middleware::XFramework is Crust::Middleware; 5 | 6 | has $.framework; 7 | 8 | method CALL-ME(%env) { 9 | start { 10 | my @ret = await $.app()(%env); 11 | 12 | if $.framework { 13 | my %headers = %(@ret[1]); 14 | %headers = $.framework; 15 | @ret[1] = [%headers]; 16 | } 17 | 18 | @ret; 19 | }; 20 | } 21 | 22 | =begin pod 23 | 24 | =head1 NAME 25 | 26 | Crust::Middleware::XFramework - Sets an X-Framework response header 27 | 28 | =head1 SYNOPSIS 29 | 30 | use Crust::Middleware::XFramework; 31 | 32 | my $app = sub { ... }; # your app 33 | $app = Crust::Middleware::XFramework.new($app, :framework); 34 | 35 | Or use with builder 36 | 37 | enable 'XFramework', :framework; 38 | 39 | =head1 DESCRIPTION 40 | 41 | Crust::Middleware::XFramework is a middleware component that sets the name of 42 | the Web application framework on which your application runs response in the 43 | I HTTP response header. 44 | 45 | This middleware is inspired by L. 46 | 47 | =head1 AUTHOR 48 | 49 | Kentaro Kuribayashi 50 | 51 | =end pod 52 | -------------------------------------------------------------------------------- /lib/Crust/Request.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Request; 4 | 5 | use URI::Escape; 6 | use Hash::MultiValue; 7 | use HTTP::MultiPartParser; 8 | use Crust::Headers; 9 | use Crust::Utils; 10 | use Crust::Request::Upload; 11 | use File::Temp; # tempfile 12 | use Cookie::Baker; 13 | 14 | has Hash $.env; 15 | has Crust::Headers $headers; 16 | 17 | method new(Hash $env) { 18 | self.bless(env => $env); 19 | } 20 | 21 | method address() { $.env } 22 | method remote-host() { $.env } 23 | method protocol() { $.env } 24 | method method() { $.env } 25 | method port() { $.env } 26 | method user() { $.env } 27 | method request-uri() { $.env } 28 | method path-info() { $.env } 29 | method path() { $.env || '/' } 30 | method query-string() { $.env } 31 | method script-name() { $.env } 32 | method scheme() { $.env } 33 | method secure() { $.scheme eq 'https' } 34 | method body() { $.env } 35 | method input() { $.env } 36 | 37 | method content-length() { $.env } 38 | method content-type() { $.env } 39 | 40 | method session() { $.env } 41 | method session-options() { $.env } 42 | method logger() { $.env } 43 | 44 | # TODO cache 45 | method query-parameters() { 46 | my Str $query_string = $.env; 47 | my @pairs = $query_string.defined 48 | ?? parse-uri-query($query_string) 49 | !! (); 50 | return Hash::MultiValue.from-pairs(|@pairs); 51 | } 52 | 53 | my sub parse-uri-query(Str $query_string is copy) { 54 | $query_string = $query_string.subst(/^<[&;]>+/, ''); 55 | my @pairs; 56 | for $query_string.split(/<[&;]>+/) { 57 | if $_ ~~ /\=/ { 58 | my ($k, $v) = @($_.split(/\=/, 2)); 59 | @pairs.push(uri_unescape($k) => uri_unescape($v)); 60 | } else { 61 | @pairs.push($_ => ''); 62 | } 63 | } 64 | return @pairs; 65 | } 66 | 67 | method headers() { 68 | unless $!headers.defined { 69 | $!env.keys ==> grep { 70 | m:i/^(HTTP|CONTENT)/ 71 | } ==> map { 72 | my $field = $_.subst(/^HTTPS?_/, '').subst(/_/, '-', :g); 73 | $field => $!env{$_} 74 | } ==> my %src; 75 | $!headers = Crust::Headers.new(%src); 76 | } 77 | return $!headers; 78 | } 79 | 80 | method header(Str $name) { 81 | $!headers.header($name); 82 | } 83 | 84 | method content() { 85 | # TODO: we should support buffering in Crust layer 86 | my $input = $!env; 87 | $input.seek(0, SeekFromBeginning); # rewind 88 | my Blob $content = $input.slurp-rest(:bin); 89 | return $content; 90 | } 91 | 92 | method user-agent() { self.headers.user-agent } 93 | 94 | method content-encoding() { self.headers.content-encoding } 95 | 96 | method referer() { self.headers.referer } 97 | 98 | method body-parameters() { 99 | $!env //= do { 100 | if self.content-type { 101 | my ($type, %opts) = parse-header-item(self.content-type); 102 | given $type { 103 | when 'application/x-www-form-urlencoded' { 104 | my @q = parse-uri-query(self.content.decode('ascii')); 105 | Hash::MultiValue.from-pairs(@q); 106 | } 107 | when 'multipart/form-data' { 108 | my ($params, $uploads) = self!parse-multipart-parser(%opts.encode('ascii')); 109 | $!env = $uploads; 110 | $params; 111 | } 112 | default { 113 | Hash::MultiValue.new 114 | } 115 | } 116 | } else { 117 | Hash::MultiValue.new 118 | } 119 | } 120 | } 121 | 122 | method uploads() { 123 | unless $!env:exists { 124 | self.body-parameters(); 125 | $!env //= Hash::MultiValue.new; 126 | } 127 | return $!env; 128 | } 129 | 130 | method !parse-multipart-parser(Blob $boundary) { 131 | my $headers; 132 | my Blob $content = Buf.new; 133 | my @parameters; 134 | my ($first, %opts); 135 | my @uploads; 136 | my ($tempfilepath, $tempfilefh); 137 | my $parser = HTTP::MultiPartParser.new( 138 | boundary => $boundary, 139 | on_header => sub ($h) { 140 | @$h ==> map { 141 | parse-header-line($_) 142 | } ==> my @pairs; 143 | $headers = Hash::MultiValue.from-pairs: |@pairs; 144 | my ($cd) = $headers; 145 | die "missing content-disposition header in multipart" unless $cd; 146 | ($first, %opts) = parse-header-item($cd); 147 | if %opts:exists { 148 | ($tempfilepath, $tempfilefh) = tempfile(); 149 | } 150 | }, 151 | on_body => sub (Blob $chunk, Bool $final) { 152 | if %opts:exists { 153 | $tempfilefh.write($chunk); 154 | } else { 155 | $content ~= $chunk; 156 | } 157 | 158 | if $final { 159 | if %opts:exists { 160 | my $filename = %opts; 161 | 162 | @uploads.push( 163 | %opts => Crust::Request::Upload.new( 164 | filename => %opts, 165 | headers => $headers, 166 | path => $tempfilepath.IO, 167 | fh => $tempfilefh, 168 | ) 169 | ); 170 | } else { 171 | @parameters.push(%opts => $content.subbuf(0)); 172 | } 173 | $content = Buf.new; 174 | $headers = Nil; 175 | } 176 | }, 177 | on_error => sub (Str $err) { 178 | # TODO: throw Bad Request 179 | die "Error while parsing multipart(boundary:{$boundary.decode('ascii')}):$err"; 180 | }, 181 | ); 182 | $parser.parse(self.content); 183 | $parser.finish(); 184 | my $params = Hash::MultiValue.from-pairs: @parameters; 185 | return $params, Hash::MultiValue.from-pairs(@uploads); 186 | } 187 | 188 | method parameters() { 189 | $!env //= do { 190 | my Hash::MultiValue $q = self.query-parameters(); 191 | my Hash::MultiValue $b = self.body-parameters(); 192 | 193 | my @pairs = |$q.all-pairs; 194 | @pairs.push(|$b.all-pairs); 195 | Hash::MultiValue.from-pairs(|@pairs); 196 | }; 197 | } 198 | 199 | method base() { 200 | self!uri-base; 201 | } 202 | 203 | method uri() { 204 | my $base = self!uri-base; 205 | 206 | # We have to escape back PATH_INFO in case they include stuff like 207 | # ? or # so that the URI parser won't be tricked. However we should 208 | # preserve '/' since encoding them into %2f doesn't make sense. 209 | # This means when a request like /foo%2fbar comes in, we recognize 210 | # it as /foo/bar which is not ideal, but that's how the p6w PATH_INFO 211 | # spec goes and we can't do anything about it. 212 | 213 | # See RFC 3986 before modifying. 214 | my $path_escape_class = rx!(<-[/;:@&= A..Z a..z 0..9 \$_.+!*'(),-]>)!; 215 | 216 | my $path = ($.env// '').subst( 217 | $path_escape_class, -> $/ { $/[0].Str.ord.fmt('%%%02X') } 218 | ); 219 | if $.env.defined && $.env ne '' { 220 | $path ~= '?' ~ $.env 221 | } 222 | 223 | if $path ~~ m/^\// { 224 | $base .= subst(/\/$/, ''); 225 | } 226 | 227 | return $base ~ $path; 228 | } 229 | 230 | method !uri-base() { 231 | return ($!env || "http") ~ 232 | "://" ~ 233 | ($!env || (($!env || "") ~ ":" ~ ($!env || 80))) ~ 234 | ($!env || '/'); 235 | } 236 | 237 | method cookies() { 238 | return {} unless $!env; 239 | 240 | if $!env && $!env eq $!env { 241 | return $!env; 242 | } 243 | 244 | my $parsed = crush-cookie($!env); 245 | $!env = $parsed; 246 | $!env = $!env; 247 | return $parsed; 248 | } 249 | 250 | =begin pod 251 | 252 | =head1 NAME 253 | 254 | Crust::Request - Request object 255 | 256 | =head1 DESCRIPTION 257 | 258 | P6W request object 259 | 260 | =head1 METHODS 261 | 262 | =head2 C 263 | 264 | Create new instance of this class by P6W's env. 265 | 266 | =head2 C }> 267 | =head2 C }> 268 | =head2 C }> 269 | =head2 C }> 270 | =head2 C }> 271 | =head2 C }> 272 | =head2 C }> 273 | =head2 C }> 274 | =head2 C || '/' }> 275 | =head2 C }> 276 | =head2 C }> 277 | =head2 C }> 278 | =head2 C 279 | =head2 C }> 280 | =head2 C }> 281 | =head2 C }> 282 | =head2 C }> 283 | =head2 C }> 284 | =head2 C }> 285 | =head2 C }> 286 | 287 | Short-hand to access. 288 | 289 | =head2 C 290 | 291 | Get parsing result of QUERY_STRING in L. 292 | 293 | =head2 C 294 | 295 | Get a instance of L. 296 | 297 | =head2 C 298 | 299 | Get header value by C<$name>. 300 | 301 | =head2 C 302 | 303 | Get C header value. 304 | 305 | =head2 C 306 | 307 | Get C header value. 308 | 309 | =head2 C 310 | 311 | Get C header value. 312 | 313 | =head2 C 314 | 315 | Return parsing result of content-body. 316 | 317 | Current implementation supports application/x-www-form-urlencoded and multipart/form-data. 318 | 319 | Return value's type is Hash::MultiValue. 320 | 321 | =head2 C 322 | 323 | Get uploaded file map in Hash::MultiValue. This hash's values are instance of L. 324 | 325 | =head2 C 326 | 327 | Get merged result of C and C. 328 | 329 | =head2 C 330 | 331 | Returns the base path of current request. This is 332 | like "uri" but only contains up to "SCRIPT_NAME" where your 333 | application is hosted at. 334 | 335 | =head2 C 336 | 337 | Returns the current request URI. 338 | 339 | The URI is constructed 340 | using various environment values such as "SCRIPT_NAME", "PATH_INFO", 341 | "QUERY_STRING", "HTTP_HOST", "SERVER_NAME" and "SERVER_PORT" 342 | 343 | =head2 C 344 | 345 | Get parsing result of cookies. 346 | 347 | =head1 AUTHOR 348 | 349 | Tokuhiro Matsuno 350 | 351 | =head1 ORIGINAL AUTHOR 352 | 353 | This file is port of Plack's. 354 | Plack::Request is written by 355 | 356 | =item Tatsuhiko Miyagawa 357 | 358 | =item Kazuhiro Osawa 359 | 360 | =item Tokuhiro Matsuno 361 | 362 | =end pod 363 | -------------------------------------------------------------------------------- /lib/Crust/Request/Upload.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Request::Upload; 4 | 5 | has Str $.filename; 6 | has $.headers; 7 | has IO::Path $.path; 8 | has IO::Handle $!fh; 9 | 10 | submethod BUILD(:$!filename, :$!headers, :$!path, :$!fh) {} 11 | 12 | =begin pod 13 | 14 | =head1 NAME 15 | 16 | Crust::Request::Upload - handles file upload requests 17 | 18 | =head1 METHODS 19 | 20 | =head2 filename 21 | 22 | filename of the uploaded content. 23 | 24 | =head2 headers 25 | 26 | Returns headers for the part. 27 | 28 | =head2 path 29 | 30 | Returns the path to the temporary file where uploaded file is saved. 31 | 32 | =end pod 33 | -------------------------------------------------------------------------------- /lib/Crust/Response.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Response; 4 | 5 | has int $.status; 6 | has Array $.headers; 7 | has $.body; 8 | 9 | method finalize() { 10 | return $.status, $.headers, $.body; 11 | } 12 | 13 | -------------------------------------------------------------------------------- /lib/Crust/Runner.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class Crust::Runner; 4 | 5 | use Getopt::Tiny; 6 | use MONKEY-SEE-NO-EVAL; 7 | 8 | has @!inc; 9 | 10 | has &!app; 11 | has %!options = host => '127.0.0.1', port => 5000; 12 | has @!args; 13 | 14 | has Bool $!accesslog; 15 | has @!modules; 16 | has Str $!eval; 17 | has Bool $!lint; 18 | has Str $!server = 'HTTP::Server::Tiny'; 19 | 20 | method parse-options(@args) { 21 | my $opts = { 22 | I => [], 23 | M => [], 24 | s => 'HTTP::Server::Tiny', 25 | }; 26 | 27 | my Bool $version; 28 | 29 | @args = Getopt::Tiny.new(:pass-through) 30 | .str( 'e', Nil, { $!eval = $^a }) 31 | .str( 'I', Nil, { @!inc.push: $^a }) 32 | .str( 'M', Nil, { @!modules.push: $^a }) 33 | .bool(Nil, 'accesslog', { $!accesslog = $^a }) 34 | .bool(Nil, 'lint', { $!lint = $^a }) 35 | .bool('v', 'version', { $version = $^a }) 36 | .str( 'h', 'host', { %!options{'host'} = $^a }) 37 | .int( 'p', 'port', { %!options{'port'} = $^a }) 38 | .str( 's', 'server', { $!server = $^a }) 39 | .parse(@args); 40 | 41 | if $version { 42 | say "perl6 version {$*PERL.compiler.version} built on {$*VM.name} version {$*VM.version}"; 43 | # TODO: show crust's version. but I don't know how to get it. 44 | exit 1; 45 | } 46 | 47 | while @args { 48 | given @args[0] { 49 | when '--' { 50 | @args.shift; 51 | @!args.append: @args; 52 | last; 53 | } 54 | when /^\-\-(<-[\=]>+)\=(.*)$/ { 55 | %!options{$/[0].Str} = $/[1].Str; 56 | @args.shift; 57 | } 58 | when /^\-\-(<-[\=]>+)$/ { 59 | @args.shift; 60 | my $key = $/[0].Str; 61 | my $value = @args.shift; 62 | %!options{$key} = $value; 63 | } 64 | default { 65 | @!args.push: @args.shift; 66 | } 67 | } 68 | } 69 | 70 | for %!options.kv -> $k, $v { 71 | if $v ~~ /^<[0 .. 9]>+$/ { 72 | %!options{$k} = IntStr.new($v.Int, $v.Str); 73 | } 74 | } 75 | } 76 | 77 | method !setup() { 78 | CompUnit::RepositoryRegistry.use-repository(CompUnit::RepositoryRegistry.repository-for-spec($_)) 79 | for @!inc; 80 | for @!modules { 81 | # FIXME: workaround for Bug RT #130535 82 | # ref: https://github.com/tokuhirom/p6-Crust/pull/86 83 | EVAL "use $_"; 84 | } 85 | } 86 | 87 | method !locate-app() { 88 | if &!app { 89 | &!app 90 | } elsif $!eval { 91 | EVAL($!eval); 92 | } elsif @!args.elems > 0 { 93 | EVALFILE(@!args.shift) 94 | } else { 95 | EVALFILE('app.p6w') 96 | } 97 | } 98 | 99 | multi method run(&app) { 100 | &!app = &app; 101 | self.run(); 102 | } 103 | 104 | multi method run() { 105 | self!setup(); 106 | 107 | my &app = self!locate-app(); 108 | 109 | if $!accesslog { 110 | require Crust::Middleware::AccessLog; 111 | &app = ::('Crust::Middleware::AccessLog').new(&app); 112 | } 113 | if $!lint { 114 | require Crust::Middleware::Lint; 115 | &app = ::('Crust::Middleware::Lint').new(&app); 116 | } 117 | 118 | my $handler = "Crust::Handler::{$!server}"; 119 | # FIXME: workaround for Bug RT #130535 120 | # ref: https://github.com/tokuhirom/p6-Crust/pull/85 121 | EVAL "use $handler"; 122 | my $httpd = ::($handler).new(|%!options); 123 | $httpd.run(&app); 124 | } 125 | -------------------------------------------------------------------------------- /lib/Crust/Test.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Crust::Test; 3 | 4 | our $Impl; 5 | $Impl ||= %*ENV || "MockHTTP"; 6 | 7 | # This is not required. But perl6.beta@20151013 is broken. 8 | # perl6-m dumps core without following line. 9 | # This is workaround for the issue. We should remove following line before christmas. 10 | use Crust::Test::MockHTTP; 11 | 12 | use MONKEY-SEE-NO-EVAL; 13 | 14 | method create(Crust::Test:U: Callable $app, *@args) { 15 | my $subclass = "Crust::Test::$Impl"; 16 | 17 | # FIXME: workaround for Bug RT #130535 18 | # ref: https://github.com/tokuhirom/p6-Crust/pull/86 19 | EVAL "use $subclass"; 20 | 21 | ::($subclass).new(:$app); # @args 22 | } 23 | 24 | multi test-p6w(Callable $app, Callable $client) is export { 25 | test-p6w(:$app, :$client); 26 | } 27 | 28 | multi test-p6w(Callable :$app!, Callable :$client!) is export { 29 | my $tester = Crust::Test.create($app); 30 | my $cb = -> $req { $tester.request($req) }; 31 | $client($cb); 32 | } 33 | 34 | =begin pod 35 | 36 | =head1 NAME 37 | 38 | Crust::Test - Test P6W applications 39 | 40 | =head1 SYNOPSIS 41 | 42 | use Crust::Test; 43 | use HTTP::Request; 44 | 45 | # OO 46 | my $app = -> $env { 200,[],['hello'] }; 47 | my $test = Crust::Test.create($app); 48 | my $req = HTTP::Request.new(GET => "/"); 49 | my $res = $test.request($req); 50 | is $res.content, "hello".encode; 51 | 52 | # Functional, named parameters 53 | test-p6w 54 | app => $app, 55 | client => -> $cb { 56 | my $req = HTTP::Request.new(GET => "/"); 57 | my $res = $cb($req); 58 | is $res->content, "hello".encode; 59 | }, 60 | ; 61 | 62 | # Functional, potitional parameters 63 | test-p6w $app, -> $cb { 64 | my $req = HTTP::Request.new(GET => "/"); 65 | my $res = $cb($req); 66 | is $res->content, "hello".encode; 67 | }; 68 | 69 | =head1 DESCRIPTION 70 | 71 | Crust::Test is a port of perl5 Plack::Test. 72 | 73 | Crust::Test is a unified interface to test P6W applications using 74 | L and L objects. It also allows you to run P6W 75 | applications in various ways. The default backend is C, 76 | but you may also use any L implementation to run live HTTP 77 | requests against a web server. 78 | 79 | =head1 AUTHOR 80 | 81 | Shoichi Kaji 82 | 83 | =head1 ORIGINAL AUTHOR 84 | 85 | This file is port of Plack's Plack::Test written by Tatsuhiko Miyagawa 86 | 87 | =end pod 88 | -------------------------------------------------------------------------------- /lib/Crust/Test/MockHTTP.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Crust::Test::MockHTTP; 3 | use HTTP::Message::P6W; 4 | use HTTP::Request; 5 | use HTTP::Response; 6 | 7 | has Callable $.app; 8 | 9 | method request(HTTP::Request $req) { 10 | my $env = $req.to-p6w; 11 | $env ||= "localhost"; 12 | 13 | my $res = try { 14 | my @res = await $!app($env); 15 | HTTP::Response.from-p6w(|@res) 16 | }; 17 | unless $res { 18 | $res = HTTP::Response.from-p6w(500, [Content-Type => 'text/plain'], [ $!.Str ]); 19 | } 20 | 21 | $res.request = $req; 22 | $res; 23 | } 24 | -------------------------------------------------------------------------------- /lib/Crust/Utils.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit module Crust::Utils; 4 | 5 | use MONKEY-SEE-NO-EVAL; 6 | 7 | # internal use only. we'll change this file without notice. 8 | 9 | sub parse-header-line(Str $header) is export { 10 | $header ~~ /^ (<-[: \s]>*) \s* \: \s* (.*) $/; 11 | return $/[0].Str.lc => $/[1].Str; 12 | } 13 | 14 | sub parse-header-item(Str $header) is export { 15 | my ($first, @items) = split(/\s*\;\s*/, $header); 16 | 17 | @items ==> map { 18 | $_ .= trim; 19 | my ($k, $v) = @(.split(/\=/)); 20 | $v = $v.subst(/^\"(.*)\"$/, -> $/ { $/[0].Str }); 21 | $k => $v 22 | } ==> my %opts; 23 | return $first.trim, %opts; 24 | } 25 | 26 | sub encode-html(Str $raw) is export { 27 | return $raw.trans( 28 | [ '&', '<', '>', '"', q{'} ] => 29 | [ '&', '<', '>', '"', ''' ] 30 | ); 31 | } 32 | 33 | sub status-with-no-entity-body(Int $status) returns Bool is export { 34 | return $status < 200 || $status == 204 || $status == 304; 35 | } 36 | 37 | sub content-length($body) is export { 38 | return Nil unless $body.defined; 39 | 40 | if $body.isa(List) { 41 | my $cl = 0; 42 | for @$body -> $chunk { 43 | my $length; 44 | given $chunk { 45 | when Str { $length = $chunk.encode.elems } 46 | when Blob { $length = $chunk.elems } 47 | } 48 | $cl += $length; 49 | } 50 | return $cl; 51 | } elsif $body.isa(IO::Handle) { 52 | return $body.path.s - $body.tell; 53 | } 54 | 55 | return Nil; 56 | } 57 | 58 | multi sub load-class($class) is export { 59 | # FIXME: workaround for Bug RT #130535 60 | # ref: https://github.com/tokuhirom/p6-Crust/pull/86 61 | EVAL "use $class"; 62 | return $class; 63 | } 64 | 65 | multi sub load-class($class is copy, $prefix) is export { 66 | unless $class ~~ s/^'+'// || $class ~~ /^$prefix/ { 67 | $class = $prefix ~ '::' ~ $class; 68 | } 69 | return load-class($class); 70 | } 71 | 72 | multi sub format-datetime-rfc1123(Instant $i) is export { 73 | return format-datetime-rfc1123(DateTime.new($i)) 74 | } 75 | 76 | multi sub format-datetime-rfc1123(DateTime $dt) is export { 77 | state @mon-abbr = ; 78 | state @dow-abbr = ; 79 | 80 | my $utc = $dt.utc; 81 | return sprintf("%s %02d %s %04d %02d:%02d:%02d GMT", 82 | @dow-abbr[$utc.day-of-week - 1], 83 | $utc.day-of-month, @mon-abbr[$utc.month-1], $utc.year, 84 | $utc.hour, $utc.minute, $utc.second); 85 | } 86 | 87 | 88 | -------------------------------------------------------------------------------- /lib/HTTP/Message/P6W.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class HTTP::Message::P6W; 3 | 4 | use HTTP::Response; 5 | use HTTP::Request; 6 | use URI::Escape; 7 | use IO::Blob; 8 | use URI; 9 | 10 | sub supplier-for-io(IO::Handle $io --> Supplier) { 11 | my $supplier = Supplier.new; 12 | my $supply = $supplier.Supply; 13 | $supply.tap(-> $v { $io.say($v) }); 14 | return $supplier; 15 | } 16 | 17 | our sub req-to-p6w($req, *%args) { 18 | my $uri = $req.uri; 19 | my IO::Blob $input .= new( 20 | ( $req.content ~~ Str ?? $req.content.encode !! $req.content ) || "".encode 21 | ); 22 | 23 | my $env = { 24 | PATH_INFO => uri-unescape($uri.path.Str || '/'), 25 | QUERY_STRING => $uri.query || '', 26 | SCRIPT_NAME => '', 27 | SERVER_NAME => $uri.host, 28 | SERVER_PORT => $uri.port, 29 | SERVER_PROTOCOL => $req.protocol || 'HTTP/1.1', 30 | REMOTE_ADDR => '127.0.0.1', 31 | REMOTE_HOST => 'localhost', 32 | REMOTE_PORT => 64000.rand.Int + 1000, # not in RFC 3875 33 | REQUEST_URI => $uri.path_query || '/', # not in RFC 3875 34 | REQUEST_METHOD => $req.method, 35 | 'p6w.version' => Version.new("0.7.Draft"), 36 | 'p6w.url-scheme' => $uri.scheme eq 'https' ?? 'https' !! 'http', 37 | 'p6w.input' => $input, 38 | 'p6w.errors' => supplier-for-io($*ERR), 39 | 'p6w.multithread' => False, 40 | 'p6w.multiprocess' => False, 41 | 'p6w.run_once' => True, 42 | 'p6w.streaming' => True, 43 | 'p6w.nonblocking' => False, 44 | |%args, 45 | }; 46 | 47 | for $req.header.header-field-names -> $field { 48 | my $key = "HTTP_$field".uc; 49 | $key ~~ s:g/'-'/_/; 50 | $key ~~ s/^HTTP_// if $field ~~ /^ Content '-' [Length|Type] $/; 51 | unless $env{$key}:exists { 52 | $env{$key} = $req.field($field).Str; 53 | } 54 | } 55 | unless $env:exists { 56 | my $len = $env.data.elems; 57 | $env = $len; 58 | } 59 | 60 | if $env { 61 | $env ~~ s/^ "$env" /\//; 62 | $env ~~ s/^\/+/\//; 63 | } 64 | 65 | if !$env.defined && $req.uri.host { 66 | $env = $req.uri.host || ""; 67 | $env ~= ':' ~ $req.uri.port if $req.uri.port != $req.uri.default_port; 68 | } 69 | 70 | return $env; 71 | } 72 | 73 | our sub res-from-p6w(Int $status, Array $headers, $body) { 74 | my $res = HTTP::Response.new($status); 75 | my @http-headers; 76 | for @($headers) -> $header { 77 | # TODO support multiple value 78 | $res.field(|$header); 79 | } 80 | my Buf $buf .= new; 81 | if $body ~~ Array { 82 | for @($body) -> $elem { 83 | $buf ~= $elem ~~ Str ?? $elem.encode !! $elem; 84 | } 85 | } elsif $body ~~ IO::Handle { 86 | until $body.eof { 87 | $buf ~= $body.read(1024); 88 | } 89 | $body.close; 90 | } elsif $body ~~ Channel { 91 | while my $got = $body.receive { 92 | $buf ~= $got; 93 | } 94 | CATCH { when X::Channel::ReceiveOnClosed { } } 95 | } else { 96 | die "3rd element of response object must be instance of Array or IO::Handle or Channel"; 97 | } 98 | $res.content = $buf; 99 | $res; 100 | } 101 | 102 | BEGIN { 103 | # https://rt.perl.org/Public/Bug/Display.html?id=126341 104 | # per above ticket, add_method must be inside a BEGIN block 105 | HTTP::Request.^add_method: 'to-p6w', method (HTTP::Request:D:) { 106 | req-to-p6w(self); 107 | }; 108 | 109 | HTTP::Response.^add_method: 'from-p6w', method ( 110 | HTTP::Response:U: Int $status, Array $headers, $body) { 111 | res-from-p6w($status, $headers, $body); 112 | }; 113 | } 114 | 115 | =begin pod 116 | 117 | =head1 NAME 118 | 119 | HTTP::Message::P6W - Converts HTTP::Request and HTTP::Response from/to P6W env and response 120 | 121 | =head1 SYNOPSIS 122 | 123 | use HTTP::Message::P6W; 124 | use HTTP::Request; 125 | 126 | my $req = HTTP::Request.new(GET => "http://example.com/foo"); 127 | my $p6w-env = $req.to-p6w; 128 | 129 | my $p6w-res = 200, ['Content-Type' => 'text/plain'], ['ok']; 130 | my $res = HTTP::Response.from-p6w(|$p6w-res); 131 | 132 | =head1 DESCRIPTION 133 | 134 | HTTP::Message::P6W is perl6 port of perl5 HTTP::Message::PSGI. 135 | 136 | HTTP::Message::P6W gives you convenient methods to convert an L 137 | object to a P6W env hash and convert a P6W response arrayref to 138 | a L object. 139 | 140 | =head1 AUTHOR 141 | 142 | Shoichi Kaji 143 | 144 | =head1 ORIGINAL AUTHOR 145 | 146 | This file is port of Plack's HTTP::Message::PSGI written by Tatsuhiko Miyagawa 147 | 148 | =end pod 149 | -------------------------------------------------------------------------------- /share/#foo: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/p6-Crust/ae5e197ebc1c8d1aaffe7f4eb8e9cbde6f5ea96b/share/#foo -------------------------------------------------------------------------------- /share/baybridge.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/p6-Crust/ae5e197ebc1c8d1aaffe7f4eb8e9cbde6f5ea96b/share/baybridge.jpg -------------------------------------------------------------------------------- /share/face.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tokuhirom/p6-Crust/ae5e197ebc1c8d1aaffe7f4eb8e9cbde6f5ea96b/share/face.jpg -------------------------------------------------------------------------------- /t/Crust-App/directory.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::App::Directory; 4 | use Crust::Test; 5 | use HTTP::Request; 6 | use File::Temp; 7 | 8 | my $tempdir = tempdir; 9 | "$tempdir/hello.css".IO.spurt: q:to/EOF/; 10 | .body {} 11 | EOF 12 | "$tempdir/js".IO.mkdir; 13 | 14 | my $app = Crust::App::Directory.new( 15 | :root($tempdir), 16 | app => sub ($env) { 17 | start { 200, [], ['hello'] }; 18 | } 19 | ); 20 | my $client = -> $cb { 21 | my ($req, $res); 22 | $req = HTTP::Request.new(GET => "/hello.css"); 23 | $res = $cb($req); 24 | is $res.code, 200; 25 | is $res.field('Content-Type').Str, 'text/css; charset=utf-8'; 26 | 27 | $req = HTTP::Request.new(GET => "/js/foo.js"); 28 | $res = $cb($req); 29 | is $res.code, 404; 30 | 31 | $req = HTTP::Request.new(GET => "/js"); 32 | $res = $cb($req); 33 | is $res.code, 301; 34 | 35 | $req = HTTP::Request.new(GET => "/js/"); 36 | $res = $cb($req); 37 | is $res.code, 200; 38 | ok $res.content.decode ~~ /\/; 39 | 40 | $req = HTTP::Request.new(GET => "/"); 41 | $res = $cb($req); 42 | is $res.code, 200; 43 | ok $res.content.decode ~~ /\/; 44 | 45 | $req = HTTP::Request.new(GET => "/../"); 46 | $res = $cb($req); 47 | is $res.code, 403; 48 | }; 49 | 50 | test-p6w $app, $client; 51 | 52 | done-testing; 53 | -------------------------------------------------------------------------------- /t/Crust-App/file.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::App::File; 4 | use Crust::Test; 5 | use Crust::Utils; 6 | use HTTP::Request; 7 | use File::Temp; 8 | 9 | my $tempdir = tempdir; 10 | "$tempdir/hello.css".IO.spurt: q:to/EOF/; 11 | .body {} 12 | EOF 13 | "$tempdir/js".IO.mkdir; 14 | "$tempdir/js/foo.js".IO.spurt: q:to/EOF/; 15 | (function () { 16 | console.log("hello"); 17 | }()); 18 | EOF 19 | "$tempdir/secret".IO.spurt(""); 20 | "$tempdir/secret".IO.chmod(0o000); 21 | 22 | my $app = Crust::App::File.new(:root($tempdir)); 23 | my $client = -> $cb { 24 | my ($req, $res); 25 | $req = HTTP::Request.new(GET => "/hello.css"); 26 | $res = $cb($req); 27 | is $res.code, 200; 28 | is $res.field('Content-Type').Str, 'text/css; charset=utf-8'; 29 | is $res.field('Last-Modified'), format-datetime-rfc1123(DateTime.new("$tempdir/hello.css".IO.modified)); 30 | 31 | $req = HTTP::Request.new(GET => "/js/foo.js"); 32 | $res = $cb($req); 33 | is $res.code, 200; 34 | is $res.field('Content-Type').Str, 'application/javascript'; 35 | 36 | $req = HTTP::Request.new(GET => "/not-found"); 37 | $res = $cb($req); 38 | is $res.code, 404; 39 | is $res.content.decode, "not found"; 40 | 41 | $req = HTTP::Request.new(GET => "/"); 42 | $res = $cb($req); 43 | is $res.code, 404; 44 | is $res.content.decode, "not found"; 45 | 46 | unless $*DISTRO.is-win { 47 | $req = HTTP::Request.new(GET => "/secret"); 48 | $res = $cb($req); 49 | is $res.code, 403; 50 | 51 | $req = HTTP::Request.new(GET => "/../.ssh/id_rsa"); 52 | $res = $cb($req); 53 | is $res.code, 403; 54 | } 55 | }; 56 | 57 | test-p6w $app, $client; 58 | 59 | done-testing; 60 | -------------------------------------------------------------------------------- /t/Crust-App/urlmap.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::App::URLMap; 4 | use Crust::Test; 5 | use HTTP::Request; 6 | 7 | my $app = Crust::App::URLMap.new; 8 | $app.map: '/foo', sub ($env) { start { 200, [], ['hello'] } }; 9 | $app.map: '/bar', sub ($env) { start { 200, [], ['world'] } }; 10 | $app.map: 'http://localhost:5000/hello', sub ($env) { start { 200, [], ['こんにちわ'] } }; 11 | $app.map: 'http://127.0.0.1:5000/world', sub ($env) { start { 200, [], ['世界'] } }; 12 | $app 13 | .map('/perl6', sub ($env) { start { 200, [], ['perl6'] } }) 14 | .map('/perl5', sub ($env) { start { 200, [], ['perl5'] } }) 15 | .map('/path', sub ($env) { start { 200, [], [$env] } }); 16 | 17 | my $client = -> $cb { 18 | my ($req, $res); 19 | $req = HTTP::Request.new(GET => "/foo"); 20 | $res = $cb($req); 21 | is $res.code, 200; 22 | is $res.content.decode, "hello"; 23 | 24 | $req = HTTP::Request.new(GET => "/bar"); 25 | $res = $cb($req); 26 | is $res.code, 200; 27 | is $res.content.decode, "world"; 28 | 29 | $req = HTTP::Request.new(GET => "http://localhost:5000/hello"); 30 | $res = $cb($req); 31 | is $res.code, 200; 32 | is $res.content.decode, "こんにちわ"; 33 | 34 | $req = HTTP::Request.new(GET => "http://127.0.0.1:5000/world"); 35 | $res = $cb($req); 36 | is $res.code, 200; 37 | is $res.content.decode, "世界"; 38 | 39 | $req = HTTP::Request.new(GET => "/zoo"); 40 | $res = $cb($req); 41 | is $res.code, 404; 42 | 43 | $req = HTTP::Request.new(GET => "/perl6"); 44 | $res = $cb($req); 45 | is $res.code, 200; 46 | is $res.content.decode, "perl6"; 47 | 48 | $req = HTTP::Request.new(GET => "/perl5"); 49 | $res = $cb($req); 50 | is $res.code, 200; 51 | is $res.content.decode, "perl5"; 52 | 53 | $req = HTTP::Request.new(GET => "/path"); 54 | $res = $cb($req); 55 | is $res.content.decode, ""; 56 | $req = HTTP::Request.new(GET => "/path/"); 57 | $res = $cb($req); 58 | is $res.content.decode, "/"; 59 | $req = HTTP::Request.new(GET => "/path/bar"); 60 | $res = $cb($req); 61 | is $res.content.decode, "/bar"; 62 | $req = HTTP::Request.new(GET => "/path/bar/"); 63 | $res = $cb($req); 64 | is $res.content.decode, "/bar/"; 65 | $req = HTTP::Request.new(GET => "/pathbar"); 66 | $res = $cb($req); 67 | is $res.code, 404; 68 | }; 69 | 70 | test-p6w $app, $client; 71 | 72 | done-testing; 73 | -------------------------------------------------------------------------------- /t/Crust-Builder/basic.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Builder; 4 | use lib 't/lib/'; 5 | use SupplierBuffer; 6 | 7 | subtest { 8 | my $app = builder { 9 | enable "AccessLog", format => "combined"; 10 | enable "ContentLength"; 11 | enable sub ($app) { 12 | return sub (%env) { 13 | start { 14 | my @res = await $app(%env); 15 | @res[1].append("HELLO", "WORLD"); 16 | @res; 17 | }; 18 | } 19 | }; 20 | sub (%env) { start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello, World' ] } }; 21 | } 22 | 23 | my $buf = SupplierBuffer.new; 24 | 25 | my %env = ( 26 | :REMOTE_ADDR<127.0.0.1>, 27 | :HTTP_REFERER, 28 | :REQUEST_METHOD, 29 | :REQUEST_URI, 30 | :SERVER_PROTOCOL, 31 | "p6w.errors" => $buf.supplier, 32 | ); 33 | 34 | my $promise = $app(%env); 35 | isa-ok $promise, Promise; 36 | my @res = await $promise; 37 | my $s = $buf.result; 38 | 39 | ok $s.starts-with('127.0.0.1 - - ['), "starts with 127.0.0.1"; 40 | is @res[0], 200, "should be 200"; 41 | is %(@res[1]), "WORLD"; 42 | is %(@res[1]), "Hello, World".encode.elems; 43 | }, 'test for enable'; 44 | 45 | subtest { 46 | subtest { 47 | my $app = builder { 48 | enable-if -> %env { %env eq '127.0.0.1' }, "AccessLog", format => "combined"; 49 | enable-if -> %env { %env eq '127.0.0.1' }, "ContentLength"; 50 | enable-if -> %env { %env eq '127.0.0.1' }, sub ($app) { 51 | return sub (%env) { 52 | start { 53 | my @res = $app(%env).result; 54 | @res[1].append("HELLO", "WORLD"); 55 | @res 56 | }; 57 | } 58 | }; 59 | sub (%env) { start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello, World' ] } }; 60 | } 61 | 62 | my $buf = SupplierBuffer.new; 63 | 64 | my %env = ( 65 | :REMOTE_ADDR<127.0.0.1>, 66 | :HTTP_REFERER, 67 | :REQUEST_METHOD, 68 | :REQUEST_URI, 69 | :SERVER_PROTOCOL, 70 | "p6w.errors" => $buf.supplier, 71 | ); 72 | 73 | my @res = await $app(%env); 74 | my $s = $buf.result; 75 | 76 | ok $s.starts-with('127.0.0.1 - - ['), "starts with 127.0.0.1"; 77 | is @res[0], 200, "should be 200"; 78 | is %(@res[1]), "WORLD"; 79 | is %(@res[1]), "Hello, World".encode.elems; 80 | }, 'Truely'; 81 | 82 | subtest { 83 | my $app = builder { 84 | enable-if -> %env { %env eq '192.168.11.1' }, "AccessLog", format => "combined"; 85 | enable-if -> %env { %env eq '192.168.11.1' }, "ContentLength"; 86 | enable-if -> %env { %env eq '192.168.11.1' }, sub ($app) { 87 | return sub (%env) { 88 | start { 89 | my @res = await $app(%env); 90 | @res[1].append("HELLO", "WORLD"); 91 | @res; 92 | }; 93 | } 94 | }; 95 | sub (%env) { start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello, World' ] } }; 96 | } 97 | 98 | my $buf = SupplierBuffer.new; 99 | 100 | my %env = ( 101 | :REMOTE_ADDR<127.0.0.1>, 102 | :HTTP_REFERER, 103 | :REQUEST_METHOD, 104 | :REQUEST_URI, 105 | :SERVER_PROTOCOL, 106 | "p6w.errors" => $buf, 107 | ); 108 | 109 | my @res = await $app(%env); 110 | my $s = $buf.result; 111 | 112 | is $s, '', 'empty logging'; 113 | is @res[0], 200, "should be 200"; 114 | nok %(@res[1]).defined; 115 | nok %(@res[1]).defined; 116 | }, 'Falsy'; 117 | }, 'test for enable-if'; 118 | 119 | done-testing; 120 | 121 | -------------------------------------------------------------------------------- /t/Crust-Builder/middleware.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Builder; 5 | use Crust::Middleware::ErrorDocument; 6 | use Crust::Middleware::AccessLog; 7 | 8 | my $app = sub () { 9 | return start { 500, [], ["OK"] }; 10 | } 11 | 12 | builder { 13 | enable 'ErrorDocument', :sub-request => 'bar', 500 => 'foo.html'; 14 | enable 'AccessLog', :format('combined'), :logger(-> $log-line { ... }); 15 | $app; 16 | }; 17 | 18 | ok True; 19 | 20 | done-testing; 21 | -------------------------------------------------------------------------------- /t/Crust-Builder/mount.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Builder; 4 | use Crust::Test; 5 | use HTTP::Request; 6 | 7 | subtest { 8 | my $app = sub ($env) { 9 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello, World' ] } 10 | }; 11 | 12 | my $builder = builder { 13 | mount "/foo", builder { 14 | enable "ContentLength"; 15 | enable sub ($app) { 16 | return sub (%env) { 17 | start { 18 | my @res = await $app(%env); 19 | @res[1].append("HELLO", "WORLD"); 20 | @res; 21 | }; 22 | } 23 | }; 24 | $app; 25 | }; 26 | mount "/bar", builder { 27 | enable "ContentLength"; 28 | $app; 29 | }; 30 | }; 31 | 32 | test-p6w 33 | client => -> $cb { 34 | my $req = HTTP::Request.new( 35 | GET => '/foo', 36 | ); 37 | my $res = $cb($req); 38 | is $res.code, 200; 39 | 40 | my $header = $res.header; 41 | is-deeply $header.field('HELLO').values, ['WORLD']; 42 | is-deeply $header.field('Content-Length').values, ["Hello, World".encode.elems]; 43 | }, 44 | app => $builder; 45 | 46 | test-p6w 47 | client => -> $cb { 48 | my $req = HTTP::Request.new( 49 | GET => '/bar', 50 | ); 51 | my $res = $cb($req); 52 | is $res.code, 200; 53 | 54 | my $header = $res.header; 55 | ok !$header.field('HELLO').defined; 56 | is-deeply $header.field('Content-Length').values, ["Hello, World".encode.elems]; 57 | }, 58 | app => $builder; 59 | }, 'test for mount'; 60 | 61 | done-testing; 62 | 63 | -------------------------------------------------------------------------------- /t/Crust-Handler/HTTP-Server-Tiny.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use lib 't/lib/'; 5 | use Test::TCP; 6 | use Crust::Handler::HTTP::Server::Tiny; 7 | use HTTP::Tinyish; 8 | 9 | my $port = 15555; 10 | 11 | Thread.start({ 12 | my $handler = Crust::Handler::HTTP::Server::Tiny.new( 13 | host => '127.0.0.1', 14 | port => $port 15 | ); 16 | $handler.run(-> $env { 17 | start { 200, [], ['ok'] } 18 | }); 19 | }); 20 | 21 | wait_port($port); 22 | 23 | my $resp = HTTP::Tinyish.new().get("http://127.0.0.1:$port/"); 24 | ok $resp; 25 | is $resp, 'ok'; 26 | 27 | done-testing; 28 | 29 | exit 0; # There is no way to kill the server thread. 30 | -------------------------------------------------------------------------------- /t/Crust-Middleware/accesslog.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Middleware::AccessLog; 5 | use lib 't/lib/'; 6 | use SupplierBuffer; 7 | 8 | my &hello-app = sub (%env) { 9 | start { 404, [], ['hello'] } 10 | } 11 | 12 | sub make-check-combined-logs($buf) { 13 | return sub { 14 | my $s = $buf.result(); 15 | if ! ok($s.defined, "\$s is defined") { 16 | note $s; 17 | return; 18 | } 19 | 20 | ok $s ~~ /^ '127.0.0.1 - - [' /, "starts with 127.0.0.1"; 21 | my $v = $s.index('] "GET /apache_pb.gif HTTP/1.1" 404 - "http://www.example.com/start.html" "-"'); 22 | if ! ok($v.defined, "\$v is defined") { 23 | note $s; 24 | return; 25 | } 26 | ok($v > 0); 27 | note "# " ~ $s if %*ENV; 28 | } 29 | } 30 | 31 | sub runit (&app, &checker, %extra-env?) { 32 | my %env = ( 33 | :REMOTE_ADDR<127.0.0.1>, 34 | :HTTP_REFERER, 35 | :REQUEST_METHOD, 36 | :REQUEST_URI, 37 | :SERVER_PROTOCOL, 38 | ); 39 | 40 | if %extra-env.defined { 41 | %env = (|%env, |%extra-env); 42 | } 43 | await &app(%env); 44 | &checker(); 45 | } 46 | 47 | { 48 | my $buf = SupplierBuffer.new; 49 | my &code = Crust::Middleware::AccessLog.new(&hello-app); 50 | runit(&code, make-check-combined-logs($buf), ("p6w.errors" => $buf.supplier)); 51 | } 52 | 53 | { 54 | my $buf = SupplierBuffer.new; 55 | my &code = Crust::Middleware::AccessLog.new( 56 | &hello-app, 57 | format => "combined", 58 | ); 59 | runit(&code, make-check-combined-logs($buf), ("p6w.errors" => $buf.supplier)); 60 | } 61 | 62 | { 63 | my $buf = SupplierBuffer.new; 64 | my &code = Crust::Middleware::AccessLog.new( 65 | &hello-app, 66 | format => Nil, 67 | ); 68 | runit(&code, make-check-combined-logs($buf), ("p6w.errors" => $buf.supplier)); 69 | } 70 | 71 | { 72 | my $buf = SupplierBuffer.new; 73 | my &code = Crust::Middleware::AccessLog.new( 74 | &hello-app, 75 | format => "", 76 | ); 77 | runit(&code, make-check-combined-logs($buf), ("p6w.errors" => $buf.supplier)); 78 | } 79 | 80 | { 81 | my $buf = SupplierBuffer.new; 82 | my &code = Crust::Middleware::AccessLog.new( 83 | &hello-app, 84 | format => Nil, 85 | logger => sub { my $s = shift @_; $buf.supplier.emit($s) }, 86 | ); 87 | runit(&code, make-check-combined-logs($buf)); 88 | } 89 | 90 | 91 | done-testing; 92 | 93 | -------------------------------------------------------------------------------- /t/Crust-Middleware/auth_basic.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Builder; 4 | use Crust::Test; 5 | use HTTP::Request; 6 | 7 | my %map = ( 8 | :admin("s3cr3t"), 9 | :john("foo:bar"), 10 | ); 11 | my $app = builder { 12 | enable "Auth::Basic", 13 | :authenticator(-> $u, $p, %env { 14 | %map{$u} && %map{$u} eq $p; 15 | }); 16 | -> %env { start { 200, [:Content-Type('text/plain')], ["Hello {%env}!"] } } 17 | }; 18 | 19 | test-p6w 20 | app => $app, 21 | client => -> $cb { 22 | my ($req, $res); 23 | 24 | # No auth, should get 401 25 | $req = HTTP::Request.new(GET => "http://localhost/"); 26 | $res = $cb($req); 27 | is $res.code, 401; 28 | 29 | # Auth for admin, should get 200 30 | $req = HTTP::Request.new(GET => "http://localhost/"); 31 | $req.header.field(:Authorization('Basic YWRtaW46czNjcjN0')); 32 | $res = $cb($req); 33 | is $res.code, 200, "Should succeed"; 34 | is $res.content.decode, "Hello admin!"; 35 | 36 | # Auth for john, should get 200 37 | $req = HTTP::Request.new(GET => "http://localhost/"); 38 | $req.header.field(:Authorization('Basic am9objpmb286YmFy')); 39 | $res = $cb($req); 40 | is $res.code, 200, "Should succeed"; 41 | is $res.content.decode, "Hello john!"; 42 | 43 | # Corrupt Authorization header, should get 401 44 | $req = HTTP::Request.new(GET => "http://localhost/"); 45 | $req.header.field(:Authorization('Basic deadBEAFam9objpmb286YmFy')); 46 | $res = $cb($req); 47 | if !is $res.code, 401, "Should fail" { 48 | $res.content.decode.say; 49 | } 50 | } 51 | ; 52 | 53 | done-testing; 54 | -------------------------------------------------------------------------------- /t/Crust-Middleware/conditional.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Test; 5 | use Crust::Middleware::ContentLength; 6 | use Crust::Middleware::Conditional; 7 | 8 | subtest { 9 | my $app = sub (%env) { 10 | start { 200, [], ['hello'] } 11 | }; 12 | 13 | $app = Crust::Middleware::Conditional.new( 14 | $app, 15 | condition => -> %env { 16 | %env eq '/foo/bar' 17 | }, 18 | builder => -> $app { 19 | Crust::Middleware::ContentLength.new($app); 20 | }, 21 | ); 22 | 23 | { 24 | my @ret = await $app((PATH_INFO => '/foo/bar')); 25 | is @ret[0], 200; 26 | is-deeply @ret[1], [:Content-Length('hello'.encode('ascii').elems)]; 27 | } 28 | 29 | { 30 | my @ret = await $app((PATH_INFO => '/')); 31 | is @ret[0], 200; 32 | is-deeply @ret[1], []; 33 | } 34 | }, 'basic case'; 35 | 36 | done-testing; 37 | 38 | -------------------------------------------------------------------------------- /t/Crust-Middleware/content-length.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Middleware::ContentLength; 5 | 6 | my %env = ( 7 | :REQUEST_METHOD, 8 | :SCRIPT_NAME, 9 | :PATH_INFO, 10 | :SERVER_NAME, 11 | :SERVER_PORT<8080>, 12 | :SERVER_PROTOCOL 13 | ); 14 | 15 | subtest { 16 | my $code = Crust::Middleware::ContentLength.new( 17 | sub (%env) { 18 | start { 200, [], [ 19 | 'hello', 20 | 'goodbye', 21 | ] } 22 | } 23 | ); 24 | 25 | my @ret = await $code(%env); 26 | 27 | is @ret[0], 200; 28 | is-deeply @ret[1], [{Content-Length => 12}]; 29 | }, 'Calc Content-Length by Blob'; 30 | 31 | subtest { 32 | my $code = Crust::Middleware::ContentLength.new( 33 | sub (%env) { 34 | start { 200, [], ['hello', 'goodbye'] } 35 | } 36 | ); 37 | 38 | my @ret = await $code(%env); 39 | 40 | is @ret[0], 200; 41 | is-deeply @ret[1], [{Content-Length => 12}]; 42 | }, 'Calc Content-Length by Str'; 43 | 44 | subtest { 45 | my $io = $*PROGRAM.open; 46 | 47 | my $code = Crust::Middleware::ContentLength.new( 48 | sub (%env) { 49 | start { 200, [], $io } 50 | } 51 | ); 52 | 53 | my @ret = await $code(%env); 54 | 55 | is @ret[0], 200; 56 | # is-deeply @ret[1], [{Content-Length => 12}]; 57 | 58 | $io.close; 59 | }, 'Calc Content-Length by IO::Handle'; 60 | 61 | subtest { 62 | my $code = Crust::Middleware::ContentLength.new( 63 | sub (%env) { 64 | start { 100, [], ['hello', 'goodbye'] } 65 | } 66 | ); 67 | 68 | my @ret = await $code(%env); 69 | 70 | is @ret[0], 100; 71 | is-deeply @ret[1], []; 72 | }, 'Should not add Content-Length because status is not suitable'; 73 | 74 | subtest { 75 | my $code = Crust::Middleware::ContentLength.new( 76 | sub (%env) { 77 | start { 200, [Content-Length => 10000], ['hello', 'goodbye'] } 78 | } 79 | ); 80 | 81 | my @ret = await $code(%env); 82 | 83 | is @ret[0], 200; 84 | is-deeply @ret[1], [{Content-Length => 10000}]; 85 | }, 'Content-Length has already set'; 86 | 87 | subtest { 88 | my $code = Crust::Middleware::ContentLength.new( 89 | sub (%env) { 90 | start { 200, [Transfer-Encoding => 'chunked'], ['hello', 'goodbye'] } 91 | } 92 | ); 93 | 94 | my @ret = await $code(%env); 95 | 96 | is @ret[0], 200; 97 | is-deeply @ret[1], [{Transfer-Encoding => 'chunked'}]; 98 | }, 'Should not add Content-Length because Transfer-Encoding is set'; 99 | 100 | subtest { 101 | # XXX maybe invalid response body type... 102 | { 103 | my $code = Crust::Middleware::ContentLength.new( 104 | sub (%env) { 105 | start { 200, [], Nil } 106 | } 107 | ); 108 | 109 | my @ret = await $code(%env); 110 | 111 | is @ret[0], 200; 112 | is-deeply @ret[1], []; 113 | } 114 | 115 | { 116 | my $code = Crust::Middleware::ContentLength.new( 117 | sub (%env) { 118 | start { 200, [], 42 } 119 | } 120 | ); 121 | 122 | my @ret = await $code(%env); 123 | 124 | is @ret[0], 200; 125 | is-deeply @ret[1], []; 126 | } 127 | }, 'Should not add Content-Length because response body is not supported type'; 128 | 129 | done-testing; 130 | 131 | -------------------------------------------------------------------------------- /t/Crust-Middleware/error-document.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Middleware::ErrorDocument; 4 | use File::Temp; 5 | 6 | my $tempdir = tempdir; 7 | "$tempdir/500.html".IO.spurt: q:to/EOF/; 8 | INTERNAL SERVER ERROR! 9 | EOF 10 | "$tempdir/404.png".IO.spurt: q:to/EOF/; 11 | NOT FOUND! 12 | EOF 13 | 14 | my %env = ( 15 | :REQUEST_METHOD, 16 | :SCRIPT_NAME, 17 | :PATH_INFO, 18 | :SERVER_NAME, 19 | :SERVER_PORT<8080>, 20 | :SERVER_PROTOCOL 21 | ); 22 | 23 | subtest { 24 | my $app = Crust::Middleware::ErrorDocument.new( 25 | sub (%env) { 26 | start { 200, ['Content-Type' => 'text/plain'], ['OK'] } 27 | }, 28 | 500 => "$tempdir/500.html", 29 | 404 => "$tempdir/404.png" 30 | ); 31 | my @ret = await $app(%env); 32 | 33 | is @ret[0], 200; 34 | is-deeply @ret[1], [:Content-Type('text/plain')]; 35 | is-deeply @ret[2], ["OK"]; 36 | }, 'Status 200'; 37 | 38 | subtest { 39 | my $app = Crust::Middleware::ErrorDocument.new( 40 | sub (%env) { 41 | start { 404, ['Content-Type' => 'text/plain'], ['OK'] } 42 | }, 43 | 500 => "$tempdir/500.html", 44 | 404 => "$tempdir/404.png" 45 | ); 46 | my @ret = await $app(%env); 47 | 48 | is @ret[0], 404; 49 | is-deeply @ret[1], [:Content-Type('image/png')]; 50 | isa-ok @ret[2], IO::Handle; 51 | }, 'Status 404'; 52 | 53 | subtest { 54 | my $app = Crust::Middleware::ErrorDocument.new( 55 | sub (%env) { 56 | start { 500, ['Content-Type' => 'text/plain'], ['OK'] } 57 | }, 58 | 500 => "$tempdir/500.html", 59 | 404 => "$tempdir/404.png" 60 | ); 61 | my @ret = await $app(%env); 62 | 63 | is @ret[0], 500; 64 | is-deeply @ret[1], [:Content-Type('text/html')]; 65 | isa-ok @ret[2], IO::Handle; 66 | }, 'Status 500'; 67 | 68 | subtest { 69 | my $app = Crust::Middleware::ErrorDocument.new( 70 | sub (%env) { 71 | start { 500, ['Content-Type' => 'text/plain'], ['OK'] } 72 | }, 73 | 500 => "$tempdir/500.html", 74 | 404 => "$tempdir/404.png", 75 | :sub-request => True 76 | ); 77 | my @ret = await $app(%env); 78 | 79 | is @ret[0], 500; 80 | is-deeply @ret[1].Hash, {'p6wx.errordocument.Content-Type' => 'text/plain', :Content-Type('text/plain')}; 81 | isa-ok @ret[2], Array; 82 | }, 'Sub Request'; 83 | 84 | done-testing; 85 | -------------------------------------------------------------------------------- /t/Crust-Middleware/lint.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Middleware::Lint; 5 | 6 | my %env = ( 7 | :REQUEST_METHOD, 8 | :SCRIPT_NAME, 9 | :PATH_INFO, 10 | :SERVER_NAME, 11 | :SERVER_PORT<8080>, 12 | :SERVER_PROTOCOL 13 | ); 14 | 15 | subtest { 16 | my $code = Crust::Middleware::Lint.new( 17 | sub (%env) { 18 | start { 200, [], ['hello'] } 19 | } 20 | ); 21 | 22 | lives-ok({await $code(%env)}, 'Should work fine'); 23 | 24 | subtest { 25 | temp %env = %env; 26 | %env:delete; 27 | dies-ok({await $code(%env)}); 28 | }, 'Should die because REQUEST_METHOD is missing'; 29 | 30 | subtest { 31 | temp %env = %env; 32 | %env = '666'; 33 | dies-ok({await $code(%env)}); 34 | }, 'Should die besause REQUEST_METHOD is invalid'; 35 | 36 | subtest { 37 | temp %env = %env; 38 | %env:delete; 39 | dies-ok({await $code(%env)}); 40 | }, 'Shuold die because SCRIPT_NAME is missing'; 41 | 42 | subtest { 43 | temp %env = %env; 44 | %env = '/'; 45 | dies-ok({await $code(%env)}); 46 | }, 'Shuold die because SCRIPT_NAME equals /'; 47 | 48 | subtest { 49 | temp %env = %env; 50 | %env:delete; 51 | dies-ok({await $code(%env)}); 52 | }, 'Should die because PATH_INFO is missing'; 53 | 54 | subtest { 55 | temp %env = %env; 56 | %env = 'not-begin-with-slash'; 57 | dies-ok({await $code(%env)}); 58 | }, 'Should die because PATH_INFO is invalid'; 59 | 60 | subtest { 61 | temp %env = %env; 62 | %env:delete; 63 | dies-ok({await $code(%env)}); 64 | }, 'Should die because SERVER_NAME is missing'; 65 | 66 | subtest { 67 | temp %env = %env; 68 | %env = ''; 69 | dies-ok({await $code(%env)}); 70 | }, 'Should die because SERVER_NAME is empty'; 71 | 72 | subtest { 73 | temp %env = %env; 74 | %env:delete; 75 | dies-ok({await $code(%env)}); 76 | }, 'Should die because SERVER_PORT is missing'; 77 | 78 | subtest { 79 | temp %env = %env; 80 | %env = ''; 81 | dies-ok({await $code(%env)}); 82 | }, 'Should die because SERVER_PORT is empty'; 83 | 84 | subtest { 85 | temp %env = %env; 86 | %env = 'MY-FABULOUS-PROTOCOL'; 87 | dies-ok({await $code(%env)}); 88 | }, 'Should die because SERVER_PROTOCOL is invalid'; 89 | 90 | subtest { 91 | temp %env = %env; 92 | %env = 'text/html'; 93 | dies-ok({await $code(%env)}); 94 | }, 'Should die because HTTP_CONTENT_TYPE is existed'; 95 | 96 | subtest { 97 | temp %env = %env; 98 | %env = 666; 99 | dies-ok({await $code(%env)}); 100 | }, 'Should die because HTTP_CONTENT_LENGTH is existed'; 101 | }, 'Test for env validation'; 102 | 103 | subtest { 104 | subtest { 105 | my $code = Crust::Middleware::Lint.new( 106 | sub (%env) { 107 | start { 200, [ 108 | 'Content-Type' => 'text/plain', 109 | 'Content-Length' => 123, 110 | ], ['hello'] } 111 | } 112 | ); 113 | lives-ok({await $code(%env)}); 114 | }, 'Should work fine'; 115 | 116 | subtest { 117 | my $code = Crust::Middleware::Lint.new( 118 | sub (%env) { start { 200, [] } } 119 | ); 120 | dies-ok({await $code(%env)}); 121 | }, 'Should die because response does not have enough elements'; 122 | 123 | subtest { 124 | my $code = Crust::Middleware::Lint.new( 125 | sub (%env) { start { 'status!!', [], ['hello'] } } 126 | ); 127 | dies-ok({await $code(%env)}); 128 | }, 'Should die because response has not got a numerical status code'; 129 | 130 | subtest { 131 | my $code = Crust::Middleware::Lint.new( 132 | sub (%env) { start { 42, [], ['hello'] } } 133 | ); 134 | dies-ok({await $code(%env)}); 135 | }, 'Should die because response status code is less than 100'; 136 | 137 | subtest { 138 | my $code = Crust::Middleware::Lint.new( 139 | sub (%env) { start { 200, 'invalid-header', ['hello'] } } 140 | ); 141 | dies-ok({await $code(%env)}); 142 | }, 'Should die because response header is not Array'; 143 | 144 | subtest { 145 | my $code = Crust::Middleware::Lint.new( 146 | sub (%env) { start { 200, ['invalid'], ['hello'] } } 147 | ); 148 | dies-ok({await $code(%env)}); 149 | }, 'Should die because response header has odd elements'; 150 | 151 | subtest { 152 | my $code = Crust::Middleware::Lint.new( 153 | sub (%env) { start { 200, ['Status' => 'Fine'], ['hello'] } } 154 | ); 155 | dies-ok({await $code(%env)}); 156 | }, 'Should die because response header has status field'; 157 | 158 | subtest { 159 | { 160 | my $code = Crust::Middleware::Lint.new( 161 | sub (%env) { start { 200, ['foo:bar' => 'buz'], ['hello'] } } 162 | ); 163 | dies-ok({await $code(%env)}); 164 | } 165 | { 166 | my $code = Crust::Middleware::Lint.new( 167 | sub (%env) { start { 200, ['foobar-' => 'buz'], ['hello'] } } 168 | ); 169 | dies-ok({await $code(%env)}); 170 | } 171 | { 172 | my $code = Crust::Middleware::Lint.new( 173 | sub (%env) { start { 200, ['0foobar' => 'buz'], ['hello'] } } 174 | ); 175 | dies-ok({await $code(%env)}); 176 | } 177 | { 178 | my $code = Crust::Middleware::Lint.new( 179 | sub (%env) { start { 200, ['foo$bar' => 'buz'], ['hello'] } } 180 | ); 181 | dies-ok({await $code(%env)}); 182 | } 183 | }, 'Should die because response header has invalid field'; 184 | 185 | subtest { 186 | my $code = Crust::Middleware::Lint.new( 187 | sub (%env) { start { 200, ['something' => utf8.new(0).Str], ['hello'] } } 188 | ); 189 | dies-ok({await $code(%env)}); 190 | }, 'Should die because value of response header has invalid character'; 191 | 192 | subtest { 193 | my $code = Crust::Middleware::Lint.new( 194 | sub (%env) { start { 200, ['something' => Nil], ['hello'] } } 195 | ); 196 | dies-ok({await $code(%env)}); 197 | }, 'Should die because value of response header is undefined'; 198 | 199 | subtest { 200 | my $code = Crust::Middleware::Lint.new( 201 | sub (%env) { start { 200, [], {} } } 202 | ); 203 | dies-ok({await $code(%env)}); 204 | }, 'Should die because response body is invalid type'; 205 | }, 'Test for ret validation'; 206 | 207 | done-testing; 208 | 209 | -------------------------------------------------------------------------------- /t/Crust-Middleware/reverse-proxy.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Test; 4 | use Crust::Request; 5 | use HTTP::Request; 6 | 7 | use Crust::Middleware::ReverseProxy; 8 | 9 | sub run(Str $tag, %arg) { 10 | my %input = %arg.lines.map({|.split(rx{':' ' '?}, 2)}); 11 | 12 | test-p6w 13 | client => -> $cb { 14 | my $req = HTTP::Request.new( 15 | GET => 'http://example.com/?foo=bar', 16 | |%input, 17 | ); 18 | 19 | # FIXME [WORKAROUND] overwrite http header 'Host' 20 | # https://github.com/sergot/http-useragent/issues/85 21 | if %input.keys.first({.lc eq "host"}) -> $host { 22 | $req.field(Host => %input{$host}); 23 | } 24 | 25 | $cb($req); 26 | }, 27 | app => -> %env { 28 | my $code = Crust::Middleware::ReverseProxy.new( 29 | sub (%env) { 30 | my $req = Crust::Request.new(%env); 31 | 32 | if %arg
.defined { 33 | is $req.address, %arg
, "$tag of address"; 34 | } 35 | 36 | if %arg.defined { 37 | is ($req.env eq 'https'), %arg, "$tag of secure"; 38 | } 39 | 40 | for qw/uri base/ -> $url { 41 | if %arg{$url}.defined { 42 | is $req."$url"(), %arg{$url}, "$tag of $url"; 43 | } 44 | } 45 | 46 | return start { 200, ['Content-Type' => 'text/plain'], [ 'OK' ] }; 47 | } 48 | ); 49 | $code(%env); 50 | }; 51 | } 52 | 53 | my @tests = [ 54 | 'with https' => { 55 | input => q{x-forwarded-https: on}, 56 | secure => True, 57 | base => 'https://example.com/', 58 | uri => 'https://example.com/?foo=bar' 59 | }, 60 | 'without https' => { 61 | input => q{x-forwarded-https: off}, 62 | secure => False, 63 | base => 'http://example.com/', 64 | uri => 'http://example.com/?foo=bar' 65 | }, 66 | 'dummy' => { 67 | input => q{dummy: 1}, 68 | secure => False, 69 | base => 'http://example.com/', 70 | uri => 'http://example.com/?foo=bar', 71 | }, 72 | 'https with HTTP_X_FORWARDED_PROTO' => { 73 | input => q{x-forwarded-proto: https}, 74 | secure => True, 75 | base => 'https://example.com/', 76 | uri => 'https://example.com/?foo=bar' 77 | }, 78 | 'http with HTTP_X_FORWARDED_PROTO' => { 79 | input => q{x-forwarded-proto: http}, 80 | secure => False, 81 | base => 'http://example.com/', 82 | uri => 'http://example.com/?foo=bar', 83 | }, 84 | 'with HTTP_X_FORWARDED_FOR' => { 85 | input => q{x-forwarded-for: 192.168.3.2}, 86 | address => '192.168.3.2', 87 | base => 'http://example.com/', 88 | uri => 'http://example.com/?foo=bar', 89 | }, 90 | 'with HTTP_X_FORWARDED_HOST' => { 91 | input => q{x-forwarded-host: 192.168.1.2:5235}, 92 | base => 'http://192.168.1.2:5235/', 93 | uri => 'http://192.168.1.2:5235/?foo=bar', 94 | }, 95 | 'default port with HTTP_X_FORWARDED_HOST' => { 96 | input => q{x-forwarded-host: 192.168.1.2}, 97 | base => 'http://192.168.1.2/', 98 | uri => 'http://192.168.1.2/?foo=bar', 99 | }, 100 | 'default https port with HTTP_X_FORWARDED_HOST' => { 101 | input => q{x-forwarded-https: on 102 | x-forwarded-host: 192.168.1.2}, 103 | base => 'https://192.168.1.2/', 104 | uri => 'https://192.168.1.2/?foo=bar', 105 | }, 106 | 'default port with HOST' => { 107 | input => q{host: 192.168.1.2}, 108 | base => 'http://192.168.1.2/', 109 | uri => 'http://192.168.1.2/?foo=bar', 110 | }, 111 | 'default https port with HOST' => { 112 | input => q{host: 192.168.1.2 113 | https: ON}, 114 | base => 'https://192.168.1.2/', 115 | uri => 'https://192.168.1.2/?foo=bar', 116 | }, 117 | 'with HTTP_X_FORWARDED_HOST and HTTP_X_FORWARDED_PORT' => { 118 | input => q{x-forwarded-host: 192.168.1.5 119 | x-forwarded-port: 1984}, 120 | base => 'http://192.168.1.5:1984/', 121 | uri => 'http://192.168.1.5:1984/?foo=bar', 122 | }, 123 | 'with multiple HTTP_X_FORWARDED_HOST and HTTP_X_FORWARDED_FOR' => { 124 | input => q{x-forwarded-host: outmost.proxy.example.com, middle.proxy.example.com 125 | x-forwarded-for: 1.2.3.4, 192.168.1.6 126 | host: 192.168.1.7:5000}, 127 | address => '192.168.1.6', 128 | base => 'http://middle.proxy.example.com/', 129 | uri => 'http://middle.proxy.example.com/?foo=bar', 130 | }, 131 | 'normal plackup status' => { 132 | input => q{host: 127.0.0.1:5000}, 133 | base => 'http://127.0.0.1:5000/', 134 | uri => 'http://127.0.0.1:5000/?foo=bar', 135 | }, 136 | 'HTTP_X_FORWARDED_PORT to secure port' => { 137 | input => q{x-forwarded-host: 192.168.1.2 138 | x-forwarded-port: 443}, 139 | secure => True, 140 | }, 141 | 'HTTP_X_FORWARDED_PORT to secure port (apache2)' => { 142 | input => q{x-forwarded-server: proxy.example.com 143 | x-forwarded-host: proxy.example.com:8443 144 | x-forwarded-https: on 145 | x-forwarded-port: 8443}, 146 | base => 'https://proxy.example.com:8443/', 147 | uri => 'https://proxy.example.com:8443/?foo=bar', 148 | secure => True, 149 | }, 150 | 'with HTTP_X_FORWARDED_SERVER including 443 port (apache1)' => { 151 | input => q{x-forwarded-server: proxy.example.com:443 152 | x-forwarded-host: proxy.example.com}, 153 | base => 'https://proxy.example.com/', 154 | uri => 'https://proxy.example.com/?foo=bar', 155 | secure => True, 156 | } 157 | ]; 158 | 159 | for @tests -> Pair $test { 160 | my ($tag, %test) = $test.kv; 161 | run($tag, %test); 162 | } 163 | 164 | subtest { 165 | subtest { 166 | my %input = (x-forwarded-for => q{I'm not a IP address}); 167 | 168 | test-p6w 169 | client => -> $cb { 170 | my $req = HTTP::Request.new( 171 | GET => 'http://example.com/?foo=bar', 172 | |%input, 173 | ); 174 | my $res = $cb($req); 175 | is $res.code, 500; 176 | like $res.content.decode, /^'Invalid remote address has come'/; 177 | }, 178 | app => -> %env { 179 | my $code = Crust::Middleware::ReverseProxy.new( 180 | sub (%env) { 181 | my $req = Crust::Request.new(%env); 182 | return start { 200, ['Content-Type' => 'text/plain'], [ 'OK' ] }; 183 | }, 184 | ); 185 | $code(%env); 186 | }; 187 | }, 'Invalid ip'; 188 | 189 | subtest { 190 | my %input = (x-forwarded-for => '1.1.1.1'); 191 | 192 | test-p6w 193 | client => -> $cb { 194 | my $req = HTTP::Request.new( 195 | GET => 'http://example.com/?foo=bar', 196 | |%input, 197 | ); 198 | my $res = $cb($req); 199 | is $res.code, 500; 200 | like $res.content.decode, /^'Invalid remote address has come'/; 201 | }, 202 | app => -> %env { 203 | my $code = Crust::Middleware::ReverseProxy.new( 204 | sub (%env) { 205 | my $req = Crust::Request.new(%env); 206 | return start { 200, ['Content-Type' => 'text/plain'], [ 'OK' ] }; 207 | }, 208 | ip-pattern => rx{'127.0.0.1'}, 209 | ); 210 | $code(%env); 211 | }; 212 | }, 'Specify own pattern'; 213 | 214 | subtest { 215 | my %input = (x-forwarded-for => q{I'm not a IP address}); 216 | 217 | test-p6w 218 | client => -> $cb { 219 | my $req = HTTP::Request.new( 220 | GET => 'http://example.com/?foo=bar', 221 | |%input, 222 | ); 223 | my $res = $cb($req); 224 | is $res.code, 200; 225 | }, 226 | app => -> %env { 227 | my $code = Crust::Middleware::ReverseProxy.new( 228 | sub (%env) { 229 | my $req = Crust::Request.new(%env); 230 | return start { 200, ['Content-Type' => 'text/plain'], [ 'OK' ] }; 231 | }, 232 | ip-pattern => Nil, 233 | ); 234 | $code(%env); 235 | }; 236 | }, 'Ignore invalid IP'; 237 | }, 'Test for validate REMOTE_ADDR'; 238 | 239 | done-testing; 240 | 241 | -------------------------------------------------------------------------------- /t/Crust-Middleware/runtime.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Test; 4 | use Crust::Middleware::Runtime; 5 | use HTTP::Request; 6 | 7 | my $app = -> $env { 8 | sleep 0.5; 9 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] }; 10 | }; 11 | $app = ::('Crust::Middleware::Runtime').new($app); 12 | 13 | test-p6w 14 | client => -> $cb { 15 | my $req = HTTP::Request.new(GET => "http://localhost/hello"); 16 | my $res = $cb($req); 17 | ok $res.field('X-Runtime').Str >= 0.25, 'X-Runtime >= 0.25'; 18 | }, 19 | app => $app; 20 | 21 | # with a differnt header-name 22 | $app = -> $env { 23 | sleep 0.5; 24 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] }; 25 | }; 26 | $app = ::('Crust::Middleware::Runtime').new($app, :header-name); 27 | 28 | test-p6w 29 | client => -> $cb { 30 | my $req = HTTP::Request.new(GET => "http://localhost/hello"); 31 | my $res = $cb($req); 32 | ok $res.field('X-RUNTIME-TEST').Str >= 0.25, 'X-RUNTIME-TEST >= 0.25'; 33 | }, 34 | app => $app; 35 | 36 | done-testing; 37 | 38 | -------------------------------------------------------------------------------- /t/Crust-Middleware/stack-trace.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | use Crust::Middleware::StackTrace; 5 | use lib 't/lib/'; 6 | use SupplierBuffer; 7 | 8 | my %env = ( 9 | :REQUEST_METHOD, 10 | :SCRIPT_NAME, 11 | :PATH_INFO, 12 | :SERVER_NAME, 13 | :SERVER_PORT<8080>, 14 | :SERVER_PROTOCOL, 15 | ); 16 | 17 | subtest { 18 | my $buf = SupplierBuffer.new; 19 | 20 | temp %env = %env; 21 | %env = $buf.supplier; 22 | 23 | my $code = Crust::Middleware::StackTrace.new( 24 | sub (%env) { 25 | die 'Oops!'; 26 | } 27 | ); 28 | my $ret = await $code(%env); 29 | is $ret[0], 500; 30 | 31 | my $res-headers = $ret[1]; 32 | is %$res-headers, 'text/plain; charset=utf-8'; 33 | 34 | is $ret[2].elems, 1; 35 | like $ret[2][0], rx{'in sub at t/Crust-Middleware/stack-trace.t line ' \d+}; 36 | 37 | like %env, rx{'in sub at t/Crust-Middleware/stack-trace.t line ' \d+}; 38 | like %env, rx{'Error: in block at ' \S+ ' line ' \d+}; 39 | 40 | like $buf.result, rx{'in sub at t/Crust-Middleware/stack-trace.t line ' \d+}; 41 | }, 'Errors with plain text trace'; 42 | 43 | subtest { 44 | my $buf = SupplierBuffer.new; 45 | 46 | temp %env = %env; 47 | %env = $buf.supplier; 48 | %env = 'text/html'; 49 | 50 | my $code = Crust::Middleware::StackTrace.new( 51 | sub (%env) { 52 | die 'Oops!'; 53 | } 54 | ); 55 | my $ret = await $code(%env); 56 | is $ret[0], 500; 57 | 58 | my $res-headers = $ret[1]; 59 | is %$res-headers, 'text/html; charset=utf-8'; 60 | 61 | is $ret[2].elems, 1; 62 | like $ret[2][0], rx{'Error:' \s+ 'in block at ' \S+ ' line ' \d+}; 63 | 64 | like %env, rx{'in sub at t/Crust-Middleware/stack-trace.t line ' \d+}; 65 | like %env, rx{'Error: in block at ' \S+ ' line ' \d+}; 66 | 67 | like $buf.result, rx{'in sub at t/Crust-Middleware/stack-trace.t line ' \d+}; 68 | }, 'Errors with html trace'; 69 | 70 | subtest { 71 | my $buf = SupplierBuffer.new; 72 | 73 | temp %env = %env; 74 | %env = $buf.supplier; 75 | 76 | my $code = Crust::Middleware::StackTrace.new( 77 | sub (%env) { 78 | die 'Oops!'; 79 | }, 80 | no-print-errors => True, 81 | ); 82 | my $ret = await $code(%env); 83 | is $ret[0], 500; 84 | 85 | is $buf.result, ''; 86 | }, 'Test for no-print-errors'; 87 | 88 | subtest { 89 | my $code = Crust::Middleware::StackTrace.new( 90 | sub (%env) { 91 | start { 200, [], ['hello'] } 92 | } 93 | ); 94 | my $ret = await $code(%env); 95 | is $ret[0], 200; 96 | is $ret[1], []; 97 | is-deeply $ret[2], ['hello']; 98 | }, 'No errors'; 99 | 100 | done-testing; 101 | 102 | -------------------------------------------------------------------------------- /t/Crust-Middleware/static.foo: -------------------------------------------------------------------------------- 1 | fooo -------------------------------------------------------------------------------- /t/Crust-Middleware/static.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Test; 4 | use Crust::Builder; 5 | use Crust::Middleware::Static; 6 | use HTTP::Request; 7 | 8 | $Crust::Test::Impl = "MockHTTP"; 9 | 10 | # TODO: Need to port more tests 11 | 12 | my $app = builder { 13 | enable "Static", 14 | path => sub { 15 | # Perl6 strings are immutable, so you can't just modify 16 | # the path and expect the changes to be visible from the caller 17 | my $match = @_[0].subst-mutate(rx<^ '/share/'>, ""); 18 | return ($match, @_[0]); 19 | }, 20 | root => "share"; 21 | enable "Static", 22 | path => rx:i{ '.foo' $}, 23 | root => ".", 24 | content-type => sub ($file) { "text/x-fooo" }; 25 | -> %env { 26 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] }; 27 | }; 28 | }; 29 | 30 | test-p6w 31 | client => -> $cb { 32 | my ($req, $res); 33 | 34 | $req = HTTP::Request.new(GET => "http://localhost/hello"); 35 | $res = $cb($req); 36 | is $res.code, 200; 37 | is $res.content.decode, "Hello World"; 38 | 39 | $req = HTTP::Request.new(GET => "http://localhost/share/face.jpg"); 40 | $res = $cb($req); 41 | is $res.code, 200; 42 | like $res.field('Content-Type').Str, rx:i{image}; 43 | 44 | $req = HTTP::Request.new(GET => "http://localhost/share/doesnotexist"); 45 | $res = $cb($req); 46 | is $res.code, 404; 47 | 48 | $req = HTTP::Request.new(GET => "http://localhost/t/Crust-Middleware/static.foo"); 49 | $res = $cb($req); 50 | like $res.field('Content-Type').Str, rx:i{'text/x-fooo' ';'?}; 51 | is $res.code, 200; 52 | }, 53 | app => $app; 54 | 55 | done-testing; 56 | -------------------------------------------------------------------------------- /t/Crust-Middleware/xframework.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Test; 4 | use Crust::Middleware::XFramework; 5 | use HTTP::Request; 6 | 7 | my $framework = 'AwesomeWAF'; 8 | 9 | my $app = -> $env { 10 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] }; 11 | }; 12 | $app = Crust::Middleware::XFramework.new($app, :framework($framework)); 13 | 14 | test-p6w 15 | client => -> $cb { 16 | my $req = HTTP::Request.new(GET => "http://localhost/hello"); 17 | my $res = $cb($req); 18 | is $res.field('X-Framework').Str, $framework; 19 | }, 20 | app => $app; 21 | 22 | done-testing; 23 | -------------------------------------------------------------------------------- /t/Crust-Test/2args.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Crust::Test; 3 | use Test; 4 | use HTTP::Request; 5 | 6 | $Crust::Test::Impl = "MockHTTP"; 7 | 8 | my $app = { start { 200, [], [ 'Hello' ] } }; 9 | 10 | test-p6w $app, -> $cb { 11 | my $res = $cb(HTTP::Request.new(GET =>"/")); 12 | is $res.content, "Hello".encode; 13 | }; 14 | 15 | done-testing; 16 | -------------------------------------------------------------------------------- /t/Crust-Test/hello.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::Test; 4 | use HTTP::Request; 5 | 6 | $Crust::Test::Impl = "MockHTTP"; 7 | 8 | test-p6w 9 | client => -> $cb { 10 | my $req = HTTP::Request.new(GET => "http://localhost/hello"); 11 | my $res = $cb($req); 12 | is $res.content, 'Hello World'.encode; 13 | is $res.field('Content-Type').Str, 'text/plain'; 14 | is $res.code, 200; 15 | }, 16 | app => -> $env { 17 | start { 200, [ 'Content-Type' => 'text/plain' ], [ 'Hello World' ] }; 18 | }; 19 | 20 | done-testing; 21 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/content-length.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Message::P6W; 4 | use HTTP::Request; 5 | 6 | my $content = q|{"foo":"bar"}|; 7 | my $req = HTTP::Request.new( 8 | POST => "http://localhost/post", 9 | Content-Type => "application/json", 10 | ); 11 | $req.content = $content.encode; 12 | 13 | my $env = $req.to-p6w; 14 | 15 | is $env, 13; 16 | my $buf = $env.read(13); 17 | is $buf, $content.encode; 18 | 19 | done-testing; 20 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/error.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Message::P6W; 4 | use HTTP::Request; 5 | use IO::Blob; 6 | 7 | my $io = IO::Blob.new(); 8 | $*ERR = $io; 9 | 10 | my $env = HTTP::Request.new(GET => "http://localhost/").to-p6w; 11 | isa-ok $env, Supplier; 12 | 13 | lives-ok { $env.emit('ohno'); }, 'can emit'; 14 | 15 | $io.seek(0); 16 | is $io.slurp-rest, "ohno\n"; 17 | 18 | done-testing; 19 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/host.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Message::P6W; 4 | use HTTP::Request; 5 | 6 | { 7 | my $req = HTTP::Request.new(GET => "http://example.com/"); 8 | my $env = $req.to-p6w; 9 | 10 | is $env, 'example.com'; 11 | is $env, '/'; 12 | } 13 | 14 | { 15 | my $req = HTTP::Request.new(GET => "http://example.com:345/"); 16 | my $env = $req.to-p6w; 17 | 18 | is $env, 'example.com:345'; 19 | is $env, '/'; 20 | } 21 | 22 | { 23 | my $req = HTTP::Request.new(GET => "/"); 24 | $req.field(Host => "perl.com"); 25 | my $env = $req.to-p6w; 26 | 27 | is $env, 'perl.com'; 28 | is $env, '/'; 29 | } 30 | 31 | done-testing; 32 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/path-info.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Message::P6W; 4 | use HTTP::Request; 5 | 6 | my $env = HTTP::Request.new(GET => "http://localhost/foo").to-p6w; 7 | is $env, "/foo"; 8 | 9 | $env = HTTP::Request.new(GET => "http://localhost/").to-p6w; 10 | is $env, ""; 11 | is $env, "/"; 12 | 13 | $env = HTTP::Request.new(GET => "http://localhost/0").to-p6w; 14 | is $env, ""; 15 | is $env, "/0"; 16 | 17 | $env = HTTP::Request.new(GET => "http://localhost").to-p6w; 18 | is $env, ""; 19 | is $env, "/"; 20 | is $env, "/"; 21 | 22 | 23 | done-testing; 24 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/res.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Message::P6W; 4 | use IO::Blob; 5 | 6 | subtest { 7 | my @psgi-res = 8 | 404, 9 | ["Content-Length" => 9, 'X-Foo' => "hoge"], 10 | ["NOT FOUND"], 11 | ; 12 | my $res = HTTP::Response.from-p6w(|@psgi-res); 13 | is $res.code, 404; 14 | is $res.content, "NOT FOUND".encode('ascii'); 15 | is $res.field('Content-Length'), 9; 16 | is $res.field('X-Foo'), "hoge"; 17 | }; 18 | 19 | subtest { 20 | my $io = IO::Blob.new( "hello".encode('utf-8') ); 21 | my @psgi-res = 22 | 200, 23 | [], 24 | $io, 25 | ; 26 | my $res = HTTP::Response.from-p6w(|@psgi-res); 27 | is $res.code, 200; 28 | is $res.content, "hello".encode('utf-8'); 29 | }; 30 | 31 | done-testing; 32 | -------------------------------------------------------------------------------- /t/HTTP-Message-P6W/utf8-req.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use HTTP::Request; 4 | use HTTP::Message::P6W; 5 | use URI::Escape; 6 | 7 | BEGIN { 8 | # t/HTTP-Message-PSGI/utf8-req.t .. Could not parse URI: http://localhost/П 9 | # in block at /Users/skaji/env/rakudobrew/moar-nom/install/share/perl6/site/lib/URI.pm:42 10 | print("1..0 # Skip: Known to fail\n"); 11 | exit 0; 12 | } 13 | 14 | my @paths = 15 | 'П', '%D0%9F', 16 | 'À', '%C3%80', 17 | ; 18 | 19 | for @paths -> $raw, $encoded { 20 | my $req = HTTP::Request.new(GET => "http://localhost/" ~ $raw); 21 | my $env = $req.to-p6w; 22 | is $env, "/$encoded"; 23 | is $env, uri_unescape("/$encoded"); 24 | } 25 | 26 | done-testing; 27 | -------------------------------------------------------------------------------- /t/crust/data/001-content.dat: -------------------------------------------------------------------------------- 1 | ------------0xKhTmLbOuNdArY 2 | Content-Disposition: form-data; name="text1" 3 | 4 | Ratione accusamus aspernatur aliquam 5 | ------------0xKhTmLbOuNdArY 6 | Content-Disposition: form-data; name="text2" 7 | 8 | 9 | ------------0xKhTmLbOuNdArY 10 | Content-Disposition: form-data; name="select" 11 | 12 | A 13 | ------------0xKhTmLbOuNdArY 14 | Content-Disposition: form-data; name="select" 15 | 16 | B 17 | ------------0xKhTmLbOuNdArY 18 | Content-Disposition: form-data; name="textarea" 19 | 20 | Voluptatem cumque voluptate sit recusandae at. Et quas facere rerum unde esse. Sit est et voluptatem. Vel temporibus velit neque odio non. 21 | 22 | Molestias rerum ut sapiente facere repellendus illo. Eum nulla quis aut. Quidem voluptas vitae ipsam officia voluptatibus eveniet. Aspernatur cupiditate ratione aliquam quidem corrupti. Eos sunt rerum non optio culpa. 23 | ------------0xKhTmLbOuNdArY 24 | Content-Disposition: form-data; name="upload"; filename="hello.pl" 25 | Content-Type: application/octet-stream 26 | 27 | #!/usr/bin/perl 28 | 29 | use strict; 30 | use warnings; 31 | 32 | print "Hello World :)\n"; 33 | 34 | 35 | ------------0xKhTmLbOuNdArY 36 | Content-Disposition: form-data; name="upload"; filename="hello.pl" 37 | Content-Type: application/octet-stream 38 | 39 | #!/usr/bin/perl 40 | 41 | use strict; 42 | use warnings; 43 | 44 | print "Hello World :)\n"; 45 | 46 | 47 | ------------0xKhTmLbOuNdArY 48 | Content-Disposition: form-data; name="upload1"; filename="" 49 | 50 | 51 | ------------0xKhTmLbOuNdArY 52 | Content-Disposition: form-data; name="upload2"; filename="hello.pl" 53 | Content-Type: application/octet-stream 54 | 55 | #!/usr/bin/perl 56 | 57 | use strict; 58 | use warnings; 59 | 60 | print "Hello World :)\n"; 61 | 62 | 63 | ------------0xKhTmLbOuNdArY 64 | Content-Disposition: form-data; name="upload3"; filename="blank.pl" 65 | Content-Type: application/octet-stream 66 | 67 | 68 | ------------0xKhTmLbOuNdArY 69 | Content-Disposition: form-data; name="upload4"; filename="0" 70 | 71 | 72 | ------------0xKhTmLbOuNdArY-- 73 | -------------------------------------------------------------------------------- /t/crust/headers.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | use Crust::Headers; 6 | 7 | my $headers = Crust::Headers.new({ 8 | 'Content-Type' => 'text/html', 9 | 'Content-Length' => '5000', 10 | 'Referer' => 'http://mixi.jp', 11 | 'User-Agent' => 'IE', 12 | 'content-encoding' => 'gzip', 13 | }); 14 | is $headers.header('ContEnt-TypE'), 'text/html'; 15 | is $headers.content-type, 'text/html'; 16 | is $headers.content-length, 5000; 17 | is $headers.user-agent, 'IE'; 18 | is $headers.referer, 'http://mixi.jp'; 19 | is $headers.content-encoding, 'gzip'; 20 | ok $headers.Str ~~ /"content-length: 5000"/; 21 | 22 | done-testing; 23 | 24 | -------------------------------------------------------------------------------- /t/crust/mime/add-type.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::MIME; 4 | 5 | Crust::MIME.add-type(".foo" => "text/foo"); 6 | is Crust::MIME.mime-type("bar.foo"), "text/foo"; 7 | 8 | Crust::MIME.add-type(".c" => "application/c-source"); 9 | is Crust::MIME.mime-type("FOO.C"), "application/c-source"; 10 | 11 | Crust::MIME.add-type(".a" => "text/a", ".b" => "text/b"); 12 | is Crust::MIME.mime-type("foo.a"), "text/a"; 13 | is Crust::MIME.mime-type("foo.b"), "text/b"; 14 | 15 | done-testing; 16 | -------------------------------------------------------------------------------- /t/crust/mime/basic.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::MIME; 4 | 5 | sub x($t) { Crust::MIME.mime-type($t) } 6 | 7 | is x(".gif"), "image/gif"; 8 | is x("foo.png"), "image/png"; 9 | is x("foo.GIF"), "image/gif"; 10 | ok !x("foo.bar").defined; 11 | is x("foo.mp3"), "audio/mpeg"; 12 | 13 | done-testing; 14 | -------------------------------------------------------------------------------- /t/crust/mime/fallback.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use Crust::MIME; 4 | 5 | ok !Crust::MIME.mime-type(".vcd").defined; 6 | 7 | my $fallback = sub ($file) { $file ~~ /\.vcd$/ ?? "application/x-cdlink" !! Nil }; 8 | Crust::MIME.set-fallback($fallback); 9 | is Crust::MIME.mime-type(".vcd"), "application/x-cdlink"; 10 | 11 | done-testing; 12 | -------------------------------------------------------------------------------- /t/crust/request.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | use Crust::Request; 5 | 6 | # body-parameters: multipart/form-data 7 | subtest { 8 | my $req = Crust::Request.new({ 9 | :REMOTE_ADDR<127.0.0.1>, 10 | 'p6w.input' => open('t/crust/data/001-content.dat', :bin), 11 | :HTTP_USER_AGENT, 12 | :HTTP_REFERER, 13 | :HTTP_CONTENT_ENCODING, 14 | REQUEST_URI => '/iyan?foo=bar&foo=baz', 15 | QUERY_STRING => 'foo=bar&foo=baz', 16 | PATH_INFO => '/iyan', 17 | HTTP_HOST => 'example.com', 18 | CONTENT_TYPE => 'multipart/form-data; boundary="----------0xKhTmLbOuNdArY"', 19 | }); 20 | my $params = $req.body-parameters; 21 | is $params.decode('ascii'), 'Ratione accusamus aspernatur aliquam'; 22 | is $req.uploads.keys.sort.join(','), 'upload,upload1,upload2,upload3,upload4'; 23 | is $req.uri, 'http://example.com/iyan?foo=bar&foo=baz'; 24 | is $req.request-uri, '/iyan?foo=bar&foo=baz'; 25 | my $upload2 = $req.uploads; 26 | is $upload2.filename, 'hello.pl'; 27 | ok $upload2.path.slurp(:bin).decode('ascii') ~~ m:s/Hello World/; 28 | }, 'multipart/form-data'; 29 | 30 | subtest { 31 | my $req = Crust::Request.new({ 32 | :REMOTE_ADDR<127.0.0.1>, 33 | :QUERY_STRING, 34 | 'p6w.input' => open('t/crust/request.t'), 35 | :HTTP_USER_AGENT, 36 | :HTTP_REFERER, 37 | :HTTP_CONTENT_ENCODING, 38 | :HTTP_HOST, 39 | :CONTENT_TYPE 40 | }); 41 | is $req.address, '127.0.0.1'; 42 | my $p = $req.query-parameters; 43 | ok [$p.all-pairs] eqv [:foo, :foo]; 44 | is $req.headers.content-type, 'text/html'; 45 | is $req.header('content-type'), 'text/html'; 46 | is $req.user-agent, 'hoge'; 47 | is $req.referer, 'http://mixi.jp'; 48 | is $req.content-encoding, 'gzip'; 49 | ok $req.content.decode('ascii') ~~ /"p6w.input"/; # XXX better method? 50 | is $req.parameters, 'baz'; 51 | is $req.base, 'http://example.com/'; 52 | is $req.uri, 'http://example.com/?foo=bar&foo=baz'; 53 | }, 'query params and basic things'; 54 | 55 | # body-parameters: x-www-form-urlencoded 56 | subtest { 57 | my $req = Crust::Request.new({ 58 | :REMOTE_ADDR<127.0.0.1>, 59 | :QUERY_STRING, 60 | 'p6w.input' => open('t/dat/query.txt'), 61 | :HTTP_USER_AGENT, 62 | :CONTENT_TYPE 63 | }); 64 | is $req.body-parameters, 'bakan'; 65 | is $req.parameters, 'baz'; 66 | is $req.parameters, 'bakan'; 67 | }, 'body-params'; 68 | 69 | # cookies 70 | subtest { 71 | my $req = Crust::Request.new({ 72 | :HTTP_COOKIE 73 | }); 74 | my $cookies = $req.cookies; 75 | my $hoge = $cookies; 76 | is $hoge, 'fuga'; 77 | }, 'body-params'; 78 | 79 | done-testing; 80 | -------------------------------------------------------------------------------- /t/crust/response.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Crust::Response; 4 | use Test; 5 | 6 | { 7 | my $resp = Crust::Response.new(status => 500, headers => ['Content-Type' => 'text/plain'], body => 'hoge'); 8 | my $r = $resp.finalize(); 9 | is $r[0], 500; 10 | } 11 | 12 | done-testing; 13 | -------------------------------------------------------------------------------- /t/crust/utils.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use Test; 4 | 5 | use Crust::Utils; 6 | 7 | subtest { 8 | my $pair = parse-header-line("foo: bar"); 9 | is $pair.key, 'foo'; 10 | is $pair.value, 'bar'; 11 | }, 'parse-header-line'; 12 | 13 | subtest { 14 | my ($head, %opts) = parse-header-item('form-data; name="upload"; filename="hello.pl"'); 15 | is $head, 'form-data'; 16 | is-deeply %opts, { 17 | name => 'upload', 18 | filename => 'hello.pl', 19 | }; 20 | }, 'parse-header-item'; 21 | 22 | subtest { 23 | my $dt = DateTime.new("2015-10-30T09:00:00+09:00"); 24 | is $dt.offset, 9 * 3600; # sanity to make sure we are NOT in UTC... 25 | is format-datetime-rfc1123($dt), "Fri 30 Oct 2015 00:00:00 GMT"; 26 | 27 | $dt = DateTime.new("2015-10-30T00:00:00z"); 28 | is $dt.offset, 0; # sanity to make sure we are in UTC... 29 | is format-datetime-rfc1123($dt), "Fri 30 Oct 2015 00:00:00 GMT"; 30 | 31 | }, 'format-datetime-rfc1123'; 32 | 33 | done-testing; 34 | -------------------------------------------------------------------------------- /t/dat/query.txt: -------------------------------------------------------------------------------- 1 | iyan=bakan -------------------------------------------------------------------------------- /t/lib/SupplierBuffer.pm6: -------------------------------------------------------------------------------- 1 | class SupplierBuffer { 2 | has $.supplier; 3 | has $.result = ""; 4 | 5 | method new() { 6 | my $supplier = Supplier.new; 7 | my $self = self.bless(supplier => $supplier); 8 | my $supply = $supplier.Supply; 9 | $supply.tap(-> $v { $self.append($v) }); 10 | return $self; 11 | } 12 | 13 | method append($v) { 14 | $!result ~= $v if $v; 15 | } 16 | } 17 | 18 | -------------------------------------------------------------------------------- /t/lib/Test/TCP.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | unit class Test::TCP; 3 | 4 | sub wait_port(int $port, Str $host='127.0.0.1', :$sleep=0.1, int :$times=100, Callable :$callback) is export { 5 | LOOP: for 1..$times { 6 | try { 7 | my $sock = IO::Socket::INET.new(host => $host, port => $port); 8 | if $callback { 9 | $callback($sock); 10 | } 11 | $sock.close; 12 | 13 | CATCH { default { 14 | sleep $sleep; 15 | next LOOP; 16 | } } 17 | } 18 | return; 19 | } 20 | 21 | die "$host:$port doesn't open in {$sleep*$times} sec."; 22 | } 23 | 24 | 25 | --------------------------------------------------------------------------------