diff --git a/META6.json b/META6.json index 9cf97c5..5a32b69 100644 --- a/META6.json +++ b/META6.json @@ -30,7 +30,8 @@ "HTTP::Response": "lib/HTTP/Response.rakumod", "HTTP::UserAgent": "lib/HTTP/UserAgent.rakumod", "HTTP::UserAgent::Common": "lib/HTTP/UserAgent/Common.rakumod", - "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod" + "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod", + "HTTP::Header::ETag": "lib/HTTP/Header/ETag.rakumod" }, "raku": "6.*", "resources": [ diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index d4223aa..e1f7180 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -1,10 +1,93 @@ unit class HTTP::Header; use HTTP::Header::Field; +use HTTP::Header::ETag; +my constant $CRLF = "\x[0D]\x[0A]"; + +has Bool $.strict is rw; # headers container has @.fields; +grammar Grammar::Strict { + token TOP { + + } + token message-header { + [ <[\t\x[20]]>* <[\t\x[20]]>* \x[0d]\x[0a] ]* + } + #| includes any VCHAR except delimiters + #| https://datatracker.ietf.org/doc/html/rfc9110#name-tokens + token token { + <[!#$%&'*+\-.^_`|~0..9a..zA..Z]>+ + } + token field { + | + | + } + token other-field { + $= ':' \s* [ | ] + } + token etag { + $=[<[eE]><[tT]><[aA]><[gG]>] ':'\s* $=[ [(W)'/']? ] + } + token opaque-tag { + \" \" + } + # visible chars except double quote + token opaque-content { + <[\x[21]..\x[FF]]-[\x[22]\x[7F]]>* + } + token vchars { <[\x[21]..\x[7E]]>+ } # visible ascii + token field-vchars { <[\x[21]..\x[FF]]-[\x[7F]]>+ } # visible chars + token value { + [ <[\t\x[20]]>* ]* + } + token quoted-string { + \" \" + } + token quoted-content { + [ | ]* + } + # visible chars plus tab, space, except double quotes and backslash + token qtd-text { + <[\t\x[20]..\x[FF]]-[\x[22]\x[5C]\x[7F]]>+ + } + # visible chars plus tab, space + token quotable-char { + <[\t\x[20]..\x[FF]]-[\x[7F]]> + } + token quoted-pair { + \\ + } +} + +class Actions::Strict { + method etag ( $/ ) { + $*OBJ.field: + HTTP::Header::ETag.new: + $.made, + weak => $/[0].Bool + } + method other-field ( $/ ) { + my $k = $.Str; + my @v = $ + ?? $.made + !! map *.trim, $.Str.split: ','; + if $*OBJ.field: $ { + $*OBJ.push-field: |( $k => @v ); + } else { + $*OBJ.field: |( $k => @v ); + } + } + method opaque-tag ( $/ ) { + make $.Str; + } + method quoted-string ( $/ ) { + make $.Str; + } +} + our grammar HTTP::Header::Grammar { token TOP { [ \r?\n ]* @@ -50,12 +133,12 @@ our class HTTP::Header::Actions { } # we want to pass arguments like this: .new(a => 1, b => 2 ...) -method new(*%fields) { +method new(Bool $strict = False, *%fields) { my @fields = %fields.sort(*.key).map: { HTTP::Header::Field.new(:name(.key), :values(.value.list)); } - self.bless(:@fields) + self.bless(:$strict, :@fields) } proto method field(|) {*} @@ -79,6 +162,11 @@ multi method field($field) { @.fields.first(*.name.lc eq $field-lc) } +multi method field ( HTTP::Header::ETag:D $etag ) { + @.fields.push: $etag; +} + + # initialize fields method init-field(*%fields) { for %fields.sort(*.key) -> (:key($k), :value($v)) { @@ -120,13 +208,24 @@ method clear() { } # get header as string -method Str($eol = "\n") { +multi method Str(Str $eol is copy = "\n", Bool $strict is copy = False) { + $strict ||= $!strict; + $eol = $CRLF if $strict; @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } +multi method Str (Bool $strict is copy = False) is default { + self.Str: "\n", $strict; +} -method parse($raw) { - my $*OBJ = self; - HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); +method parse($raw, Bool $strict is copy = False) { + $strict ||= $!strict; + if $strict { + my $*OBJ = self; + Grammar::Strict.parse: $raw, actions => Actions::Strict; + } else { + my $*OBJ = self; + HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); + } } # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Header/ETag.rakumod b/lib/HTTP/Header/ETag.rakumod new file mode 100644 index 0000000..fe161d7 --- /dev/null +++ b/lib/HTTP/Header/ETag.rakumod @@ -0,0 +1,12 @@ +use HTTP::Header::Field; + +unit class HTTP::Header::ETag is HTTP::Header::Field; + +has Bool:D $.weak is required; + +method new ( $value, Bool :$weak ) { + self.bless: + name => 'ETag', + :$weak, + values => $value +} diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 56865e6..7acb32b 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -4,6 +4,7 @@ use HTTP::Header; use HTTP::MediaType; use Encode; +has Bool $.strict is rw; has HTTP::Header $.header = HTTP::Header.new; has $.content is rw; @@ -12,12 +13,20 @@ has $.protocol is rw = 'HTTP/1.1'; has Bool $.binary = False; has Str @.text-types; -my $CRLF = "\r\n"; +my constant $CRLF = "\x[0d]\x[0a]"; +my constant $DELIM = $CRLF x 2; +my constant $STRICT = True; # prepare for assoc. strict to positional strict -method new($content?, *%fields) { - my $header = HTTP::Header.new(|%fields); +multi method new($content, Bool $strict = False, *%fields) { + my $header = HTTP::Header.new($strict, |%fields); - self.bless(:$header, :$content); + self.bless(:$header, :$content, :$strict); +} + +multi method new(Bool $strict = False, *%fields) is default { + my $header = HTTP::Header.new($strict, |%fields); + + self.bless(:$header, :$strict); } method add-content($content) { @@ -103,6 +112,17 @@ method is-text(--> Bool:D) { method is-binary(--> Bool:D) { !self.is-text } +#| multiple transfer-codings can be listed; chunked should be last +#| https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 +#| https://datatracker.ietf.org/doc/html/rfc7230#section-4 +multi method is-chunked ( HTTP::Header $header --> Bool:D ) { + my $enc = $header.field('Transfer-Encoding'); + so $enc and $enc.values.tail.trim.lc.ends-with: 'chunked' +} +multi method is-chunked(--> Bool:D) { + self.is-chunked: $!header; +} + method content-encoding() { $!header.field('Content-Encoding'); } @@ -180,48 +200,87 @@ method clear { $.content = '' } -method parse($raw_message) { - my @lines = $raw_message.split(/$CRLF/); - - my ($first, $second, $third) = @lines.shift.split(/\s+/); +# parsing content with embedded CRLFs NYI +# it would require taking encoding into account and working with Blobs +method !parse-content-strict ( $content ) { + if self.is-chunked { + # technically incorrect - content allowed to contain embedded CRLFs + my @lines = $content.split: $CRLF; + # pop zero-length Str that occurs after last chunk + # what to do if this doesn't happen? + @lines.pop if @lines %2; + @lines = grep so *, + @lines.map: + -> $d, $s { $d ~~ /^<[0..9]>/ ?? $s !! Str } + ; + $.content = @lines.join; + } else { + $.content = $content; + } +} +method !parse-first ($raw_message, --> Str) { + my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; + my ($first, $second, $third) = $start-line.split(/\s+/); if $third.index('/') { # is a request $.protocol = $third; } else { # is a response $.protocol = $first; } + $rest; +} - loop { - last until @lines; - - my $line = @lines.shift; - if $line { - my ($k, $v) = $line.split(/\:\s*/, 2); - if $k and $v { - if $.header.field($k) { - $.header.push-field: |($k => $v.split(',')>>.trim); - } else { - $.header.field: |($k => $v.split(',')>>.trim); - } +method !parse-header($header) { + my @lines = $header.split($CRLF); + for @lines -> $line { + my ($k, $v) = $line.split(/\:\s*/, 2); + if $k and $v { + if $!header.field($k) { + $!header.push-field: |($k => $v.split(',')>>.trim); + } else { + $!header.field: |($k => $v.split(',')>>.trim); } - } else { - $.content = @lines.grep({ $_ }).join("\n"); - last; } + # else warn? } +} + +method !parse-header-strict($header) { + $!header.parse($header, $STRICT); +} +method parse($raw_message, Bool $strict is copy = False) { + $strict ||= $!strict; + my $rest = self!parse-first($raw_message); + my ($header, $content) = $rest.split($DELIM, 2); + if $strict { + $!header.parse($header, $STRICT); + self!parse-content-strict($content) if $content; + } else { + self!parse-header($header); + $!content = join "\n", grep so *, $content.split: $CRLF; + } self } -method Str($eol = "\n", :$debug, Bool :$bin) { +multi method Str(Str $eol is copy = "\n", Bool $strict is copy = False, :$debug, Bool :$bin) { + $strict ||= $!strict; + $eol = $CRLF if $strict; + my constant $max_size = 300; - my $s = $.header.Str($eol); - $s ~= $eol if $.content; + self.field: Content-Length => ( $!content.?encode or $!content ).bytes.Str + if $strict and $!content and not self.is-chunked; + my $s = $.header.Str($eol, $strict); + $s ~= $eol if $!content and not $strict; # The :bin will be passed from the H::UA if not $bin { - $s ~= $.content ~ $eol if $.content and !$debug; + if $strict { + $s ~= $CRLF ~ ( $.content || '' ); + } else { + $s ~= $.content ~ $eol if $.content and !$debug; + } } if $.content and $debug { if $bin || self.is-binary { @@ -237,5 +296,8 @@ method Str($eol = "\n", :$debug, Bool :$bin) { $s } +multi method Str(Bool $strict is copy = False, :$debug, Bool :$bin) { + self.Str: "\n", $strict, :$debug, :$bin; +} # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index a5af450..09938d7 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -17,13 +17,15 @@ has Str $.host is rw; has Int $.port is rw; has Str $.scheme is rw; -my $CRLF = "\r\n"; +has Bool $.strict is rw; + +my constant $CRLF = "\x[0D]\x[0A]"; my $HRC_DEBUG = %*ENV.Bool; proto method new(|) {*} -multi method new(Bool :$bin, *%args) { +multi method new(Bool $strict = False, Bool :$bin, *%args) { if %args { my ($method, $url, $file, %fields, $uri); @@ -37,23 +39,21 @@ multi method new(Bool :$bin, *%args) { } } - my $header = HTTP::Header.new(|%fields); - self.new($method // 'GET', $uri, $header, :$bin); + my $header = HTTP::Header.new($strict, |%fields); + self.new($method // 'GET', $uri, $header, $strict, :$bin); } else { - self.bless + self.bless: :$strict, :$bin; } } -multi method new() { self.bless } - -multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { +multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool $strict = False, Bool :$bin) { my $url = $uri.grammar.parse_result.orig; my $file = $uri.path_query || '/'; $header.field(Host => get-host-value($uri)) without $header.field('Host'); - self.bless(:$method, :$url, :$header, :$file, :$uri, binary => $bin) + self.bless(:$method, :$url, :$header, :$file, :$uri, binary => $bin, :$strict) } sub get-host-value(URI $uri --> Str) { @@ -266,13 +266,15 @@ method make-boundary(int $size=10) { } -method Str (:$debug, Bool :$bin) { +method Str (Bool $strict is copy = False, :$debug, Bool :$bin) { + $strict ||= $!strict; $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; - $s ~= $CRLF ~ callwith($CRLF, :$debug, :$bin); + $s ~ $CRLF ~ callwith $CRLF, $strict, :$debug, :$bin; } -method parse($raw_request) { +method parse($raw_request, Bool $strict is copy = False) { + $strict ||= $!strict; my @lines = $raw_request.split($CRLF); ($.method, $.file) = @lines.shift.split(' '); diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index 7dcd253..57efd6f 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -8,8 +8,9 @@ unit class HTTP::Response is HTTP::Message; has $.status-line is rw; has $.code is rw; has HTTP::Request $.request is rw; +has Bool $.strict is rw; -my $CRLF = "\r\n"; +my constant $CRLF = "\x[0D]\x[0A]"; submethod BUILD(:$!code) { $!status-line = self.set-code($!code); @@ -18,21 +19,33 @@ submethod BUILD(:$!code) { proto method new(|) {*} # This candidate makes it easier to test weird responses -multi method new(Blob:D $header-chunk) { +multi method new(Blob:D $header-chunk, Bool $strict = False) { # See https://tools.ietf.org/html/rfc7230#section-3.2.4 - my ($rl, $header) = $header-chunk.decode('ISO-8859-1').split(/\r?\n/, 2); + my ($rl, $header); + if $strict { + ($rl, $header) = $header-chunk.decode('ISO-8859-1').split($CRLF, 2); + } else { + ($rl, $header) = $header-chunk.decode('ISO-8859-1').split(/\r?\n/, 2); + } X::HTTP::NoResponse.new.throw unless $rl; my $code = (try $rl.split(' ')[1].Int) // 500; - my $response = self.new($code); - $response.header.parse(.subst(/"\r"?"\n"$$/, '')) with $header; + my $response = self.new($code, $strict); + with $header { + .=subst: /"\r"?"\n"$$/, '' unless $strict; + $response.header.parse: $header, $strict; + } $response } multi method new(Int:D $code = 200, *%fields) { - my $header = HTTP::Header.new(|%fields); - self.bless(:$code, :$header); + self.new: $code, False, |%fields; +} + +multi method new(Int:D $code, Bool $strict, *%fields) { + my $header = HTTP::Header.new($strict, |%fields); + self.bless(:$code, :$header, :$strict); } method content-length(--> Int) { @@ -65,7 +78,8 @@ method set-code(Int:D $code) { $!status-line = $code ~ " " ~ get_http_status_msg($code); } -method next-request(--> HTTP::Request:D) { +method next-request(Bool $strict is copy = False --> HTTP::Request:D) { + $strict ||= $!strict; my HTTP::Request $new-request; my $location = ~self.header.field('Location').values; @@ -83,7 +97,7 @@ method next-request(--> HTTP::Request:D) { my %args = $method => $location; - $new-request = HTTP::Request.new(|%args); + $new-request = HTTP::Request.new($strict, |%args); unless ~$new-request.field('Host').values { my $hh = ~$!request.field('Host').values; @@ -97,9 +111,10 @@ method next-request(--> HTTP::Request:D) { $new-request } -method Str(:$debug) { +method Str(Bool $strict is copy = False, :$debug) { + $strict ||= $!strict; my $s = $.protocol ~ " " ~ $!status-line; - $s ~= $CRLF ~ callwith($CRLF, :debug($debug)); + $s ~ $CRLF ~ callwith $CRLF, $strict, :$debug; } # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index d1100e9..f624488 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -13,22 +13,27 @@ use File::Temp; use MIME::Base64; constant CRLF = Buf.new(13, 10); +my constant $STRICT = True; # placeholder role to make signatures nicer # and enable greater abstraction role Connection { - method send-request(HTTP::Request $request ) { + method send-request(HTTP::Request $request, Bool $strict = $request.strict) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { - self.print($request.Str(:bin)); + self.print($request.Str($strict, :bin)); self.write($request.content); } + elsif $strict { + self.print: $request.Str: $STRICT; + } else { self.print($request.Str ~ "\r\n"); } } } +has Bool $.strict is rw; has Int $.timeout is rw = 180; has $.useragent; has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( @@ -71,7 +76,7 @@ my sub _index_buf(Blob $input, Blob $sub) { -1 } -submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { +submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row, :$!strict = False) { $!useragent = get-ua($!useragent) if $!useragent.defined; if $!debug.defined { if $!debug ~~ Bool and $!debug == True { @@ -89,6 +94,10 @@ submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$ } } +method new ( Bool $strict = False, :$useragent, Bool :$throw-exceptions, :$max-redirects = 5, :$debug, :$redirects-in-a-row ) { + self.bless: :$useragent, :$throw-exceptions, :$max-redirects, :$debug, :$redirects-in-a-row, :$strict; +} + method auth(Str $login, Str $password) { $!auth_login = $login; $!auth_password = $password; @@ -96,51 +105,56 @@ method auth(Str $login, Str $password) { proto method get(|) {*} -multi method get(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request.new(GET => $uri, |%header); - self.request($request, :$bin) +multi method get(URI $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { + $strict ||= $!strict; + my $request = HTTP::Request.new($strict, GET => $uri, |%header); + self.request($request, $strict, :$bin) } -multi method get(Str $uri is copy, Bool :$bin, *%header ) { - self.get(URI.new(_clear-url($uri)), :$bin, |%header) +multi method get(Str $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { + self.get(URI.new(_clear-url($uri)), $strict, :$bin, |%header) } proto method post(|) {*} -multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(POST => $uri, |%header); +multi method post(URI $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header) { + $strict ||= $!strict; + my $request = HTTP::Request.new($strict, POST => $uri, |%header); $request.add-form-data(%form); - self.request($request, :$bin) + self.request($request, $strict, :$bin) } -multi method post(Str $uri is copy, %form, Bool :$bin, *%header ) { - self.post(URI.new(_clear-url($uri)), %form, |%header) +multi method post(Str $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header ) { + self.post(URI.new(_clear-url($uri)), %form, $strict, :$bin, |%header) } proto method put(|) {*} -multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(PUT => $uri, |%header); +multi method put(URI $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header) { + $strict ||= $!strict; + my $request = HTTP::Request.new($strict, PUT => $uri, |%header); $request.add-form-data(%form); - self.request($request, :$bin) + self.request($request, $strict, :$bin) } -multi method put(Str $uri is copy, %form, Bool :$bin, *%header ) { - self.put(URI.new(_clear-url($uri)), %form, |%header) +multi method put(Str $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header ) { + self.put(URI.new(_clear-url($uri)), %form, $strict, |%header) } proto method delete(|) {*} -multi method delete(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request.new(DELETE => $uri, |%header); - self.request($request, :$bin) +multi method delete(URI $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { + $strict ||= $!strict; + my $request = HTTP::Request.new($strict, DELETE => $uri, |%header); + self.request($request, $strict, :$bin) } -multi method delete(Str $uri is copy, Bool :$bin, *%header ) { - self.delete(URI.new(_clear-url($uri)), :$bin, |%header) +multi method delete(Str $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { + self.delete(URI.new(_clear-url($uri)), $strict, :$bin, |%header) } -method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { +method request(HTTP::Request $request, Bool $strict is copy = False, Bool :$bin --> HTTP::Response:D) { + $strict ||= $!strict; my HTTP::Response $response; # add cookies to the request @@ -151,11 +165,11 @@ method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { # if auth has been provided add it to the request self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; + $.debug-handle.say("==>>Send\n" ~ $request.Str($strict, :debug)) if $.debug; my Connection $conn = self.get-connection($request); - if $conn.send-request($request) { - $response = self.get-response($request, $conn, :$bin); + if $conn.send-request($request, $strict) { + $response = self.get-response($request, $conn, $strict, :$bin); } $conn.close; @@ -171,8 +185,8 @@ method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { if $.max-redirects < $.redirects-in-a-row { X::HTTP::Response.new(:rc('Max redirects exceeded'), :response($response)).throw; } - my $new-request = $response.next-request(); - return self.request($new-request); + my $new-request = $response.next-request($strict); + return self.request($new-request, $strict); } else { $!redirects-in-a-row = 0; @@ -260,7 +274,8 @@ method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { $content } -method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { +method get-response(HTTP::Request $request, Connection $conn, Bool $strict is copy = False, Bool :$bin --> HTTP::Response:D) { + $strict ||= $!strict; my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; @@ -298,7 +313,7 @@ method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTT } - my HTTP::Response $response = HTTP::Response.new($header-chunk); + my HTTP::Response $response = HTTP::Response.new($header-chunk, $strict); $response.request = $request; if $response.has-content { diff --git a/t/011-headers-strict.rakutest b/t/011-headers-strict.rakutest new file mode 100644 index 0000000..a40e2fa --- /dev/null +++ b/t/011-headers-strict.rakutest @@ -0,0 +1,98 @@ +use Test; +use HTTP::UserAgent; +use HTTP::Header; + +plan 24; + +my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; + +# new +my $h = HTTP::Header.new($STRICT, a => "A", b => "B"); + +is ~$h.field('b'), 'B', 'new'; + +# field +is ~$h.field('a'), 'A', 'field 1/4'; + +$h.field(a => ['a', 'a1']); +is ~$h.field('a'), 'a, a1', 'field 2/4'; + +$h.field(a => 'a'); +is ~$h.field('a'), 'a', 'field 3/4'; + +# case insensitive +is ~$h.field('A'), 'a', 'field 4/4'; + +# init-field +$h.init-field(b => 'b'); +is ~$h.field('b'), 'B', 'init-field 1/1'; + +# push-field +$h.push-field(a => ['a2', 'a3']); +is ~$h.field('a'), 'a, a2, a3', 'push-field 1/1'; + +# header-field-names +is $h.header-field-names.elems, 2, 'header-field-names 1/3'; +is any($h.header-field-names), 'a', 'header-field-names 2/3'; +is any($h.header-field-names), 'b', 'header-field-names 3/3'; + +# Str +is-deeply $h.Str($STRICT), "a: a, a2, a3{$CRLF}b: B$CRLF", 'Str 1/2'; +is-deeply $h.Str('|', $STRICT), "a: a, a2, a3{$CRLF}b: B$CRLF", 'Str 2/2'; + +# remove-field +$h.remove-field('a'); +ok not $h.field('a'), 'remove-field 1/1'; + +# clear +$h.clear; +ok not $h.field('b'), 'clear 1/1'; + +$h = HTTP::Header.new($STRICT, One => "one", Two => "two"); + +is $h.hash, "one", "Got one (hash 1/2)"; +is $h.hash, "two", "Got two (hash 2/2)"; + +$h = HTTP::Header.new: $STRICT; + +lives-ok { $h.parse('ETag: W/"1201-51b0ce7ad3900"', $STRICT) }, "parses ETag"; +is ~$h.field('ETag'), "1201-51b0ce7ad3900", "got the value we expected"; +ok $h.field('ETag').weak, 'weak ETag'; + +lives-ok { $h.parse('expires: Wed, 27 Jan 2016 17:44:43 GMT', $STRICT) }, "parses date on a Wed"; +ok $h.field('expires') ~~ /^^Wed/, "Does not trip start of field value starting with 'W'"; + +# ugexe++ -- See http://irclog.perlgeek.de/perl6/2017-09-27#i_15227591 +lives-ok { $h.parse('Custom-Auth-Header-Strict: W/7fhEfhkjafeHF', $STRICT) }, "parses ETag like"; +is ~$h.field('Custom-Auth-Header-Strict'), 'W/7fhEfhkjafeHF', 'got the non truncated value'; + +subtest { + plan 3; + my $htest = q:to/EOH/.subst: "\n", $CRLF, :g; +Cache-Control: max-age=21600 +Connection: close +Date: Mon, 25 Jan 2016 17:44:43 GMT +Accept-Ranges: bytes +ETag: "276-422ea2b4cfcc0" +Server: Apache/2 +Vary: upgrade-insecure-requests +Content-Length: 630 +Content-Type: text/html +Expires: Mon, 25 Jan 2016 23:44:43 GMT +Last-Modified: Thu, 23 Nov 2006 13:37:31 GMT +Client-Date: Mon, 25 Jan 2016 17:44:43 GMT +Client-Peer: 128.30.52.100:80 +Client-Response-Num: 1 +Link: ; rel="stylesheet" +P3P: policyref="http://www.w3.org/2014/08/p3p.xml" +Title: Test of a utf8 page served as text/html with UTF8 BOM +EOH + my $h = HTTP::Header.new: $STRICT; + $h.parse($htest, $STRICT); + is $h.fields.elems,17, "got the number of fields we expected"; + ok $h.field('ETag').weak.defined, 'ETag\'s weakness is defined'; + nok $h.field('ETag').weak, 'non-weak ETag'; +}, "test full parse of problematic header"; + +# vim: expandtab shiftwidth=4 diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest new file mode 100644 index 0000000..dbf2ce0 --- /dev/null +++ b/t/021-message-issue-226.rakutest @@ -0,0 +1,197 @@ +use Test; + +use HTTP::UserAgent; + +plan 23; + +my constant $CRLF = "\x[0d]\x[0a]"; +my constant $STRICT = True; + +################################################################################ + +# new +my $m = HTTP::Message.new('somecontent', $STRICT, a => ['a1', 'a2']); + +isa-ok $m, HTTP::Message, 'new 1/4'; +isa-ok $m.header, HTTP::Header, 'new 2/4'; +is $m.field('a'), 'a1, a2', 'new 3/4'; +is $m.content, 'somecontent', 'new 4/4'; + +# push-field +$m.push-field(a => 'a3'); +is $m.field('a'), 'a1, a2, a3', 'push-field 1/2'; +$m.push-field(a => ); +is $m.field('a'), 'a1, a2, a3, a4, a5', 'push-field 2/2'; + +# add-content +$m.add-content('some'); +is $m.content, 'somecontentsome', 'add-content 1/2'; + +$m.add-content('line'); +is $m.content, 'somecontentsomeline', 'add-content 2/2'; + +# remove-field +$m.remove-field('a'); +nok $m.field('a'), 'remove-field 1/1'; + +# parse +# this test message is invalid according to RFC 7230, section 3.3.3, item 6. +# the expected value has been modified to include the trailing CRLF, which +# is taken to be part of the content +my $to_parse = "GET site HTTP/1.0{$CRLF}a: b, c{$CRLF}a: d$CRLF" + ~ "{$CRLF}line$CRLF"; +$m.parse($to_parse, $STRICT); +is $m.field('a'), 'b, c, d', 'parse 1/4'; +is $m.field('a').values[0], 'b', 'parse 2/4'; +is $m.content, "line$CRLF", 'parse 3/4'; +is $m.protocol, 'HTTP/1.0', 'parse 4/4'; + +# Str +# please see explanation to preceeding parse tests. +is $m.Str($STRICT), "a: b, c, d{$CRLF}Content-Length: 6{$CRLF x 2}line$CRLF", 'Str'; + +# clear +$m.clear; +is $m.Str($STRICT), $CRLF, 'clear 1/2 - body-less messages require final CRLF'; +is $m.content, '', 'clear 2/2'; + +## parse a more complex example +# new +my $m2 = HTTP::Message.new: $STRICT; + +# parse +$to_parse = "HTTP/1.1 200 OK\r\n" + ~ "Server: Apache/2.2.3 (CentOS)\r\n" + ~ "Last-Modified: Sat, 31 May 2014 16:39:02 GMT\r\n" + ~ "ETag: \"16d3e2-20416-4fab4ccb03580\"\r\n" + ~ "Vary: Accept-Encoding\r\n" + ~ "Content-Type: text/plain; charset=UTF-8\r\n" + ~ "Transfer-Encoding: chunked\r\n" + ~ "Date: Mon, 02 Jun 2014 17:07:52 GMT\r\n" + ~ "X-Varnish: 1992382947 1992382859\r\n" + ~ "Age: 40\r\n" + ~ "Via: 1.1 varnish\r\n" + ~ "Connection: close\r\n" + ~ "X-Served-By: eu3.develooper.com\r\n" + ~ "X-Cache: HIT\r\n" + ~ "X-Cache-Hits: 2\r\n" + ~ "\r\n" + ~ "008000\r\n" + ~ "# Last updated Sat May 31 16:39:01 2014 (UTC)\n" + ~ "# \n" + ~ "# Explanation of the syntax:\n"; +$m2.parse($to_parse, $STRICT); + +# quotes generally not considered part of the content. please see +# RFC 9110, section 5.5, second-to-last paragraph +# (https://datatracker.ietf.org/doc/html/rfc9110#name-field-values) +# and section 5.6.4 +# (https://datatracker.ietf.org/doc/html/rfc9110#name-quoted-strings) +# is ~$m2.field('ETag'), '"16d3e2-20416-4fab4ccb03580"', 'parse complex 1/3'; +is ~$m2.field('ETag'), '16d3e2-20416-4fab4ccb03580', 'parse complex 1/3'; +is ~$m2.field('Transfer-Encoding'), 'chunked', 'parse complex 2/3'; +is ~$m2.field('Content-Type'), 'text/plain; charset=UTF-8', 'parse complex 3/3'; + +subtest { + is HTTP::Message.new($STRICT).charset, 'iso-8859-1', "dumb default charset"; + is HTTP::Message.new($STRICT, Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; + is HTTP::Message.new($STRICT, Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; + is HTTP::Message.new($STRICT, Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; +}, "charset"; + +################################################################################ + +subtest { + plan 8; + my Str:D $to-parse = join $CRLF, + 'POST /site HTTP/1.1', # request line + 'Content-Type: text/plain', # header + 'Transfer-Encoding: chunked', # header + '', # end of header + '6', # chunk size + '- four', # chunk data + '0', # last chunk + $CRLF, # end of chunk body + ; # FIXME : does not test: trailer, chunk extension, binary + my HTTP::Request:D $m = HTTP::Request.new($STRICT).parse: $to-parse, $STRICT; + + is $m.protocol, 'HTTP/1.1', 'protocol'; + is $m.field('Transfer-Encoding'), 'chunked', 'parsed header'; + is $m.content, '- four', 'parsed content'; + ok $m.is-text, 'text'; + nok $m.is-binary, 'not binary data'; + + $m.remove-field: 'Transfer-Encoding'; + + my Str:D $expected = join $CRLF, + 'POST /site HTTP/1.1', # request line + 'Content-Type: text/plain', # header + 'Content-Length: 6', # header + '', # end of header + '- four' # chunk data + ; + + is $m.Str($STRICT), $expected, 'Str'; + + # add-content + $m.add-content: "\n- five"; + is $m.content, "- four\n- five", 'add-content'; + + $expected = join $CRLF, + 'POST /site HTTP/1.1', # request line + 'Content-Type: text/plain', # header + 'Content-Length: 13', # header + '', # end of header + "- four\n- five", # content + ; # FIXME : does not test: trailer, chunk extension, binary + is $m.Str($STRICT), $expected, 'non-chunked Str'; +}, 'chunked request'; + + + +subtest { + plan 5; + # parse + my Str:D $to_parse = "HTTP/1.1 200 OK\r\n" + ~ "Content-Length: 3\r\n" + ~ "\r\n" + ~ "a\nb"; + my HTTP::Response:D $m2 = HTTP::Response.new(200, $STRICT).parse($to_parse, $STRICT); + ok $m2.is-text, 'text'; + nok $m2.is-binary, 'not binary'; + is $m2.field('Content-Length'), '3', 'Content-Length'; + is $m2.content, "a\nb", 'non-chunked content ok'; + is $m2.Str($STRICT), $to_parse, 'non-chunked Str'; +}, 'parse non-chunked response'; + + + +subtest { + plan 3; + # parse + my Str:D $to_parse = join $CRLF, + 'HTTP/1.1 200 OK', + 'Transfer-Encoding: chunked', + '', + '3', + "a\nb", + '0', + '' + ; + my HTTP::Response:D $m2 = HTTP::Response.new(200, $STRICT).parse($to_parse, $STRICT); + ok $m2.is-text, 'text'; + nok $m2.is-binary, 'not binary'; + + $m2.remove-field: 'Transfer-Encoding'; + + my Str:D $expected = join $CRLF, + 'HTTP/1.1 200 OK', # request line + 'Content-Length: 3', # header + '', # end of header + "a\nb", # chunk data + ; + + is $m2.Str($STRICT), $expected, 'Str'; +}, 'parse chunked response'; + +# vim: expandtab shiftwidth=4 diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest new file mode 100644 index 0000000..0a3f15e --- /dev/null +++ b/t/042-request-issue-226.rakutest @@ -0,0 +1,139 @@ +use Test; + +use URI; +use HTTP::UserAgent; + +plan 27; + +my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; + +############################################################################### + +my $url = 'http://testsite.ext/cat/f.h?q=1&q=2'; +my $file = '/cat/f.h?q=1&q=2'; +my $host = 'testsite.ext'; + +# new +my $r1 = HTTP::Request.new($STRICT, POST => $url, test_field => 'this_is_field'); + +is $r1.method, 'post'.uc, 'new 1/6'; +is $r1.url, $url, 'new 2/6'; +is $r1.file, $file, 'new 3/6'; +is $r1.field('Host'), $host, 'new 4/6'; +is $r1.field('test_field'), 'this_is_field', 'new 5/6'; +ok $r1.Str ~~ /^POST\s$file/, 'new 6/6'; + +# content +$r1.add-content('n1=v1&a'); +is $r1.content, 'n1=v1&a', 'content 1/1'; + +# field +$r1.field(Accept => 'test'); +is $r1.field('Accept'), 'test', 'field 1/2'; +$r1.field(Accept => 'test2'); +is $r1.field('Accept'), 'test2', 'field 2/2'; + +# uri +$file = '/cat/b.a?r=1&r=2'; +$r1.uri('http://test.com' ~ $file); +is $r1.url, 'http://test.com' ~ $file, 'uri 1/4'; +is $r1.field('Host'), 'test.com', 'uri 2/4'; +is $r1.file, $file, 'uri 3/4'; +ok $r1.Str ~~ /^POST\s$file/, 'uri 4/4'; + +# check construction of host header +$r1.uri('http://test.com:8080'); +is $r1.url, 'http://test.com:8080', 'uri 3/4'; +is $r1.field('Host'), 'test.com:8080', 'uri 4/4'; + +# set-method +throws-like({ $r1.set-method: 'TEST' }, /'expected HTTP::Request::RequestMethod but got Str'/, "rejects wrong method"); +lives-ok { $r1.set-method: 'PUT' }, "set method"; +is $r1.method, 'PUT', 'set-method 1/1'; + +# parse +my $req = "GET /index HTTP/1.1\r\nHost: somesite\r\nAccept: test\r\n\r\nname=value&a=b\r\n"; +my $exp = "GET /index HTTP/1.1\r\nHost: somesite\r\nAccept: test\r\nContent-Length: 16\r\n\r\nname=value&a=b\r\n"; +$r1 = HTTP::Request.new.parse($req, $STRICT); + +is $r1.method, 'get'.uc, 'parse 1/6'; +is $r1.file, '/index', 'parse 2/6'; +is $r1.url, 'http://somesite/index', 'parse 3/6'; +is $r1.field('Accept'), 'test', 'parse 4/6'; +is $r1.content, "name=value\&a=b$CRLF", 'parse 5/6'; +is $r1.Str($STRICT), $exp, 'parse 6/6'; + +subtest { + my $r; + lives-ok { $r = HTTP::Request.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new($STRICT, Foo => 'bar'), $STRICT ) }, "new with positionals"; + is $r.method, 'GET', "right method"; + is $r.file, '/bar', "right file"; + is $r.field('Host'), 'foo.com', 'got right host'; +}, "positional construcutor"; + +subtest { + subtest { + my $req = HTTP::Request.new($STRICT, POST => URI.new('http://127.0.0.1/')); + lives-ok { $req.add-form-data({ foo => "b&r\x1F42B", }) }, "add-form-data"; + is $req.method, 'POST'; + is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; + is $req.header.field('content-length'), '21'; + is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; + }, 'add-form-data with positional Hash'; + subtest { + my $req = HTTP::Request.new($STRICT, POST => URI.new('http://127.0.0.1/')); + lives-ok { $req.add-form-data( foo => "b&r\x1F42B", ) }, "add-form-data"; + is $req.method, 'POST'; + is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; + is $req.header.field('content-length'), '21'; + is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; + }, 'add-form-data with slurpy hash'; + subtest { + my $req = HTTP::Request.new($STRICT, POST => 'http://127.0.0.1/', X-Foo => 'Bar'); + lives-ok { $req.add-form-data([foo => "b&r\x1F42B",]) }, "add-form-data with array of pairs"; + is $req.method, 'POST'; + is $req.header.field('content-type'), 'application/x-www-form-urlencoded'; + is $req.header.field('content-length'), '21'; + is $req.header.field('X-Foo'), 'Bar'; + is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; + }, 'content by array'; + subtest { + # need to set the host up front so it compares with the data nicely + my $req = HTTP::Request.new($STRICT, POST => 'http://127.0.0.1/', Host => '127.0.0.1', content-type => 'multipart/form-data; boundary=XxYyZ'); + lives-ok { $req.add-form-data({ foo => "b&r", x => ['t/dat/foo.txt'], }) }, "add-form-data"; + todo("issue seen on travis regarding line endings"); + is-deeply Buf[uint8].new($req.Str.encode), slurp("t/dat/multipart-1.dat", :bin); + }, 'multipart implied by existing content-type'; + subtest { + my $req = HTTP::Request.new($STRICT, POST => 'http://127.0.0.1/'); + lives-ok { $req.add-form-data({ foo => "b&r", x => ['t/dat/foo.txt'], }, :multipart) }, "add-form-data"; + like $req.header.field('content-type').Str, rx|'multipart/form-data'|, "and got multipart data"; + }, 'multipart explicit'; + subtest { + my $req = HTTP::Request.new($STRICT, POST => 'http://127.0.0.1/'); + lives-ok { $req.add-form-data( foo => "b&r", x => ['t/dat/foo.txt'], :multipart) }, "add-form-data"; + like $req.header.field('content-type').Str, rx|'multipart/form-data'|, "and got multipart data"; + }, 'multipart explicit with slurpy hash (check no gobble adverb)'; +}, 'add-form-data'; + +############################################################################### + +$host = 'dne.site'; +my Str:D $resource = 'resource'; +$url = "http://$host/$resource"; + +my Str:D $expected = join $CRLF, + "POST /$resource HTTP/1.1", # request line + "Host: $host", # header + 'Content-Length: 13', # header + '', # end of header + "- four\n- five", # content +; # FIXME : does not test: trailer, chunk extension, binary + +my HTTP::Request $r = + HTTP::Request.new: $STRICT, POST => $url; +$r.add-content: "- four\n- five"; +is $r.Str($STRICT), $expected, 'build non-chunked post'; + +# vim: expandtab shiftwidth=4 diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest new file mode 100644 index 0000000..8ae84d5 --- /dev/null +++ b/t/051-response-issue-226.rakutest @@ -0,0 +1,105 @@ +use Test; + +use HTTP::UserAgent; + +plan 27; + +my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; + +############################################################################### + +# new +my $r = HTTP::Response.new(200, $STRICT, a => 'a'); + +is $r.field('a'), 'a', 'new'; + +# field +$r.field(h => 'h'); +is $r.field('h'), 'h', 'field 1/2'; +$r.field(h => 'abc'); +is $r.field('h'), 'abc', 'field 2/2'; + +# status-line +is $r.status-line, '200 OK', 'status-line 1/1'; + +# is-success +ok $r.is-success, 'is-success 1/2'; +## 200-300 status is-success +$r.set-code(204); +ok $r.is-success, 'is-success 2/2'; +$r.set-code(404); +ok !$r.is-success, 'is-success 2/3'; + +# set-code +is $r.status-line, '404 Not Found', 'set-code 1/1'; + +# parse +my $res = "HTTP/1.1 200 OK\r\nHost: hoscik\r\n\r\ncontent\r\n"; +my $exp = "HTTP/1.1 200 OK\r\nHost: hoscik\r\nContent-Length: 9\r\n\r\ncontent\r\n"; +$r = HTTP::Response.new(200, $STRICT).parse($res, $STRICT); +is $r.Str, $exp, 'parse - Str 1/4'; +is $r.content, "content$CRLF", 'parse - content 2/4'; +is $r.status-line, '200 OK', 'parse - status-line 3/4'; +is $r.protocol, 'HTTP/1.1', 'parse - protocol 4/4'; + +# has-content + +$r = HTTP::Response.new(204, $STRICT); +ok !$r.has-content, "has-content 1/3"; +$r.set-code(304); +ok !$r.has-content, "has-content 2/3"; +$r.set-code(200); +ok $r.has-content, "has-content 3/3"; + +my $buf = Buf[uint8].new(72, 84, 84, 80, 47, 49, 46, 49, 32, 52, 48, 51, 32, 70, 111, 114, 98, 105, 100, 100, 101, 110, 13, 10, 68, 97, 116, 101, 58, 32, 84, 104, 117, 44, 32, 50, 50, 32, 79, 99, 116, 32, 50, 48, 49, 53, 32, 49, 50, 58, 50, 48, 58, 53, 52, 32, 71, 77, 84, 13, 10, 83, 101, 114, 118, 101, 114, 58, 32, 65, 112, 97, 99, 104, 101, 47, 50, 46, 52, 46, 49, 54, 32, 40, 70, 101, 100, 111, 114, 97, 41, 32, 79, 112, 101, 110, 83, 83, 76, 47, 49, 46, 48, 46, 49, 107, 45, 102, 105, 112, 115, 32, 109, 111, 100, 95, 112, 101, 114, 108, 47, 50, 46, 48, 46, 57, 32, 80, 101, 114, 108, 47, 118, 53, 46, 50, 48, 46, 51, 13, 10, 76, 97, 115, 116, 45, 77, 111, 100, 105, 102, 105, 101, 100, 58, 32, 70, 114, 105, 44, 32, 49, 55, 32, 74, 117, 108, 32, 50, 48, 49, 53, 32, 48, 55, 58, 49, 50, 58, 48, 52, 32, 71, 77, 84, 13, 10, 69, 84, 97, 103, 58, 32, 34, 49, 50, 48, 49, 45, 53, 49, 98, 48, 99, 101, 55, 97, 100, 51, 57, 48, 48, 34, 13, 10, 65, 99, 99, 101, 112, 116, 45, 82, 97, 110, 103, 101, 115, 58, 32, 98, 121, 116, 101, 115, 13, 10, 67, 111, 110, 116, 101, 110, 116, 45, 76, 101, 110, 103, 116, 104, 58, 32, 52, 54, 48, 57, 13, 10, 67, 111, 110, 110, 101, 99, 116, 105, 111, 110, 58, 32, 99, 108, 111, 115, 101, 13, 10, 67, 111, 110, 116, 101, 110, 116, 45, 84, 121, 112, 101, 58, 32, 116, 101, 120, 116, 47, 104, 116, 109, 108, 59, 32, 99, 104, 97, 114, 115, 101, 116, 61, 85, 84, 70, 45, 56, 13, 10, 13, 10, 13, 10); + +lives-ok { $r = HTTP::Response.new($buf, $STRICT) }, "create Response from a Buf"; +is $r.code, 403, "got the code we expected"; +is $r.field('ETag').values[0], "1201-51b0ce7ad3900", "got a header we expected"; + +lives-ok { $r = HTTP::Response.new(200, $STRICT, Content-Length => "hsh") }, "create a response with a Content-Length"; +throws-like { $r.content-length }, X::HTTP::ContentLength; +lives-ok { $r = HTTP::Response.new(200, $STRICT, Content-Length => "888") }, "create a response with a Content-Length"; +lives-ok { $r.content-length }, "content-length lives"; +is $r.content-length, 888, "got the right value"; +isa-ok $r.content-length, Int, "and it is an Int"; + +subtest { + my $r; + throws-like { $r = HTTP::Response.new(Buf.new, $STRICT) }, X::HTTP::NoResponse, "create with an empty buf"; + my $garbage = Buf.new(('a' .. 'z', 'A' .. 'Z').pick(20).map({$_.ords}).flat); + lives-ok { + $r = HTTP::Response.new($garbage, $STRICT); + }, "create with garbage"; + is $r.code, 500, "and got a 500 response"; + +}, "failure modes"; + +subtest { + my $res = HTTP::Response.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode, $STRICT; + is $res.status-line, '200 OK', 'Can parse responses with non-ASCII header values'; + is $res.header.field('X-Duck'), "ð\x[9F]¦\x[86]", 'Header value decoded as ISO-8859-1'; +}, 'Non-ASCII header values'; + +############################################################################### + +subtest { + plan 4; + my $r = HTTP::Response.new: 200, $STRICT; + my Str:D $expected = join $CRLF, + 'HTTP/1.1 200 OK', # status line + 'Content-Length: 7', # header + 'Content-Type: text/plain', # header + '', # end header + 'content', # content + ; + $r.field: Content-Type => 'text/plain', Content-Length => '7'; + $r.add-content: 'content'; + ok $r.is-text, 'is text'; + nok $r.is-binary, 'not binary'; + is $r.content, 'content', 'content'; + is $r.Str($STRICT), $expected, 'Str'; +}, 'build non-chunked Str'; + +# vim: expandtab shiftwidth=4 diff --git a/t/081-ua-strict-interop.rakutest b/t/081-ua-strict-interop.rakutest new file mode 100644 index 0000000..4d598df --- /dev/null +++ b/t/081-ua-strict-interop.rakutest @@ -0,0 +1,67 @@ +use lib ; + +use Test; +use HTTP::UserAgent; +use HTTP::Request; +use Test::Util::ServerPort; +use TestServer; + +my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; + +plan 3; + +my $port = get-unused-port; + +%*ENV = 'localhost'; + +my $test-server = test-full-message my $done-promise = Promise.new, :$port; + +say 'using port ', $port; + +subtest { + plan 2; + my $uas = HTTP::UserAgent.new: $STRICT; + my $rs = $uas.post: "http://localhost:$port/POST", { hello => 'world' }; + my ( $eol, $lok ) = $rs.content.split: "\x0d"; + is $eol, 'F', 'no extra eol'; + is $lok, 'T', 'length matches'; +}, 'UA:strict passes strict to method calls not requesting :strict explicitly'; + +subtest { + plan 4; + my $ual = HTTP::UserAgent.new: not $STRICT; + my $rl = $ual.post: "http://localhost:$port/POST", { hello => 'world' }; + my ( $eol, $lok ) = $rl.content.split: "\x0d"; + is $eol, 'T', 'UA:!strict sends extra eol'; + is $lok, 'F', 'UA:!strict sends mismatched lengths'; + my $rq = HTTP::Request.new: $STRICT; + $rq.set-method: 'POST'; + $rq.uri: "http://localhost:$port/ualenientmsgstrict"; + $rq.add-content: 'hello=world'; + my $rs = $ual.request: $rq, $STRICT; + ( $eol, $lok ) = $rs.content.split: "\x0d"; + is $eol, 'F', 'UA:!strict with Message:strict - no extra eol'; + is $lok, 'T', 'UA:!strict with Message:strict - length matches'; +}, 'UA:!strict can use Message:strict'; + +subtest { + plan 4; + my $uas = HTTP::UserAgent.new: $STRICT; + my $rs = $uas.post: "http://localhost:$port/POST", { hello => 'world' }; + my ( $eol, $lok ) = $rs.content.split: "\x0d"; + is $eol, 'F', 'no extra eol'; + is $lok, 'T', 'length matches'; + my $rq = HTTP::Request.new: not $STRICT; + $rq.set-method: 'POST'; + $rq.uri: "http://localhost:$port/uastrictmsglenient"; + $rq.add-content: 'hello=world'; + $rs = $uas.request: $rq; + ( $eol, $lok ) = $rs.content.split: "\x0d"; + is $eol, 'F', 'UA:strict with Message:!strict - no extra eol'; + is $lok, 'T', 'UA:strict with Message:!strict - length matches'; +}, 'UA:strict is still strict with Message:!strict'; + +$done-promise.keep: 'shutdown'; + +# UA:strict with Message:!strict diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest new file mode 100644 index 0000000..17dc0a1 --- /dev/null +++ b/t/081-ua-strict.rakutest @@ -0,0 +1,113 @@ +use HTTP::UserAgent; +use HTTP::UserAgent::Common; +use Test; + +use URI; + +plan 11; + +my constant $STRICT = True; + +# new +my $ua = HTTP::UserAgent.new: $STRICT; +nok $ua.useragent, 'new 1/3'; + +$ua = HTTP::UserAgent.new: useragent => 'test', $STRICT; +is $ua.useragent, 'test', 'new 2/3'; + +my $newua = get-ua('chrome_linux'); +$ua = HTTP::UserAgent.new: useragent => 'chrome_linux', $STRICT; +is $ua.useragent, $newua, 'new 3/3'; + +if %*ENV { +# user agent + like $ua.get('http://httpbin.org/user-agent', $STRICT).content, /$newua/, 'useragent 1/1'; + +# get + todo "possibly flaky host", 4; + lives-ok { + my $response = $ua.get('github.com/', $STRICT); + ok $response, 'get 1/3'; + isa-ok $response, HTTP::Response, 'get 2/3'; + ok $response.is-success, 'get 3/3'; + }, "get from 'github.com/'"; + +# non-ascii encodings (github issue #35) + lives-ok { HTTP::UserAgent.new($STRICT).get('http://www.baidu.com', $STRICT) }, 'Lived through gb2312 encoding'; + +# chunked encoding. + + skip 'Site changed. Need new site to cover this problem See #208'; +# lives-ok { HTTP::UserAgent.new.get('http://rakudo.org') }, "issue#51 - get rakudo.org (chunked encoding foul-up results in incomplete UTF-8 data)"; + + subtest { + my Bool $have-json = True; + CATCH { + when X::CompUnit::UnsatisfiedDependency { + $have-json = False; + } + } + use JSON::Fast; + + my $uri = 'http://httpbin.org/post'; + my %data = (foo => 'bar', baz => 'quux'); + subtest { + my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; + my %data = :72foo, :bar<♵>; + my $ua = HTTP::UserAgent.new: $STRICT; + my $res; + lives-ok { $res = $ua.post(URI.new($uri), %data, $STRICT, X-Foo => "foodle") }, "new make post"; + my $ret-data; + + if $have-json { + lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; + + is $ret-data, 'foodle', "has got our header"; + is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; + is-deeply $ret-data
, %data, "and we sent the right params"; + } + else { + skip("no json parser", 4); + } + }, "with URI object"; + subtest { + my $ua = HTTP::UserAgent.new: $STRICT; + my $res; + lives-ok { $res = $ua.post(URI.new($uri), %data, $STRICT, X-Foo => "foodle") }, "make post"; + my $ret-data; + + if $have-json { + lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; + + is $ret-data, 'foodle', "has got our header"; + is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; + is-deeply $ret-data, %data, "and we sent the right params"; + } + else { + skip("no json parser", 4); + } + }, "with URI object"; + subtest { + my $ua = HTTP::UserAgent.new: $STRICT; + my $res; + lives-ok { $res = $ua.post($uri, %data, $STRICT, X-Foo => "foodle") }, "make post"; + my $ret-data; + if $have-json { + lives-ok { $ret-data = from-json($res.decoded-content) }, "get JSON body"; + + is $ret-data, 'foodle', "has got our header"; + is $ret-data, "application/x-www-form-urlencoded", "and got the content type we expected"; + is-deeply $ret-data, %data, "and we sent the right params"; + } + else { + skip("no json parser", 4); + + } + }, "with URI string"; + }, "post"; +} +else { + skip "NETWORK_TESTING not set", 8; +} + +# vim: expandtab shiftwidth=4 diff --git a/t/lib/TestServer.rakumod b/t/lib/TestServer.rakumod index 733baf5..b15f3eb 100644 --- a/t/lib/TestServer.rakumod +++ b/t/lib/TestServer.rakumod @@ -62,6 +62,35 @@ module TestServer { } $server-promise } + + use HTTP::Request; + my constant $STRICT = True; + sub test-full-message ( Promise $done-promise, Int :$port --> Promise:D ) is export { + start { + react { + whenever $done-promise { + done; + } + whenever IO::Socket::Async.listen: 'localhost', $port -> $conn { + whenever $conn.Supply: :bin -> $buf { + my HTTP::Request $r = HTTP::Request.new: $STRICT; + $r.parse: $buf.decode, $STRICT; + my ( $eol, $okl ); + $eol = $r.content.ends-with: "\x0d\x0a"; + $okl = $r.content.chars == .values.head.Int with $r.field: 'Content-Length'; + my $out-buf = + Buf.new: + 'HTTP/1.1 200 OK'.comb>>.ord, 13, 10, + 'Content-Length: 3'.comb>>.ord, 13, 10, + 13, 10, + ( $eol ?? 'T'.ord !! 'F'.ord ), 13, ( $okl ?? 'T'.ord !! 'F'.ord ); + $conn.write: $out-buf; + $conn.close; + } + } + } + } + } } # vim: expandtab shiftwidth=4