From 1e9da7bb7df8de55f76b6d85fad1f09ce946c78e Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Thu, 8 Jan 2026 09:25:55 -0800 Subject: [PATCH 01/28] preliminary minimal changes --- lib/HTTP/Message.rakumod | 39 ++++++++++- lib/HTTP/UserAgent.rakumod | 4 +- t/021-message-issue-226.rakutest | 106 ++++++++++++++++++++++++++++++ t/042-request-issue-226.rakutest | 27 ++++++++ t/051-response-issue-226.rakutest | 47 +++++++++++++ 5 files changed, 220 insertions(+), 3 deletions(-) create mode 100644 t/021-message-issue-226.rakutest create mode 100644 t/042-request-issue-226.rakutest create mode 100644 t/051-response-issue-226.rakutest diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 56865e6..8155b35 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -103,6 +103,18 @@ method is-text(--> Bool:D) { method is-binary(--> Bool:D) { !self.is-text } +method is-chunked(--> Bool:D) { +# 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 + + # TODO : uncomment after confirming testcase + my $enc = self.field('Transfer-Encoding'); + so $enc and $enc.Str.trim.lc.ends-with: 'chunked' +# # TODO : remove after implementing +# ... +} + method content-encoding() { $!header.field('Content-Encoding'); } @@ -191,7 +203,8 @@ method parse($raw_message) { else { # is a response $.protocol = $first; } - + + my Bool:D $tec = False; loop { last until @lines; @@ -199,12 +212,21 @@ method parse($raw_message) { if $line { my ($k, $v) = $line.split(/\:\s*/, 2); if $k and $v { + $tec = True if $k eq 'Transfer-Encoding' + and $v.trim.lc.ends-with: 'chunked'; if $.header.field($k) { $.header.push-field: |($k => $v.split(',')>>.trim); } else { $.header.field: |($k => $v.split(',')>>.trim); } } + } elsif $tec { + # chunked, add zero-length Str to end as size 0 chunk + @lines.push: '' if +@lines % 2; + $!content = join '', + grep *, + @lines.map: -> $s, $d { $s ~~ /^\d/ ?? $d !! '' }; + last; } else { $.content = @lines.grep({ $_ }).join("\n"); last; @@ -216,12 +238,25 @@ method parse($raw_message) { method Str($eol = "\n", :$debug, Bool :$bin) { my constant $max_size = 300; + # TODO : reference relevant section of relevant RFC + # TODO : need to consider Str vs Buf length ? + self.field(Content-Length => ( $!content.?encode or $!content ).bytes.Str) + if $!content and not self.field: 'Transfer-Encoding'; my $s = $.header.Str($eol); $s ~= $eol if $.content; # The :bin will be passed from the H::UA if not $bin { - $s ~= $.content ~ $eol if $.content and !$debug; + # do not append eol unless chunked + # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 + # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 + # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 + +# # TODO : replace following line with code following it +# $s ~= $.content ~ $eol if $.content and !$debug; + # TODO : uncomment following code for final implementation + $s ~= self.is-chunked ?? $!content !! $!content + if $!content; } if $.content and $debug { if $bin || self.is-binary { diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index d1100e9..c5c9b71 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -23,7 +23,9 @@ role Connection { self.print($request.Str(:bin)); self.write($request.content); } - else { + elsif $request.method.Str eq 'POST' | 'PUT' { + self.print($request.Str); + } else { self.print($request.Str ~ "\r\n"); } } diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest new file mode 100644 index 0000000..02cbc63 --- /dev/null +++ b/t/021-message-issue-226.rakutest @@ -0,0 +1,106 @@ +use Test; +use HTTP::Request; +use HTTP::Response; + +plan 3; + +my constant $CRLF = "\r\n"; + +# construct request - move to request 042-request-issue-226.rakutest +# my $m = HTTP::Message.new: +# 'four', +# Content-Type => 'text/plain', +# Transfer-Encoding => 'chunked' +# ; +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.parse: $to-parse; + + 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, $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, $expected, 'non-chunked Str'; +}, 'chunked request'; + + + +subtest { + plan 4; + # 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.parse($to_parse); + ok $m2.is-text, 'text'; + nok $m2.is-binary, 'not binary'; + is $m2.field('Content-Length'), '3', 'Content-Length'; + is $m2.Str, $to_parse, 'non-chunked Str'; +}, 'parse non-chunked response'; + + + +subtest { + plan 3; + # parse + my Str:D $to_parse = "HTTP/1.1 200 OK\r\n" + ~ "Transfer-Encoding: chunked\r\n" + ~ "\r\n" + ~ "3\r\n" + ~ "a\nb\r\n" + ~ "0\r\n" + ~ "\r\n" + ; + my HTTP::Response:D $m2 = HTTP::Response.new.parse($to_parse); + 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, $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..5428825 --- /dev/null +++ b/t/042-request-issue-226.rakutest @@ -0,0 +1,27 @@ +use Test; +use URI; +use HTTP::Request; + +plan 1; + +my constant $CRLF = "\r\n"; + +my Str:D $host = 'dne.site'; +my Str:D $resource = 'resource'; +my $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: + POST => $url; +$r.add-content: "- four\n- five"; +is $r.Str, $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..5e3f3ec --- /dev/null +++ b/t/051-response-issue-226.rakutest @@ -0,0 +1,47 @@ +use Test; +use HTTP::Response; + +plan 1; + +my constant $CRLF = "\r\n"; + +# subtest { +# plan 4; +# my $r = HTTP::Response.new; +# my Str:D $expected = join $CRLF, +# 'HTTP/1.1 200 OK', # status line +# 'Content-Type: text/plain', # header +# 'Transfer-Encoding: chunked', # header +# '', # end header +# '7', # chunk size +# 'content', # chunk data +# '0', # last chunk +# $CRLF # end chunk body +# ; +# $r.field: Content-Type => 'text/plain', Transfer-Encoding => 'chunked'; +# $r.add-content: 'content'; +# ok $r.is-text, 'is text'; +# nok $r.is-binary, 'not binary'; +# is $r.content, 'content', 'content'; +# is $r.Str, $expected, 'Str'; +# }, 'build chunked Str'; + +subtest { + plan 4; + my $r = HTTP::Response.new; + 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, $expected, 'Str'; +}, 'build non-chunked Str'; + +# vim: expandtab shiftwidth=4 From 5662117dbf3d7aeaa34fb70f2cd392697ff73a6e Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 24 Jan 2026 14:53:11 -0800 Subject: [PATCH 02/28] initial strict implementation --- lib/HTTP/Cookies.rakumod | 8 +- lib/HTTP/Header.rakumod | 297 ++++++--- lib/HTTP/Header/ETag.rakumod | 12 + lib/HTTP/Message.rakumod | 492 ++++++++------- lib/HTTP/Request.rakumod | 508 ++++++++------- lib/HTTP/Response.rakumod | 193 +++--- lib/HTTP/UserAgent.rakumod | 882 ++++++++++++++++----------- lib/HTTP/UserAgent/Exception.rakumod | 2 +- t/021-message-issue-226.rakutest | 123 +++- t/042-request-issue-226.rakutest | 4 +- t/051-response-issue-226.rakutest | 2 +- 11 files changed, 1556 insertions(+), 967 deletions(-) create mode 100644 lib/HTTP/Header/ETag.rakumod diff --git a/lib/HTTP/Cookies.rakumod b/lib/HTTP/Cookies.rakumod index 35f0a0d..5dc4c1f 100644 --- a/lib/HTTP/Cookies.rakumod +++ b/lib/HTTP/Cookies.rakumod @@ -1,8 +1,8 @@ unit class HTTP::Cookies; use HTTP::Cookie; -use HTTP::Response:auth; -use HTTP::Request:auth; +use HTTP::Response; +use HTTP::Request; use DateTime::Parse; has @.cookies; @@ -44,12 +44,12 @@ my class HTTP::Cookies::Actions { } } -method extract-cookies(HTTP::Response $response) { +method extract-cookies(HTTP::Response-Lenient $response) { self.set-cookie($_) for $response.field('Set-Cookie').grep({ $_.defined }).map({ "Set-Cookie: $_" }).flat; self.save if $.autosave; } -method add-cookie-header(HTTP::Request $request) { +method add-cookie-header(HTTP::Request-Lenient $request) { for @.cookies -> $cookie { # TODO this check sucks, eq is not the right (should probably use uri) #next if $cookie.domain.defined diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index d4223aa..4d6bf3d 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -1,132 +1,235 @@ -unit class HTTP::Header; - use HTTP::Header::Field; -# headers container -has @.fields; +class HTTP::Header-Lenient { -our grammar HTTP::Header::Grammar { - token TOP { - [ \r?\n ]* - } + # headers container + has @.fields; - token message-header { - $=[ <-[:]>+ ] ':' - } + grammar HTTP::Header::Grammar { + token TOP { + [ \r?\n ]* + } - token field-value { - [ ( ['W/' | 'w/'] )? ? - $=[ <-[\r\n"]>+ ] || \h+ ]* - ? - } - token quot { - <['"]> + token message-header { + $=[ <-[:]>+ ] ':' + } + + token field-value { + [ ( ['W/' | 'w/'] )? ? + $=[ <-[\r\n"]>+ ] || \h+ ]* + ? + } + token quot { + <['"]> + } } -} -our class HTTP::Header::Actions { - method message-header($/) { - my $value = $.made; - my $k = ~$; - my @v = $value.Array; + class HTTP::Header::Actions { + method message-header($/) { + my $value = $.made; + my $k = ~$; + my @v = $value.Array; + + @v[0] = $value ~ @v[0] if $value && $k.lc ne 'etag'; + if $k && @v -> $v { + if $*OBJ.field($k) { + $*OBJ.push-field: |($k => $v); + } else { + $*OBJ.field: |($k => $v); + } + } + } - @v[0] = $value ~ @v[0] if $value && $k.lc ne 'etag'; - if $k && @v -> $v { - if $*OBJ.field($k) { - $*OBJ.push-field: |($k => $v); - } else { - $*OBJ.field: |($k => $v); + method field-value($/) { + make { + prefix => $0, + content => $ ?? + $.Str.split(',')>>.trim !! Nil + } } - } } - method field-value($/) { - make { - prefix => $0, - content => $ ?? - $.Str.split(',')>>.trim !! Nil + # we want to pass arguments like this: .new(a => 1, b => 2 ...) + method new(*%fields) { + my @fields = %fields.sort(*.key).map: { + HTTP::Header::Field.new(:name(.key), :values(.value.list)); } - } -} -# we want to pass arguments like this: .new(a => 1, b => 2 ...) -method new(*%fields) { - my @fields = %fields.sort(*.key).map: { - HTTP::Header::Field.new(:name(.key), :values(.value.list)); + self.bless(:@fields) } - self.bless(:@fields) -} + proto method field(|) {*} + + # set fields + multi method field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $f = HTTP::Header::Field.new(:name($k), :values($v.list)); + if @.fields.first({ .name.lc eq $k.lc }) { + @.fields[@.fields.first({ .name.lc eq $k.lc }, :k)] = $f; + } + else { + @.fields.push: $f; + } + } + } -proto method field(|) {*} + # get fields + multi method field($field) { + my $field-lc := $field.lc; + @.fields.first(*.name.lc eq $field-lc) + } -# set fields -multi method field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $f = HTTP::Header::Field.new(:name($k), :values($v.list)); - if @.fields.first({ .name.lc eq $k.lc }) { - @.fields[@.fields.first({ .name.lc eq $k.lc }, :k)] = $f; + # initialize fields + method init-field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $k-lc := $k.lc; + @.fields.push: + HTTP::Header::Field.new(:name($k), :values($v.list)) + unless @.fields.first(*.name.lc eq $k-lc); } - else { - @.fields.push: $f; + } + + # add value to existing fields + method push-field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $k-lc := $k.lc; + @.fields.first(*.name.lc eq $k-lc).values.append: $v.list; } } -} -# get fields -multi method field($field) { - my $field-lc := $field.lc; - @.fields.first(*.name.lc eq $field-lc) -} + # remove a field + method remove-field(Str $field) { + my $field-lc := $field.lc; + @.fields.splice($_, 1) + with @.fields.first(*.name.lc eq $field-lc, :k); + } -# initialize fields -method init-field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $k-lc := $k.lc; - @.fields.push: - HTTP::Header::Field.new(:name($k), :values($v.list)) - unless @.fields.first(*.name.lc eq $k-lc); + # get fields names + method header-field-names() { + @.fields.map(*.name) } -} -# add value to existing fields -method push-field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $k-lc := $k.lc; - @.fields.first(*.name.lc eq $k-lc).values.append: $v.list; + # return the headers as name -> value hash + method hash(--> Hash:D) { + @.fields.map({ $_.name => $_.values }).Hash } -} -# remove a field -method remove-field(Str $field) { - my $field-lc := $field.lc; - @.fields.splice($_, 1) - with @.fields.first(*.name.lc eq $field-lc, :k); -} + # remove all fields + method clear() { + @.fields = (); + } -# get fields names -method header-field-names() { - @.fields.map(*.name) -} + # get header as string + method Str($eol = "\n") { + @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join + } -# return the headers as name -> value hash -method hash(--> Hash:D) { - @.fields.map({ $_.name => $_.values }).Hash + method parse($raw) { + my $*OBJ = self; + HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); + } } -# remove all fields -method clear() { - @.fields = (); -} -# get header as string -method Str($eol = "\n") { - @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join -} +class HTTP::Header-Strict is HTTP::Header-Lenient { + use HTTP::Header::ETag; + + grammar HTTP::Header-Strict::Grammar { + 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 { + \" \" + } + token opaque-content { + <[\x[21]..\x[FF]]-[\x[22]\x[7F]]>* + } + token vchars { <[\x[21]..\x[7E]]>+ } + token field-vchars { <[\x[21]..\x[FF]]-[\x[7F]]>+ } + token value { + [ <[\t\x[20]]>* ]* + } + token quoted-string { + \" \" + } + token quoted-content { + [ | ]* + } + token qtd-text { + <[\t\x[20]..\x[FF]]-[\x[22]\x[5C]\x[7F]]>+ + } + token quotable-char { + <[\t\x[20]..\x[FF]]-[\x[7F]]> + } + token quoted-pair { + \\ + } + } -method parse($raw) { - my $*OBJ = self; - HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); + class HTTP::Header-Strict::Actions { + 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; + } + } + + multi method field ( HTTP::Header::ETag:D $etag ) { + @.fields.push: $etag; + } + + method parse($raw) { + my $*OBJ = self; + HTTP::Header-Strict::Grammar.parse: + $raw, + actions => HTTP::Header-Strict::Actions + ; + } } +# sub EXPORT ( $strict? ) { +# if $strict and $strict eq 'strict' { +# OUR::HTTP::Header := HTTP::Header-Strict; +# } else { +# OUR::HTTP::Header := HTTP::Header-Lenient; +# } +# Map.new; +# } + # 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 8155b35..1db24ea 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -1,276 +1,346 @@ -unit class HTTP::Message; - use HTTP::Header; use HTTP::MediaType; use Encode; -has HTTP::Header $.header = HTTP::Header.new; -has $.content is rw; +class HTTP::Message-Lenient { + + has HTTP::Header-Lenient $.header; # = HTTP::Header.new; + has $.content is rw; -has $.protocol is rw = 'HTTP/1.1'; + has $.protocol is rw = 'HTTP/1.1'; -has Bool $.binary = False; -has Str @.text-types; + has Bool $.binary = False; + has Str @.text-types; -my $CRLF = "\r\n"; + #| see https://docs.raku.org/language/grammars#Attributes_in_grammars + my constant $CRLF = "\x[0d]\x[0a]"; + my constant $DELIM = $CRLF x 2; -method new($content?, *%fields) { - my $header = HTTP::Header.new(|%fields); + method new($content?, *%fields) { + my $header = HTTP::Header-Lenient.new(|%fields); - self.bless(:$header, :$content); -} + self.bless(:$header, :$content); + } -method add-content($content) { - $.content ~= $content; -} + method add-content($content) { + $.content ~= $content; + } -class X::Decoding is Exception { - has HTTP::Message $.response; - has Blob $.content; - method message() { - "Problem decoding content"; + class X::Decoding is Exception { + has HTTP::Message-Lenient $.response; + has Blob $.content; + method message() { + "Problem decoding content"; + } } -} -method content-type(--> Str:D) { - $!header.field('Content-Type').values[0] || ''; -} + method content-type(--> Str:D) { + $!header.field('Content-Type').values[0] || ''; + } -has HTTP::MediaType $!media-type; + has HTTP::MediaType $!media-type; -method media-type(--> HTTP::MediaType) { - without $!media-type { - if self.content-type() -> $ct { - $!media-type = HTTP::MediaType.parse($ct); + method media-type(--> HTTP::MediaType) { + without $!media-type { + if self.content-type() -> $ct { + $!media-type = HTTP::MediaType.parse($ct); + } } + $!media-type } - $!media-type -} -# Don't want to put the heuristic in the HTTP::MediaType -# Also moving this here makes it much more easy to test + # Don't want to put the heuristic in the HTTP::MediaType + # Also moving this here makes it much more easy to test -method charset(--> Str:D) { - if self.media-type -> $mt { - $mt.charset || ( $mt.major-type eq 'text' ?? $mt.sub-type eq 'html' ?? 'utf-8' !! 'iso-8859-1' !! 'utf-8'); - } - else { - # At this point we're probably screwed anyway - 'iso-8859-1' + method charset(--> Str:D) { + if self.media-type -> $mt { + $mt.charset || ( $mt.major-type eq 'text' ?? $mt.sub-type eq 'html' ?? 'utf-8' !! 'iso-8859-1' !! 'utf-8'); + } + else { + # At this point we're probably screwed anyway + 'iso-8859-1' + } } -} -# This is already a candidate for refactoring -# Just want to get it working -method is-text(--> Bool:D) { - if $!binary { - False - } - elsif self.media-type -> $mt { - if $mt.type ~~ any(@!text-types) { - True + # This is already a candidate for refactoring + # Just want to get it working + method is-text(--> Bool:D) { + if $!binary { + False } - else { - given $mt.major-type { - when 'text' { - True - } - when any() { - False - } - when 'application' { - given $mt.sub-type { - when /xml|javascript|json/ { - True - } - default { - False + elsif self.media-type -> $mt { + if $mt.type ~~ any(@!text-types) { + True + } + else { + given $mt.major-type { + when 'text' { + True + } + when any() { + False + } + when 'application' { + given $mt.sub-type { + when /xml|javascript|json/ { + True + } + default { + False + } } } - } - default { - # Not sure about this - True + default { + # Not sure about this + True + } } } } + else { + # No content type, try and blow up + True + } } - else { - # No content type, try and blow up - True - } -} -method is-binary(--> Bool:D) { !self.is-text } - -method is-chunked(--> Bool:D) { -# 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 - - # TODO : uncomment after confirming testcase - my $enc = self.field('Transfer-Encoding'); - so $enc and $enc.Str.trim.lc.ends-with: 'chunked' -# # TODO : remove after implementing -# ... -} + method is-binary(--> Bool:D) { !self.is-text } -method content-encoding() { - $!header.field('Content-Encoding'); -} + #| 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-Lenient $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; + } -class X::Deflate is Exception { - has Str $.message; -} + method content-encoding() { + $!header.field('Content-Encoding'); + } -method inflate-content(--> Blob:D) { - if self.content-encoding -> $v is copy { - # This is a guess - $v = 'zlib' if $v eq 'compress' ; - $v = 'zlib' if $v eq 'deflate'; - try require ::('Compress::Zlib'); - if ::('Compress::Zlib::Stream') ~~ Failure { - X::Deflate.new(message => "Please install 'Compress::Zlib' to uncompress '$v' encoded content").throw; + class X::Deflate is Exception { + has Str $.message; + } + + method inflate-content(--> Blob:D) { + if self.content-encoding -> $v is copy { + # This is a guess + $v = 'zlib' if $v eq 'compress' ; + $v = 'zlib' if $v eq 'deflate'; + try require ::('Compress::Zlib'); + if ::('Compress::Zlib::Stream') ~~ Failure { + X::Deflate.new(message => "Please install 'Compress::Zlib' to uncompress '$v' encoded content").throw; + } + else { + my $z = ::('Compress::Zlib::Stream').new( |{ $v => True }); + $z.inflate($!content); + } } else { - my $z = ::('Compress::Zlib::Stream').new( |{ $v => True }); - $z.inflate($!content); + $!content; } } - else { - $!content; - } -} -method decoded-content(:$bin) { - return $!content if $!content ~~ Str || $!content.bytes == 0; + method decoded-content(:$bin) { + return $!content if $!content ~~ Str || $!content.bytes == 0; - my $content = self.inflate-content; - # [todo] - # If charset is missing from Content-Type, then before defaulting - # to anything it should attempt to extract it from $.content like (for HTML): - # - # - - my $decoded_content; - - if !$bin && self.is-text { - my $charset = self.charset; - $decoded_content = try { - Encode::decode($charset, $content); - } || try { - $content.decode('iso-8859-1'); - } || try { - $content.unpack("A*") - } || X::Decoding.new(content => $content, response => self).throw; - } - else { - $decoded_content = $content; + my $content = self.inflate-content; + # [todo] + # If charset is missing from Content-Type, then before defaulting + # to anything it should attempt to extract it from $.content like (for HTML): + # + # + + my $decoded_content; + + if !$bin && self.is-text { + my $charset = self.charset; + $decoded_content = try { + Encode::decode($charset, $content); + } || try { + $content.decode('iso-8859-1'); + } || try { + $content.unpack("A*") + } || X::Decoding.new(content => $content, response => self).throw; + } + else { + $decoded_content = $content; + } + + $decoded_content } - $decoded_content -} + multi method field(Str $f) { + $.header.field($f) + } -multi method field(Str $f) { - $.header.field($f) -} + multi method field(*%fields) { + $.header.field(|%fields) + } -multi method field(*%fields) { - $.header.field(|%fields) -} + method push-field(*%fields) { + $.header.push-field(|%fields) + } -method push-field(*%fields) { - $.header.push-field(|%fields) -} + method remove-field(Str $field) { + $.header.remove-field($field) + } -method remove-field(Str $field) { - $.header.remove-field($field) -} + method clear { + $.header.clear; + $.content = '' + } -method clear { - $.header.clear; - $.content = '' -} + method parse($raw_message) { + say 'LENIENT PARSE'; + my @lines = $raw_message.split(/$CRLF/); -method parse($raw_message) { - my @lines = $raw_message.split(/$CRLF/); + my ($first, $second, $third) = @lines.shift.split(/\s+/); - my ($first, $second, $third) = @lines.shift.split(/\s+/); + if $third.index('/') { # is a request + $.protocol = $third; + } + else { # is a response + $.protocol = $first; + } - if $third.index('/') { # is a request - $.protocol = $third; - } - else { # is a response - $.protocol = $first; - } - - my Bool:D $tec = False; - loop { - last until @lines; - - my $line = @lines.shift; - if $line { - my ($k, $v) = $line.split(/\:\s*/, 2); - if $k and $v { - $tec = True if $k eq 'Transfer-Encoding' - and $v.trim.lc.ends-with: 'chunked'; - if $.header.field($k) { - $.header.push-field: |($k => $v.split(',')>>.trim); - } else { - $.header.field: |($k => $v.split(',')>>.trim); + 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); + } } + } else { + $.content = @lines.grep({ $_ }).join("\n"); + last; } - } elsif $tec { - # chunked, add zero-length Str to end as size 0 chunk - @lines.push: '' if +@lines % 2; - $!content = join '', - grep *, - @lines.map: -> $s, $d { $s ~~ /^\d/ ?? $d !! '' }; - last; - } else { - $.content = @lines.grep({ $_ }).join("\n"); - last; } + + self } - self + method Str($eol = "\n", Bool :$strict, :$debug, Bool :$bin) { + my constant $max_size = 300; + my $s = $.header.Str($eol); + $s ~= $eol if $.content; + + # The :bin will be passed from the H::UA + if not $bin { + $s ~= $.content ~ $eol if $.content and !$debug; + } + if $.content and $debug { + if $bin || self.is-binary { + $s ~= $eol ~ "=Content size : " ~ $.content.elems ~ " bytes "; + $s ~= "$eol ** Not showing binary content ** $eol"; + } + else { + $s ~= $eol ~ "=Content size: "~$.content.Str.chars~" chars"; + $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; + $s ~= $eol ~ $.content.Str.substr(0, $max_size) ~ $eol; + } + } + + $s + } } -method Str($eol = "\n", :$debug, Bool :$bin) { - my constant $max_size = 300; - # TODO : reference relevant section of relevant RFC - # TODO : need to consider Str vs Buf length ? - self.field(Content-Length => ( $!content.?encode or $!content ).bytes.Str) - if $!content and not self.field: 'Transfer-Encoding'; - my $s = $.header.Str($eol); - $s ~= $eol if $.content; + +class HTTP::Message-Strict is HTTP::Message-Lenient { + #| see https://docs.raku.org/language/grammars#Attributes_in_grammars + my constant $CRLF = "\x[0d]\x[0a]"; + my constant $DELIM = $CRLF x 2; - # The :bin will be passed from the H::UA - if not $bin { - # do not append eol unless chunked - # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 - # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 - # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 + method new($content?, *%fields) { + my $header = HTTP::Header-Strict.new(|%fields); -# # TODO : replace following line with code following it -# $s ~= $.content ~ $eol if $.content and !$debug; - # TODO : uncomment following code for final implementation - $s ~= self.is-chunked ?? $!content !! $!content - if $!content; + self.bless(:$header, :$content); } - if $.content and $debug { - if $bin || self.is-binary { - $s ~= $eol ~ "=Content size : " ~ $.content.elems ~ " bytes "; - $s ~= "$eol ** Not showing binary content ** $eol"; + + method parse ( $raw_message ) { + my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; + my ( $fields, $content ) = $rest.split: $DELIM, 2; + + my ($first, $second, $third) = $start-line.split(/\s+/); + if $third.index('/') { # is a request + $.protocol = $third; } - else { - $s ~= $eol ~ "=Content size: "~$.content.Str.chars~" chars"; - $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; - $s ~= $eol ~ $.content.Str.substr(0, $max_size) ~ $eol; + else { # is a response + $.protocol = $first; } + + # $.header = HTTP::Header-Strict.new; + $.header.parse: $fields; + return self unless $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 *, + @lines.map: + -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } + ; + $.content = @lines.join; + return self; + } else { + $.content = $content; + return self; + } + + self + } + + method Str ( :$debug, Bool :$bin ) { + my constant $max_size = 300; + # TODO : reference relevant section of relevant RFC + # TODO : need to consider Str vs Buf length ? + self.field: Content-Length => ( $.content.?encode or $.content ).bytes.Str + if $.content and not self.is-chunked; + my $s = $.header.Str: $CRLF; + + # The :bin will be passed from the H::UA + if not $bin { + # do not append CRLF unless chunked + # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 + # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 + # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 + $s = join $CRLF, $s, $.content if $.content; + } + if $.content and $debug { + if $bin || self.is-binary { + $s ~= $CRLF ~ "=Content size : " ~ $.content.elems ~ " bytes "; + $s ~= "$CRLF ** Not showing binary content ** $CRLF"; + } + else { + $s ~= $CRLF ~ "=Content size: "~$.content.Str.chars~" chars"; + $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; + $s ~= $CRLF ~ $.content.Str.substr(0, $max_size) ~ $CRLF; + } + } + + $s } - $s } +# sub EXPORT ( $strict? ) { +# if $strict and $strict eq 'strict' { +# OUR::HTTP::Message := HTTP::Message-Strict; +# } else { +# OUR::HTTP::Message := HTTP::Message-Lenient; +# } +# Map.new; +# } + # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index a5af450..c18fee1 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -4,291 +4,373 @@ use URI::Escape; use HTTP::MediaType; use MIME::Base64; -unit class HTTP::Request is HTTP::Message; - subset RequestMethod of Str where any(); -has RequestMethod $.method is rw; -has $.url is rw; -has $.file is rw; -has $.uri is rw; +class HTTP::Request-Lenient is HTTP::Message-Lenient { + + has RequestMethod $.method is rw; + has $.url is rw; + has $.file is rw; + has $.uri is rw; -has Str $.host is rw; -has Int $.port is rw; -has Str $.scheme is rw; + has Str $.host is rw; + has Int $.port is rw; + has Str $.scheme is rw; -my $CRLF = "\r\n"; + my $CRLF = "\r\n"; -my $HRC_DEBUG = %*ENV.Bool; + my $HRC_DEBUG = %*ENV.Bool; -proto method new(|) {*} + proto method new(|) {*} -multi method new(Bool :$bin, *%args) { + multi method new(Bool :$bin, *%args) { - if %args { - my ($method, $url, $file, %fields, $uri); - for %args.kv -> $key, $value { - if $key.lc ~~ any() { - $uri = $value.isa(URI) ?? $value !! URI.new($value); - $method = $key.uc; - } - else { - %fields{$key} = $value; + if %args { + my ($method, $url, $file, %fields, $uri); + for %args.kv -> $key, $value { + if $key.lc ~~ any() { + $uri = $value.isa(URI) ?? $value !! URI.new($value); + $method = $key.uc; + } + else { + %fields{$key} = $value; + } } - } - my $header = HTTP::Header.new(|%fields); - self.new($method // 'GET', $uri, $header, :$bin); - } - else { - self.bless + my $header = HTTP::Header-Lenient.new(|%fields); + self.new($method // 'GET', $uri, $header, :$bin); + } + else { + self.bless + } } -} -multi method new() { self.bless } + multi method new() { self.bless } -multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { - my $url = $uri.grammar.parse_result.orig; - my $file = $uri.path_query || '/'; + multi method new(RequestMethod $method, URI $uri, HTTP::Header-Lenient $header, 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'); + $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) + } -sub get-host-value(URI $uri --> Str) { - my Str $host = $uri.host; + sub get-host-value(URI $uri --> Str) { + my Str $host = $uri.host; - if $host { - if ( $uri.port != $uri.default_port ) { - $host ~= ':' ~ $uri.port; + if $host { + if ( $uri.port != $uri.default_port ) { + $host ~= ':' ~ $uri.port; + } } + $host; } - $host; -} -method set-method($method) { $.method = $method.uc } + method set-method($method) { $.method = $method.uc } -proto method uri(|) {*} + proto method uri(|) {*} -multi method uri($uri is copy where URI|Str) { - $!uri = $uri.isa(Str) ?? URI.new($uri) !! $uri ; - $!url = $!uri.grammar.parse_result.orig; - $!file = $!uri.path_query || '/'; - self.field(Host => get-host-value($!uri)); - $!uri -} + multi method uri($uri is copy where URI|Str) { + $!uri = $uri.isa(Str) ?? URI.new($uri) !! $uri ; + $!url = $!uri.grammar.parse_result.orig; + $!file = $!uri.path_query || '/'; + self.field(Host => get-host-value($!uri)); + $!uri + } -multi method uri() is rw { $!uri } + multi method uri() is rw { $!uri } -proto method host(|) {*} + proto method host(|) {*} -multi method host(--> Str:D) is rw { - $!host = ~self.field('Host').values without $!host; - $!host -} + multi method host(--> Str:D) is rw { + $!host = ~self.field('Host').values without $!host; + $!host + } -proto method port(|) {*} + proto method port(|) {*} -multi method port(--> Int) is rw { - if not $!port.defined { - # if there isn't a scheme the no default port - if try self.uri.scheme { - $!port = self.uri.port; + multi method port(--> Int) is rw { + if not $!port.defined { + # if there isn't a scheme the no default port + if try self.uri.scheme { + $!port = self.uri.port; + } } + $!port } - $!port -} -proto method scheme(|) {*} + proto method scheme(|) {*} -multi method scheme(--> Str:D) is rw { - without $!scheme { - CATCH { - default { $!scheme = 'http' } + multi method scheme(--> Str:D) is rw { + without $!scheme { + CATCH { + default { $!scheme = 'http' } + } + $!scheme = self.uri.scheme; } - $!scheme = self.uri.scheme; + $!scheme } - $!scheme -} -method add-cookies($cookies) { - $cookies.add-cookie-header(self) if $cookies.cookies; -} + method add-cookies($cookies) { + $cookies.add-cookie-header(self) if $cookies.cookies; + } -proto method add-content(|) {*} + proto method add-content(|) {*} -multi method add-content(Str:D $content) { - self.content ~= $content; - self.header.field(Content-Length => self.content.encode.bytes.Str); -} + multi method add-content(Str:D $content) { + self.content ~= $content; + self.header.field(Content-Length => self.content.encode.bytes.Str); + } -proto method add-form-data(|) {*} + proto method add-form-data(|) {*} -multi method add-form-data(:$multipart, *%data) { - self.add-form-data(%data.sort.Array, :$multipart); -} + multi method add-form-data(:$multipart, *%data) { + self.add-form-data(%data.sort.Array, :$multipart); + } -multi method add-form-data(%data, :$multipart) { - self.add-form-data(%data.sort.Array, :$multipart); -} + multi method add-form-data(%data, :$multipart) { + self.add-form-data(%data.sort.Array, :$multipart); + } -multi method add-form-data(Array $data, :$multipart) { - my $ct = do { - my $f = self.header.field('Content-Type'); - if $f { - $f.values[0]; - } else { - if $multipart { - 'multipart/form-data'; - } - else { - 'application/x-www-form-urlencoded'; + multi method add-form-data(Array $data, :$multipart) { + my $ct = do { + my $f = self.header.field('Content-Type'); + if $f { + $f.values[0]; + } else { + if $multipart { + 'multipart/form-data'; + } + else { + 'application/x-www-form-urlencoded'; + } } + }; + sub form-escape($s) { + uri-escape($s).subst(:g, '%20', '+').subst(:g, '%2A', '*'); } - }; - sub form-escape($s) { - uri-escape($s).subst(:g, '%20', '+').subst(:g, '%2A', '*'); - } - given $ct { - when 'application/x-www-form-urlencoded' { - my @parts; - for @$data { - @parts.push: form-escape(.key) ~ "=" ~ form-escape(.value); - } - self.content = @parts.join("&").encode; - self.header.field(Content-Length => self.content.bytes.Str); + given $ct { + when 'application/x-www-form-urlencoded' { + my @parts; + for @$data { + @parts.push: form-escape(.key) ~ "=" ~ form-escape(.value); + } + self.content = @parts.join("&").encode; + self.header.field(Content-Length => self.content.bytes.Str); + } + when m:i,^ "multipart/form-data" \s* ( ";" | $ ), { + say 'generating form-data' if $HRC_DEBUG; + + my $mt = HTTP::MediaType.parse($ct); + my Str $boundary = $mt.param('boundary') // self.make-boundary(10); + (my $generated-content, $boundary) = self.form-data($data, $boundary); + $mt.param('boundary', $boundary); + $ct = $mt.Str; + my Str $encoded-content = $generated-content; + self.content = $encoded-content; + self.header.field(Content-Length => $encoded-content.encode('ascii').bytes.Str); + } } - when m:i,^ "multipart/form-data" \s* ( ";" | $ ), { - say 'generating form-data' if $HRC_DEBUG; - - my $mt = HTTP::MediaType.parse($ct); - my Str $boundary = $mt.param('boundary') // self.make-boundary(10); - (my $generated-content, $boundary) = self.form-data($data, $boundary); - $mt.param('boundary', $boundary); - $ct = $mt.Str; - my Str $encoded-content = $generated-content; - self.content = $encoded-content; - self.header.field(Content-Length => $encoded-content.encode('ascii').bytes.Str); - } + self.header.field(Content-Type => $ct) } - self.header.field(Content-Type => $ct) -} -method form-data(Array:D $content, Str:D $boundary) { - my @parts; - for @$content { - my ($k, $v) = $_.key, $_.value; - given $v { - when Str { - $k ~~ s:g/(<[\\ \"]>)/\\$1/; # escape quotes and backslashes - @parts.push: qq!Content-Disposition: form-data; name="$k"$CRLF$CRLF$v!; - } - when Array { - my ($file, $usename, @headers) = @$v; - unless defined $usename { - $usename = $file; - $usename ~~ s!.* "/"!! if defined($usename); - } - $k ~~ s:g/(<[\\ \"]>)/\\$1/; - my $disp = qq!form-data; name="$k"!; - if (defined($usename) and $usename.elems > 0) { - $usename ~~ s:g/(<[\\ \"]>)/\\$1/; - $disp ~= qq!; filename="$usename"!; + method form-data(Array:D $content, Str:D $boundary) { + my @parts; + for @$content { + my ($k, $v) = $_.key, $_.value; + given $v { + when Str { + $k ~~ s:g/(<[\\ \"]>)/\\$1/; # escape quotes and backslashes + @parts.push: qq!Content-Disposition: form-data; name="$k"$CRLF$CRLF$v!; } - my $content; - my $headers = HTTP::Header.new(|@headers); - if $file { - # TODO: dynamic file upload support - $content = $file.IO.slurp; - unless $headers.field('Content-Type') { - # TODO: LWP::MediaTypes - $headers.field(Content-Type => 'application/octet-stream'); + when Array { + my ($file, $usename, @headers) = @$v; + unless defined $usename { + $usename = $file; + $usename ~~ s!.* "/"!! if defined($usename); } - } - if $headers.field('Content-Disposition') { - $disp = $headers.field('Content-Disposition'); - $headers.remove-field('Content-Disposition'); - } - if $headers.field('Content') { - $content = $headers.field('Content'); - $headers.remove-field('Content'); - } - my $head = ["Content-Disposition: $disp", - $headers.Str($CRLF), - ""].join($CRLF); - given $content { - when Str { - @parts.push: $head ~ $content; + $k ~~ s:g/(<[\\ \"]>)/\\$1/; + my $disp = qq!form-data; name="$k"!; + if (defined($usename) and $usename.elems > 0) { + $usename ~~ s:g/(<[\\ \"]>)/\\$1/; + $disp ~= qq!; filename="$usename"!; + } + my $content; + my $headers = HTTP::Header.new(|@headers); + if $file { + # TODO: dynamic file upload support + $content = $file.IO.slurp; + unless $headers.field('Content-Type') { + # TODO: LWP::MediaTypes + $headers.field(Content-Type => 'application/octet-stream'); + } + } + if $headers.field('Content-Disposition') { + $disp = $headers.field('Content-Disposition'); + $headers.remove-field('Content-Disposition'); + } + if $headers.field('Content') { + $content = $headers.field('Content'); + $headers.remove-field('Content'); } - default { - die "NYI" + my $head = ["Content-Disposition: $disp", + $headers.Str($CRLF), + ""].join($CRLF); + given $content { + when Str { + @parts.push: $head ~ $content; + } + default { + die "NYI" + } } } - } - default { - die "unsupported type: $v.WHAT.gist()($content.raku())"; + default { + die "unsupported type: $v.WHAT.gist()($content.raku())"; + } } } - } - say $content if $HRC_DEBUG; - say @parts if $HRC_DEBUG; - return "", "none" unless @parts; - - my $contents; - # TODO: dynamic upload support - my $bno = 10; - CHECK_BOUNDARY: { - for @parts { - if $_.index($boundary).defined { - # must have a better boundary - $boundary = self.make-boundary(++$bno); - redo CHECK_BOUNDARY; + say $content if $HRC_DEBUG; + say @parts if $HRC_DEBUG; + return "", "none" unless @parts; + + my $contents; + # TODO: dynamic upload support + my $bno = 10; + CHECK_BOUNDARY: { + for @parts { + if $_.index($boundary).defined { + # must have a better boundary + $boundary = self.make-boundary(++$bno); + redo CHECK_BOUNDARY; + } } } + my $generated-content = "--$boundary$CRLF" + ~ @parts.join("$CRLF--$boundary$CRLF") + ~ "$CRLF--$boundary--$CRLF"; + + $generated-content, $boundary } - my $generated-content = "--$boundary$CRLF" - ~ @parts.join("$CRLF--$boundary$CRLF") - ~ "$CRLF--$boundary--$CRLF"; - $generated-content, $boundary -} + method make-boundary(int $size=10) { + my $str = (1..$size*3).map({(^256).pick.chr}).join(''); + my $b = MIME::Base64.new.encode_base64($str, :oneline); + $b ~~ s:g/\W/X/; # ensure alnum only + $b + } -method make-boundary(int $size=10) { - my $str = (1..$size*3).map({(^256).pick.chr}).join(''); - my $b = MIME::Base64.new.encode_base64($str, :oneline); - $b ~~ s:g/\W/X/; # ensure alnum only - $b -} + method Str ( :$debug, Bool :$bin) { + $.file = '/' ~ $.file unless $.file.starts-with: '/'; + my $s = "$.method $.file $.protocol"; + join $CRLF, $s, callwith $CRLF, :$debug, :$bin; + } + + method parse($raw_request) { + my @lines = $raw_request.split($CRLF); + ($.method, $.file) = @lines.shift.split(' '); + + $.url = 'http://'; + + for @lines -> $line { + if $line ~~ m:i/host:/ { + $.url ~= $line.split(/\:\s*/)[1]; + } + } + + $.url ~= $.file; -method Str (:$debug, Bool :$bin) { - $.file = '/' ~ $.file unless $.file.starts-with: '/'; - my $s = "$.method $.file $.protocol"; - $s ~= $CRLF ~ callwith($CRLF, :$debug, :$bin); + self.uri = URI.new($.url) ; + + nextsame; + } } -method parse($raw_request) { - my @lines = $raw_request.split($CRLF); - ($.method, $.file) = @lines.shift.split(' '); +class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request-Lenient { + my constant $CRLF = "\x[0D]\x[0A]"; + + + sub get-host-value(URI $uri --> Str) { + my Str $host = $uri.host; - $.url = 'http://'; + if $host { + if ( $uri.port != $uri.default_port ) { + $host ~= ':' ~ $uri.port; + } + } + $host; + } + + multi method new(Bool :$bin, *%args) { + + if %args { + my ($method, $url, $file, %fields, $uri); + for %args.kv -> $key, $value { + if $key.lc ~~ any() { + $uri = $value.isa(URI) ?? $value !! URI.new($value); + $method = $key.uc; + } + else { + %fields{$key} = $value; + } + } - for @lines -> $line { - if $line ~~ m:i/host:/ { - $.url ~= $line.split(/\:\s*/)[1]; + my $header = HTTP::Header-Strict.new(|%fields); + self.new($method // 'GET', $uri, $header, :$bin); } + else { + self.bless: header => HTTP::Header-Strict.new + } + } + + multi method new() { self.bless: header => HTTP::Header-Strict.new } + + multi method new(RequestMethod $method, URI $uri, HTTP::Header-Strict $header, 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) + } + + method Str ( :$debug, Bool :$bin ) { + $.file = '/' ~ $.file unless $.file.starts-with: '/'; + my $s = "$.method $.file $.protocol"; + join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug, :$bin; } + method parse ( $raw_request ) { + my @lines = $raw_request.split($CRLF); + ($.method, $.file) = @lines.shift.split(' '); - $.url ~= $.file; + $.url = 'http://'; - self.uri = URI.new($.url) ; + for @lines -> $line { + if $line ~~ m:i/host:/ { + $.url ~= $line.split(/\:\s*/)[1]; + } + } + + $.url ~= $.file; - nextsame; + self.uri = URI.new($.url); + self.HTTP::Message-Strict::parse: $raw_request; + } } +# sub EXPORT ( $strict? ) { +# if $strict and $strict eq 'strict' { +# OUR::HTTP::Request := HTTP::Request-Strict; +# } else { +# OUR::HTTP::Request := HTTP::Request-Lenient; +# } +# Map.new; +# } + # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index 7dcd253..f6e7b76 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -1,105 +1,156 @@ use HTTP::Message; use HTTP::Status; -use HTTP::Request:auth; +use HTTP::Request; use HTTP::UserAgent::Exception; -unit class HTTP::Response is HTTP::Message; +class HTTP::Response-Lenient is HTTP::Message-Lenient { -has $.status-line is rw; -has $.code is rw; -has HTTP::Request $.request is rw; + has $.status-line is rw; + has $.code is rw; + has HTTP::Request-Lenient $.request is rw; -my $CRLF = "\r\n"; + my $CRLF = "\r\n"; -submethod BUILD(:$!code) { - $!status-line = self.set-code($!code); -} + submethod BUILD(:$!code) { + $!status-line = self.set-code($!code); + } -proto method new(|) {*} + proto method new(|) {*} -# This candidate makes it easier to test weird responses -multi method new(Blob:D $header-chunk) { - # See https://tools.ietf.org/html/rfc7230#section-3.2.4 - my ($rl, $header) = $header-chunk.decode('ISO-8859-1').split(/\r?\n/, 2); - X::HTTP::NoResponse.new.throw unless $rl; + # This candidate makes it easier to test weird responses + multi method new(Blob:D $header-chunk) { + # See https://tools.ietf.org/html/rfc7230#section-3.2.4 + my ($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 $code = (try $rl.split(' ')[1].Int) // 500; + my $response = self.new($code); + $response.header.parse(.subst(/"\r"?"\n"$$/, '')) with $header; - $response -} + $response + } -multi method new(Int:D $code = 200, *%fields) { - my $header = HTTP::Header.new(|%fields); - self.bless(:$code, :$header); -} + multi method new(Int:D $code = 200, *%fields) { + my $header = HTTP::Header-Lenient.new(|%fields); + self.bless(:$code, :$header); + } -method content-length(--> Int) { - my $content-length = self.field('Content-Length').values[0]; + method content-length(--> Int) { + my $content-length = self.field('Content-Length').values[0]; - with $content-length -> $c { - X::HTTP::ContentLength.new(message => "Content-Length header value '$c' is not numeric").throw - without $content-length = try +$content-length; - $content-length - } - else { - Int + with $content-length -> $c { + X::HTTP::ContentLength.new(message => "Content-Length header value '$c' is not numeric").throw + without $content-length = try +$content-length; + $content-length + } + else { + Int + } } -} -method is-success { is-success($!code).Bool } + method is-success { is-success($!code).Bool } -# please extend as necessary -method has-content(--> Bool:D) { - (204, 304).grep({ $!code eq $_ }) ?? False !! True; -} + # please extend as necessary + method has-content(--> Bool:D) { + (204, 304).grep({ $!code eq $_ }) ?? False !! True; + } -method is-chunked(--> Bool:D) { - self.field('Transfer-Encoding') - && self.field('Transfer-Encoding') eq 'chunked' -} + method is-chunked(--> Bool:D) { + self.field('Transfer-Encoding') + && self.field('Transfer-Encoding') eq 'chunked' + } -method set-code(Int:D $code) { - $!code = $code; - $!status-line = $code ~ " " ~ get_http_status_msg($code); -} + method set-code(Int:D $code) { + $!code = $code; + $!status-line = $code ~ " " ~ get_http_status_msg($code); + } -method next-request(--> HTTP::Request:D) { - my HTTP::Request $new-request; + method next-request(--> HTTP::Request-Lenient:D) { + my HTTP::Request-Lenient $new-request; - my $location = ~self.header.field('Location').values; + my $location = ~self.header.field('Location').values; - if $location.defined { - # Special case for the HTTP status code 303 (redirection): - # The response to the request can be found under another URI using - # a separate GET method. This relates to POST, PUT, DELETE and PATCH - # methods. - my $method = $!request.method; - $method = "GET" - if self.code == 303 - && $!request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); + if $location.defined { + # Special case for the HTTP status code 303 (redirection): + # The response to the request can be found under another URI using + # a separate GET method. This relates to POST, PUT, DELETE and PATCH + # methods. + my $method = $!request.method; + $method = "GET" + if self.code == 303 + && $!request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); - my %args = $method => $location; + my %args = $method => $location; - $new-request = HTTP::Request.new(|%args); + $new-request = HTTP::Request-Lenient.new(|%args); - unless ~$new-request.field('Host').values { - my $hh = ~$!request.field('Host').values; - $new-request.field(Host => $hh); - $new-request.scheme = $!request.scheme; - $new-request.host = $!request.host; - $new-request.port = $!request.port; + unless ~$new-request.field('Host').values { + my $hh = ~$!request.field('Host').values; + $new-request.field(Host => $hh); + $new-request.scheme = $!request.scheme; + $new-request.host = $!request.host; + $new-request.port = $!request.port; + } } + + $new-request } - $new-request + method Str(:$debug) { + my $s = $.protocol ~ " " ~ $!status-line; + join $CRLF, $s, callwith $CRLF, :$debug; + } } -method Str(:$debug) { - my $s = $.protocol ~ " " ~ $!status-line; - $s ~= $CRLF ~ callwith($CRLF, :debug($debug)); +class HTTP::Response-Strict is HTTP::Response-Lenient is HTTP::Message-Strict { + my constant $CRLF = "\x[0D]\x[0A]"; + + method next-request(--> HTTP::Request-Lenient:D) { + my HTTP::Request-Strict $new-request; + + my $location = ~self.header.field('Location').values; + + + if $location.defined { + # Special case for the HTTP status code 303 (redirection): + # The response to the request can be found under another URI using + # a separate GET method. This relates to POST, PUT, DELETE and PATCH + # methods. + my $method = $.request.method; + $method = "GET" + if self.code == 303 + && $.request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); + + my %args = $method => $location; + + $new-request = HTTP::Request-Strict.new(|%args); + + unless ~$new-request.field('Host').values { + my $hh = ~$.request.field('Host').values; + $new-request.field(Host => $hh); + $new-request.scheme = $.request.scheme; + $new-request.host = $.request.host; + $new-request.port = $.request.port; + } + } + + $new-request + } + + method Str(:$debug) { + my $s = $.protocol ~ " " ~ $.status-line; + join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug; + } } +# sub EXPORT ( $strict? ) { +# if $strict and $strict eq 'strict' { +# OUR::HTTP::Response := HTTP::Response-Strict; +# } else { +# OUR::HTTP::Response := HTTP::Response-Lenient; +# } +# Map.new; +# } + # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index c5c9b71..20afa6f 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -1,7 +1,7 @@ -unit class HTTP::UserAgent; - -use HTTP::Response:auth; -use HTTP::Request:auth; +# use HTTP::Response:auth; +# use HTTP::Request:auth; +use HTTP::Request; +use HTTP::Response; use HTTP::Cookies; use HTTP::UserAgent::Common; use HTTP::UserAgent::Exception; @@ -12,467 +12,629 @@ use URI; use File::Temp; use MIME::Base64; -constant CRLF = Buf.new(13, 10); - -# placeholder role to make signatures nicer -# and enable greater abstraction -role Connection { - method send-request(HTTP::Request $request ) { - $request.field(Connection => 'close') unless $request.field('Connection'); - if $request.binary { - self.print($request.Str(:bin)); - self.write($request.content); - } - elsif $request.method.Str eq 'POST' | 'PUT' { - self.print($request.Str); - } else { - self.print($request.Str ~ "\r\n"); +class HTTP::UserAgent-Lenient { + # use HTTP::Response:auth; + # use HTTP::Request:auth; + # use HTTP::Cookies; + # use HTTP::UserAgent::Common; + # use HTTP::UserAgent::Exception; + + use Encode; + use URI; + + use File::Temp; + use MIME::Base64; + + constant CRLF = Buf.new(13, 10); + + # placeholder role to make signatures nicer + # and enable greater abstraction + role Connection { + method send-request(HTTP::Request-Lenient $request ) { + $request.field(Connection => 'close') unless $request.field('Connection'); + if $request.binary { + self.print($request.Str(:bin)); + self.write($request.content); + } + elsif $request.method.Str eq 'POST' | 'PUT' { + self.print: $request.Str: :strict; + } else { + self.print($request.Str ~ "\r\n"); + } } } -} - -has Int $.timeout is rw = 180; -has $.useragent; -has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( - file => tempfile[0], - autosave => 1, -); -has $.auth_login; -has $.auth_password; -has Int $.max-redirects is rw; -has $.redirects-in-a-row; -has Bool $.throw-exceptions; -has $.debug; -has IO::Handle $.debug-handle; - -my sub search-header-end(Blob $input) { - my $i = 0; - my $input-bytes = $input.bytes; - while $i+2 <= $input-bytes { - # CRLF - if $i+4 <= $input-bytes && $input[$i] == 0x0d && $input[$i+1]==0x0a && $input[$i+2]==0x0d && $input[$i+3]==0x0a { - return $i+4; - } - # LF - if $input[$i] == 0x0a && $input[$i+1]==0x0a { - return $i+2; - } - $i++; - } - Nil -} -my sub _index_buf(Blob $input, Blob $sub) { - my $end-pos = 0; - while $end-pos < $input.bytes { - if $sub eq $input.subbuf($end-pos, $sub.bytes) { - return $end-pos; + has Int $.timeout is rw = 180; + has $.useragent; + has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( + file => tempfile[0], + autosave => 1, + ); + has $.auth_login; + has $.auth_password; + has Int $.max-redirects is rw; + has $.redirects-in-a-row; + has Bool $.throw-exceptions; + has $.debug; + has IO::Handle $.debug-handle; + + my sub search-header-end(Blob $input) { + my $i = 0; + my $input-bytes = $input.bytes; + while $i+2 <= $input-bytes { + # CRLF + if $i+4 <= $input-bytes && $input[$i] == 0x0d && $input[$i+1]==0x0a && $input[$i+2]==0x0d && $input[$i+3]==0x0a { + return $i+4; + } + # LF + if $input[$i] == 0x0a && $input[$i+1]==0x0a { + return $i+2; + } + $i++; } - $end-pos++; + Nil } - -1 -} -submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { - $!useragent = get-ua($!useragent) if $!useragent.defined; - if $!debug.defined { - if $!debug ~~ Bool and $!debug == True { - $!debug-handle = $*OUT; - } - if $!debug ~~ Str { - say $!debug; - $!debug-handle = open($!debug, :w); - $!debug = True; + my sub _index_buf(Blob $input, Blob $sub) { + my $end-pos = 0; + while $end-pos < $input.bytes { + if $sub eq $input.subbuf($end-pos, $sub.bytes) { + return $end-pos; + } + $end-pos++; } - if $!debug ~~ IO::Handle { - $!debug-handle = $!debug; - $!debug = True; + -1 + } + + submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { + $!useragent = get-ua($!useragent) if $!useragent.defined; + if $!debug.defined { + if $!debug ~~ Bool and $!debug == True { + $!debug-handle = $*OUT; + } + if $!debug ~~ Str { + say $!debug; + $!debug-handle = open($!debug, :w); + $!debug = True; + } + if $!debug ~~ IO::Handle { + $!debug-handle = $!debug; + $!debug = True; + } } } -} -method auth(Str $login, Str $password) { - $!auth_login = $login; - $!auth_password = $password; -} + method auth(Str $login, Str $password) { + $!auth_login = $login; + $!auth_password = $password; + } -proto method get(|) {*} + 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 :$bin, *%header ) { + my $request = HTTP::Request-Lenient.new(GET => $uri, |%header); + self.request($request, :$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 :$bin, *%header ) { + self.get(URI.new(_clear-url($uri)), :$bin, |%header) + } -proto method post(|) {*} + proto method post(|) {*} -multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(POST => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) -} + multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Lenient.new(POST => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$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 :$bin, *%header ) { + self.post(URI.new(_clear-url($uri)), %form, |%header) + } -proto method put(|) {*} + proto method put(|) {*} -multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(PUT => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) -} + multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Lenient.new(PUT => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$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 :$bin, *%header ) { + self.put(URI.new(_clear-url($uri)), %form, |%header) + } -proto method delete(|) {*} + 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 :$bin, *%header ) { + my $request = HTTP::Request-Lenient.new(DELETE => $uri, |%header); + self.request($request, :$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 :$bin, *%header ) { + self.delete(URI.new(_clear-url($uri)), :$bin, |%header) + } -method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { - my HTTP::Response $response; + method request(HTTP::Request-Lenient $request, Bool :$bin --> HTTP::Response-Lenient:D) { + my HTTP::Response-Lenient $response; - # add cookies to the request - $request.add-cookies($.cookies); + # add cookies to the request + $request.add-cookies($.cookies); - # set the useragent - $request.field(User-Agent => $.useragent) if $.useragent.defined; + # set the useragent + $request.field(User-Agent => $.useragent) if $.useragent.defined; - # if auth has been provided add it to the request - self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection $conn = self.get-connection($request); + # if auth has been provided add it to the request + self.setup-auth($request); + $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; + my Connection $conn = self.get-connection($request); - if $conn.send-request($request) { - $response = self.get-response($request, $conn, :$bin); - } - $conn.close; + if $conn.send-request($request) { + $response = self.get-response($request, $conn, :$bin); + } + $conn.close; - X::HTTP::Response.new(:rc('No response')).throw unless $response; + X::HTTP::Response.new(:rc('No response')).throw unless $response; - $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; + $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; - # save cookies - $.cookies.extract-cookies($response); + # save cookies + $.cookies.extract-cookies($response); - if $response.code ~~ /^30<[0123]>/ { - $!redirects-in-a-row++; - 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); - } - else { - $!redirects-in-a-row = 0; - } - if $!throw-exceptions { - given $response.code { - when /^4/ { - X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; + if $response.code ~~ /^30<[0123]>/ { + $!redirects-in-a-row++; + if $.max-redirects < $.redirects-in-a-row { + X::HTTP::Response.new(:rc('Max redirects exceeded'), :response($response)).throw; } - when /^5/ { - X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; + my $new-request = $response.next-request(); + return self.request($new-request); + } + else { + $!redirects-in-a-row = 0; + } + if $!throw-exceptions { + given $response.code { + when /^4/ { + X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; + } + when /^5/ { + X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; + } } } - } - $response -} + $response + } -proto method get-content(|) {*} + proto method get-content(|) {*} -# When we have a content-length -multi method get-content(Connection $conn, Blob $content, $content-length --> Blob:D) { - if $content.bytes == $content-length { - $content + # When we have a content-length + multi method get-content(Connection $conn, Blob $content, $content-length --> Blob:D) { + if $content.bytes == $content-length { + $content + } + else { + # Create a Buf with what we have now and append onto + # it until we've read the right amount. + my $buf = Buf.new($content); + my int $total-bytes-read = $content.bytes; + while $content-length > $total-bytes-read { + my $read = $conn.recv($content-length - $total-bytes-read, :bin); + $buf.append($read); + $total-bytes-read += $read.bytes; + } + $buf + } } - else { - # Create a Buf with what we have now and append onto - # it until we've read the right amount. - my $buf = Buf.new($content); - my int $total-bytes-read = $content.bytes; - while $content-length > $total-bytes-read { - my $read = $conn.recv($content-length - $total-bytes-read, :bin); - $buf.append($read); - $total-bytes-read += $read.bytes; + + # fallback when not chunked and no content length + multi method get-content(Connection $conn, Blob $content is rw --> Blob:D) { + + while my $new_content = $conn.recv(:bin) { + $content ~= $new_content; } - $buf + $content; } -} -# fallback when not chunked and no content length -multi method get-content(Connection $conn, Blob $content is rw --> Blob:D) { + method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { + my Buf $chunk = $content.clone; + $content = Buf.new; + # We carry on as long as we receive something. + PARSE_CHUNK: loop { + my $end_pos = _index_buf($chunk, CRLF); + if $end_pos >= 0 { + my $size = $chunk.subbuf(0, $end_pos).decode; + # remove optional chunk extensions + $size = $size.subst(/';'.*$/, ''); + # www.yahoo.com sends additional spaces(maybe invalid) + $size = $size.subst(/' '*$/, ''); + $chunk = $chunk.subbuf($end_pos+2); + my $chunk-size = :16($size); + if $chunk-size == 0 { + last PARSE_CHUNK; + } + while $chunk-size+2 > $chunk.bytes { + $chunk ~= $conn.recv($chunk-size+2-$chunk.bytes, :bin); + } + $content ~= $chunk.subbuf(0, $chunk-size); + $chunk = $chunk.subbuf($chunk-size+2); + } + else { + # XXX Reading 1 byte is inefficient code. + # + # But IO::Socket#read/IO::Socket#recv reads from socket until + # fill the requested size. + # + # It cause hang-up on socket reading. + my $byte = $conn.recv(1, :bin); + last PARSE_CHUNK unless $byte.elems; + $chunk ~= $byte; + } + }; - while my $new_content = $conn.recv(:bin) { - $content ~= $new_content; + $content } - $content; -} -method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { - my Buf $chunk = $content.clone; - $content = Buf.new; - # We carry on as long as we receive something. - PARSE_CHUNK: loop { - my $end_pos = _index_buf($chunk, CRLF); - if $end_pos >= 0 { - my $size = $chunk.subbuf(0, $end_pos).decode; - # remove optional chunk extensions - $size = $size.subst(/';'.*$/, ''); - # www.yahoo.com sends additional spaces(maybe invalid) - $size = $size.subst(/' '*$/, ''); - $chunk = $chunk.subbuf($end_pos+2); - my $chunk-size = :16($size); - if $chunk-size == 0 { - last PARSE_CHUNK; + method get-response(HTTP::Request-Lenient $request, Connection $conn, Bool :$bin --> HTTP::Response-Lenient:D) { + my Blob[uint8] $first-chunk = Blob[uint8].new; + my $msg-body-pos; + + CATCH { + when X::HTTP::NoResponse { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; } - while $chunk-size+2 > $chunk.bytes { - $chunk ~= $conn.recv($chunk-size+2-$chunk.bytes, :bin); + when /'Connection reset by peer'/ { + X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; } - $content ~= $chunk.subbuf(0, $chunk-size); - $chunk = $chunk.subbuf($chunk-size+2); } - else { - # XXX Reading 1 byte is inefficient code. - # - # But IO::Socket#read/IO::Socket#recv reads from socket until - # fill the requested size. - # - # It cause hang-up on socket reading. - my $byte = $conn.recv(1, :bin); - last PARSE_CHUNK unless $byte.elems; - $chunk ~= $byte; - } - }; - - $content -} -method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { - my Blob[uint8] $first-chunk = Blob[uint8].new; - my $msg-body-pos; + # Header can be longer than one chunk + while my $t = $conn.recv( :bin ) { + $first-chunk ~= $t; - CATCH { - when X::HTTP::NoResponse { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; + # Find the header/body separator in the chunk, which means + # we can parse the header seperately and are able to figure + # out the correct encoding of the body. + $msg-body-pos = search-header-end($first-chunk); + last if $msg-body-pos.defined; } - when /'Connection reset by peer'/ { - X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; + + + # If the header would indicate that there won't + # be any content there may not be a \r\n\r\n at + # the end of the header. + my $header-chunk = do if $msg-body-pos.defined { + $first-chunk.subbuf(0, $msg-body-pos); + } + else { + # Assume we have the whole header because if the server + # didn't send it we're stuffed anyway + $first-chunk; } - } - # Header can be longer than one chunk - while my $t = $conn.recv( :bin ) { - $first-chunk ~= $t; - # Find the header/body separator in the chunk, which means - # we can parse the header seperately and are able to figure - # out the correct encoding of the body. - $msg-body-pos = search-header-end($first-chunk); - last if $msg-body-pos.defined; - } + my HTTP::Response-Lenient $response = HTTP::Response-Lenient.new($header-chunk); + $response.request = $request; + if $response.has-content { + if !$msg-body-pos.defined { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; + } - # If the header would indicate that there won't - # be any content there may not be a \r\n\r\n at - # the end of the header. - my $header-chunk = do if $msg-body-pos.defined { - $first-chunk.subbuf(0, $msg-body-pos); - } - else { - # Assume we have the whole header because if the server - # didn't send it we're stuffed anyway - $first-chunk; + + my $content = $first-chunk.subbuf($msg-body-pos); + # Turn the inner exceptions to ours + # This may really want to be outside + CATCH { + when X::HTTP::ContentLength { + X::HTTP::Header.new( :rc($_.message), :response($response) ).throw + } + } + # We also need to handle 'Transfer-Encoding: chunked', which means + # that we request more chunks and assemble the response body. + if $response.is-chunked { + $content = self.get-chunked-content($conn, $content); + } + elsif $response.content-length -> $content-length is copy { + $content = self.get-content($conn, $content, $content-length); + } + else { + $content = self.get-content($conn, $content); + } + + $response.content = $content andthen $response.content = $response.decoded-content(:$bin); + } + $response } - my HTTP::Response $response = HTTP::Response.new($header-chunk); - $response.request = $request; + proto method get-connection(|) {*} - if $response.has-content { - if !$msg-body-pos.defined { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; - } + multi method get-connection(HTTP::Request-Lenient $request --> Connection:D) { + my $host = $request.host; + my $port = $request.port; - my $content = $first-chunk.subbuf($msg-body-pos); - # Turn the inner exceptions to ours - # This may really want to be outside - CATCH { - when X::HTTP::ContentLength { - X::HTTP::Header.new( :rc($_.message), :response($response) ).throw + if self.get-proxy($request) -> $http_proxy { + $request.file = $request.url; + my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; + ($host, $port) = $proxy_host.split(':'); + $port.=Int; + if $proxy_auth.defined { + $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); } + $request.field(Connection => 'close'); } - # We also need to handle 'Transfer-Encoding: chunked', which means - # that we request more chunks and assemble the response body. - if $response.is-chunked { - $content = self.get-chunked-content($conn, $content); + self.get-connection($request, $host, $port) + } + + my $https_lock = Lock.new; + multi method get-connection(HTTP::Request-Lenient $request, Str $host, Int $port? --> Connection:D) { + my $conn; + if $request.scheme eq 'https' { + $https_lock.lock; + try require ::("IO::Socket::SSL"); + $https_lock.unlock; + die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; + $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) } - elsif $response.content-length -> $content-length is copy { - $content = self.get-content($conn, $content, $content-length); + else { + $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); + } + $conn does Connection; + $conn + } + + # heuristic to determine whether we are running in the CGI + # please adjust as required + method is-cgi() returns Bool { + %*ENV:exists or %*ENV:exists; + } + + has $.http-proxy; + # want the request to possibly match scheme, no_proxy etc + method get-proxy(HTTP::Request-Lenient $request) { + $!http-proxy //= do if self.is-cgi { + %*ENV || %*ENV; } else { - $content = self.get-content($conn, $content); + %*ENV || %*ENV; + } + if self.use-proxy( $request ) { + $!http-proxy; + } + } + + has @.no-proxy; + + has Bool $!no-proxy-check = False; + + method no-proxy() { + if @!no-proxy.elems == 0 { + if not $!no-proxy-check { + if (%*ENV || %*ENV ) -> $no-proxy { + @!no-proxy = $no-proxy.split: /\s*\,\s*/; + } + $!no-proxy-check = True; + } } + @!no-proxy; + } + + proto method use-proxy(|) {*} - $response.content = $content andthen $response.content = $response.decoded-content(:$bin); + multi method use-proxy(HTTP::Request-Lenient $request --> Bool:D) { + self.use-proxy($request.host) } - $response -} + multi method use-proxy(Str $host) returns Bool { + my $rc = True; + + for self.no-proxy -> $no-proxy { + if $host ~~ /$no-proxy/ { + $rc = False; + last; + } + } + $rc + } -proto method get-connection(|) {*} + multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { + basic-auth-token("{$login}:{$passwd}"); -multi method get-connection(HTTP::Request $request --> Connection:D) { - my $host = $request.host; - my $port = $request.port; + } + multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { + "Basic " ~ MIME::Base64.encode-str($creds, :oneline); + } - if self.get-proxy($request) -> $http_proxy { - $request.file = $request.url; - my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; - ($host, $port) = $proxy_host.split(':'); - $port.=Int; - if $proxy_auth.defined { - $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); + method setup-auth(HTTP::Request-Lenient $request) { + # use HTTP Auth + if self.use-auth($request) { + $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); } - $request.field(Connection => 'close'); } - self.get-connection($request, $host, $port) -} -my $https_lock = Lock.new; -multi method get-connection(HTTP::Request $request, Str $host, Int $port? --> Connection:D) { - my $conn; - if $request.scheme eq 'https' { - $https_lock.lock; - try require ::("IO::Socket::SSL"); - $https_lock.unlock; - die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; - $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) - } - else { - $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); - } - $conn does Connection; - $conn -} + method use-auth(HTTP::Request-Lenient $request) { + $!auth_login.defined && $!auth_password.defined; + } -# heuristic to determine whether we are running in the CGI -# please adjust as required -method is-cgi() returns Bool { - %*ENV:exists or %*ENV:exists; -} + # :simple + our sub get($target where URI|Str) is export(:simple) { + my $ua = HTTP::UserAgent.new(:throw-exceptions); + my $response = $ua.get($target); -has $.http-proxy; -# want the request to possibly match scheme, no_proxy etc -method get-proxy(HTTP::Request $request) { - $!http-proxy //= do if self.is-cgi { - %*ENV || %*ENV; + $response.decoded-content } - else { - %*ENV || %*ENV; + + our sub head(Str $url) is export(:simple) { + my $ua = HTTP::UserAgent-Lenient.new(:throw-exceptions); + $ua.get($url).header.hash } - if self.use-proxy( $request ) { - $!http-proxy; + + our sub getprint(Str $url) is export(:simple) { + my $response = HTTP::UserAgent-Lenient.new(:throw-exceptions).get($url); + print $response.decoded-content; + $response.code } -} -has @.no-proxy; + our sub getstore(Str $url, Str $file) is export(:simple) { + $file.IO.spurt: get($url) + } -has Bool $!no-proxy-check = False; + sub _clear-url(Str $url is copy) { + $url.starts-with('http://' | 'https://') + ?? $url + !! "http://$url" + } +} -method no-proxy() { - if @!no-proxy.elems == 0 { - if not $!no-proxy-check { - if (%*ENV || %*ENV ) -> $no-proxy { - @!no-proxy = $no-proxy.split: /\s*\,\s*/; +class HTTP::UserAgent-Strict is HTTP::UserAgent-Lenient { + constant CRLF = Buf.new(13, 10); + + role Connection { + method send-request(HTTP::Request-Strict $request ) { + $request.field(Connection => 'close') unless $request.field('Connection'); + if $request.binary { + self.print($request.Str(:bin)); + self.write($request.content); + } else { + self.print: $request.Str; } - $!no-proxy-check = True; } } - @!no-proxy; -} + + multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { + basic-auth-token("{$login}:{$passwd}"); -proto method use-proxy(|) {*} + } -multi method use-proxy(HTTP::Request $request --> Bool:D) { - self.use-proxy($request.host) -} + multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { + "Basic " ~ MIME::Base64.encode-str($creds, :oneline); + } + + multi method get(URI $uri is copy, Bool :$bin, *%header ) { + my $request = HTTP::Request-Strict.new(GET => $uri, |%header); + self.request($request, :$bin) + } -multi method use-proxy(Str $host) returns Bool { - my $rc = True; + proto method post(|) {*} - for self.no-proxy -> $no-proxy { - if $host ~~ /$no-proxy/ { - $rc = False; - last; - } + multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Strict.new(POST => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$bin) } - $rc -} -multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { - basic-auth-token("{$login}:{$passwd}"); + proto method put(|) {*} -} + multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Strict.new(PUT => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$bin) + } -multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { - "Basic " ~ MIME::Base64.encode-str($creds, :oneline); -} + proto method delete(|) {*} -method setup-auth(HTTP::Request $request) { - # use HTTP Auth - if self.use-auth($request) { - $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); + multi method delete(URI $uri is copy, Bool :$bin, *%header ) { + my $request = HTTP::Request-Strict.new(DELETE => $uri, |%header); + self.request($request, :$bin) } -} -method use-auth(HTTP::Request $request) { - $!auth_login.defined && $!auth_password.defined; -} + method request(HTTP::Request-Strict $request, Bool :$bin --> HTTP::Response-Strict:D) { + my HTTP::Response-Strict $response; -# :simple -our sub get($target where URI|Str) is export(:simple) { - my $ua = HTTP::UserAgent.new(:throw-exceptions); - my $response = $ua.get($target); + # add cookies to the request + $request.add-cookies($.cookies); - $response.decoded-content -} + # set the useragent + $request.field(User-Agent => $.useragent) if $.useragent.defined; -our sub head(Str $url) is export(:simple) { - my $ua = HTTP::UserAgent.new(:throw-exceptions); - $ua.get($url).header.hash -} + # if auth has been provided add it to the request + self.setup-auth($request); + $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; + my Connection $conn = self.get-connection($request); -our sub getprint(Str $url) is export(:simple) { - my $response = HTTP::UserAgent.new(:throw-exceptions).get($url); - print $response.decoded-content; - $response.code -} + if $conn.send-request($request) { + $response = self.get-response($request, $conn, :$bin); + } + $conn.close; -our sub getstore(Str $url, Str $file) is export(:simple) { - $file.IO.spurt: get($url) -} + X::HTTP::Response.new(:rc('No response')).throw unless $response; + + $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; -sub _clear-url(Str $url is copy) { - $url.starts-with('http://' | 'https://') - ?? $url - !! "http://$url" + # save cookies + $.cookies.extract-cookies($response); + + if $response.code ~~ /^30<[0123]>/ { + $.redirects-in-a-row++; + 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); + } + else { + $.redirects-in-a-row = 0; + } + if $.throw-exceptions { + given $response.code { + when /^4/ { + X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; + } + when /^5/ { + X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; + } + } + } + + $response + } + + multi method get-connection(HTTP::Request-Strict $request --> Connection:D) { + my $host = $request.host; + my $port = $request.port; + + + if self.get-proxy($request) -> $http_proxy { + $request.file = $request.url; + my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; + ($host, $port) = $proxy_host.split(':'); + $port.=Int; + if $proxy_auth.defined { + $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); + } + $request.field(Connection => 'close'); + } + self.get-connection($request, $host, $port) + } + + my $https_lock = Lock.new; + multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection:D) { + my $conn; + if $request.scheme eq 'https' { + $https_lock.lock; + try require ::("IO::Socket::SSL"); + $https_lock.unlock; + die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; + $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) + } + else { + $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); + } + $conn does Connection; + $conn + } } +# sub EXPORT ( $strict? ) { +# if $strict and $strict eq 'strict' { +# OUR::HTTP::UserAgent := HTTP::UserAgent-Lenient; +# } else { +# OUR::HTTP::UserAgent := HTTP::UserAgent-Lenient; +# } +# Map.new; +# } + # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UserAgent/Exception.rakumod b/lib/HTTP/UserAgent/Exception.rakumod index 25c3d55..8404994 100644 --- a/lib/HTTP/UserAgent/Exception.rakumod +++ b/lib/HTTP/UserAgent/Exception.rakumod @@ -3,7 +3,7 @@ module HTTP::UserAgent::Exception { class X::HTTP is Exception { has $.rc; - has HTTP::Message $.response; + has HTTP::Message-Lenient $.response; } class X::HTTP::Internal is Exception { diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index 02cbc63..6397747 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -1,13 +1,121 @@ use Test; +# use HTTP::Message 'strict'; +# use HTTP::Request 'strict'; +# use HTTP::Response 'strict'; + +use HTTP::UA 'strict'; +use HTTP::UserAgent; +use HTTP::Message; use HTTP::Request; use HTTP::Response; +use HTTP::Header; +# use HTTP::Request; + +plan 23; + +my constant $CRLF = "\x[0d]\x[0a]"; + +################################################################################ + +# new +# is HTTP::Message.^name, 'HTTP::Message-Strict', 'strict import'; +is HTTP::Message-Strict.^name, 'HTTP::Message-Strict', 'can use strict explicitly'; + +my $m = HTTP::Message-Strict.new('somecontent', a => ['a1', 'a2']); + +# isa-ok $m, HTTP::Message, 'new 1/5'; +# isa-ok $m.header, HTTP::Header, 'new 2/5'; +isa-ok $m.header, HTTP::Header-Strict, 'new 3/5'; +is $m.field('a'), 'a1, a2', 'new 4/5'; +is $m.content, 'somecontent', 'new 5/5'; + +# 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'; -plan 3; +$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\r\na: b, c\r\na: d\r\n" + ~ "\r\nline\r\n"; +$m.parse($to_parse); +is $m.field('a'), 'b, c, d', 'parse 1/4'; +is $m.field('a').values[0], 'b', 'parse 2/4'; +# is $m.content, 'line', 'parse 3/4'; +is $m.content, "line\r\n", 'parse 3/4'; +is $m.protocol, 'HTTP/1.0', 'parse 4/4'; + +# Str +# please see explanation to preceeding parse tests. +is $m.Str, "a: b, c, d\r\nContent-Length: 6\r\n\r\nline\r\n", 'Str'; + +# clear +$m.clear; +is $m.Str, '', 'clear 1/2'; +is $m.content, '', 'clear 2/2'; + +## parse a more complex example +# new +my $m2 = HTTP::Message-Strict.new; + +# 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); + +# 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-Strict.new.charset, 'iso-8859-1', "dumb default charset"; + is HTTP::Message-Strict.new(Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; + is HTTP::Message-Strict.new(Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; + is HTTP::Message-Strict.new(Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; +}, "charset"; -my constant $CRLF = "\r\n"; +################################################################################ # construct request - move to request 042-request-issue-226.rakutest -# my $m = HTTP::Message.new: +# my $m = HTTP::Message-Strict.new: # 'four', # Content-Type => 'text/plain', # Transfer-Encoding => 'chunked' @@ -24,7 +132,7 @@ subtest { '0', # last chunk $CRLF, # end of chunk body ; # FIXME : does not test: trailer, chunk extension, binary - my HTTP::Request:D $m = HTTP::Request.new.parse: $to-parse; + my HTTP::Request-Strict:D $m = HTTP::Request-Strict.new.parse: $to-parse; is $m.protocol, 'HTTP/1.1', 'protocol'; is $m.field('Transfer-Encoding'), 'chunked', 'parsed header'; @@ -61,16 +169,17 @@ subtest { subtest { - plan 4; + 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.parse($to_parse); + my HTTP::Response-Strict:D $m2 = HTTP::Response-Strict.new.parse($to_parse); 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, $to_parse, 'non-chunked Str'; }, 'parse non-chunked response'; @@ -87,7 +196,7 @@ subtest { ~ "0\r\n" ~ "\r\n" ; - my HTTP::Response:D $m2 = HTTP::Response.new.parse($to_parse); + my HTTP::Response-Strict:D $m2 = HTTP::Response-Strict.new.parse($to_parse); ok $m2.is-text, 'text'; nok $m2.is-binary, 'not binary'; diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index 5428825..341c16f 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -18,8 +18,8 @@ my Str:D $expected = join $CRLF, "- four\n- five", # content ; # FIXME : does not test: trailer, chunk extension, binary -my HTTP::Request $r = - HTTP::Request.new: +my HTTP::Request-Strict $r = + HTTP::Request-Strict.new: POST => $url; $r.add-content: "- four\n- five"; is $r.Str, $expected, 'build non-chunked post'; diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest index 5e3f3ec..381e6c0 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -28,7 +28,7 @@ my constant $CRLF = "\r\n"; subtest { plan 4; - my $r = HTTP::Response.new; + my $r = HTTP::Response-Strict.new; my Str:D $expected = join $CRLF, 'HTTP/1.1 200 OK', # status line 'Content-Length: 7', # header From 169f4ee7c52213a6e0222f3ccfc0f7e8561812fd Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 24 Jan 2026 15:22:13 -0800 Subject: [PATCH 03/28] keep original names --- lib/HTTP/Cookies.rakumod | 4 +-- lib/HTTP/Header.rakumod | 6 ++-- lib/HTTP/Message.rakumod | 15 +++++----- lib/HTTP/Request.rakumod | 10 +++---- lib/HTTP/Response.rakumod | 18 ++++++------ lib/HTTP/UserAgent.rakumod | 42 ++++++++++++++-------------- lib/HTTP/UserAgent/Exception.rakumod | 2 +- 7 files changed, 48 insertions(+), 49 deletions(-) diff --git a/lib/HTTP/Cookies.rakumod b/lib/HTTP/Cookies.rakumod index 5dc4c1f..808a52d 100644 --- a/lib/HTTP/Cookies.rakumod +++ b/lib/HTTP/Cookies.rakumod @@ -44,12 +44,12 @@ my class HTTP::Cookies::Actions { } } -method extract-cookies(HTTP::Response-Lenient $response) { +method extract-cookies(HTTP::Response $response) { self.set-cookie($_) for $response.field('Set-Cookie').grep({ $_.defined }).map({ "Set-Cookie: $_" }).flat; self.save if $.autosave; } -method add-cookie-header(HTTP::Request-Lenient $request) { +method add-cookie-header(HTTP::Request $request) { for @.cookies -> $cookie { # TODO this check sucks, eq is not the right (should probably use uri) #next if $cookie.domain.defined diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 4d6bf3d..1c938c4 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -1,6 +1,6 @@ use HTTP::Header::Field; -class HTTP::Header-Lenient { +class HTTP::Header { # headers container has @.fields; @@ -131,7 +131,7 @@ class HTTP::Header-Lenient { } -class HTTP::Header-Strict is HTTP::Header-Lenient { +class HTTP::Header-Strict is HTTP::Header { use HTTP::Header::ETag; grammar HTTP::Header-Strict::Grammar { @@ -227,7 +227,7 @@ class HTTP::Header-Strict is HTTP::Header-Lenient { # if $strict and $strict eq 'strict' { # OUR::HTTP::Header := HTTP::Header-Strict; # } else { -# OUR::HTTP::Header := HTTP::Header-Lenient; +# OUR::HTTP::Header := HTTP::Header; # } # Map.new; # } diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 1db24ea..b65d7d0 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -2,9 +2,9 @@ use HTTP::Header; use HTTP::MediaType; use Encode; -class HTTP::Message-Lenient { +class HTTP::Message { - has HTTP::Header-Lenient $.header; # = HTTP::Header.new; + has HTTP::Header $.header = HTTP::Header.new; has $.content is rw; has $.protocol is rw = 'HTTP/1.1'; @@ -17,7 +17,7 @@ class HTTP::Message-Lenient { my constant $DELIM = $CRLF x 2; method new($content?, *%fields) { - my $header = HTTP::Header-Lenient.new(|%fields); + my $header = HTTP::Header.new(|%fields); self.bless(:$header, :$content); } @@ -27,7 +27,7 @@ class HTTP::Message-Lenient { } class X::Decoding is Exception { - has HTTP::Message-Lenient $.response; + has HTTP::Message $.response; has Blob $.content; method message() { "Problem decoding content"; @@ -108,7 +108,7 @@ class HTTP::Message-Lenient { #| 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-Lenient $header --> Bool:D ) { + 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' } @@ -194,7 +194,6 @@ class HTTP::Message-Lenient { } method parse($raw_message) { - say 'LENIENT PARSE'; my @lines = $raw_message.split(/$CRLF/); my ($first, $second, $third) = @lines.shift.split(/\s+/); @@ -254,7 +253,7 @@ class HTTP::Message-Lenient { } -class HTTP::Message-Strict is HTTP::Message-Lenient { +class HTTP::Message-Strict is HTTP::Message { #| see https://docs.raku.org/language/grammars#Attributes_in_grammars my constant $CRLF = "\x[0d]\x[0a]"; my constant $DELIM = $CRLF x 2; @@ -338,7 +337,7 @@ class HTTP::Message-Strict is HTTP::Message-Lenient { # if $strict and $strict eq 'strict' { # OUR::HTTP::Message := HTTP::Message-Strict; # } else { -# OUR::HTTP::Message := HTTP::Message-Lenient; +# OUR::HTTP::Message := HTTP::Message; # } # Map.new; # } diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index c18fee1..80bd26e 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -6,7 +6,7 @@ use MIME::Base64; subset RequestMethod of Str where any(); -class HTTP::Request-Lenient is HTTP::Message-Lenient { +class HTTP::Request is HTTP::Message { has RequestMethod $.method is rw; has $.url is rw; @@ -37,7 +37,7 @@ class HTTP::Request-Lenient is HTTP::Message-Lenient { } } - my $header = HTTP::Header-Lenient.new(|%fields); + my $header = HTTP::Header.new(|%fields); self.new($method // 'GET', $uri, $header, :$bin); } else { @@ -47,7 +47,7 @@ class HTTP::Request-Lenient is HTTP::Message-Lenient { multi method new() { self.bless } - multi method new(RequestMethod $method, URI $uri, HTTP::Header-Lenient $header, Bool :$bin) { + multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { my $url = $uri.grammar.parse_result.orig; my $file = $uri.path_query || '/'; @@ -292,7 +292,7 @@ class HTTP::Request-Lenient is HTTP::Message-Lenient { } } -class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request-Lenient { +class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { my constant $CRLF = "\x[0D]\x[0A]"; @@ -368,7 +368,7 @@ class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request-Lenient { # if $strict and $strict eq 'strict' { # OUR::HTTP::Request := HTTP::Request-Strict; # } else { -# OUR::HTTP::Request := HTTP::Request-Lenient; +# OUR::HTTP::Request := HTTP::Request; # } # Map.new; # } diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index f6e7b76..d1304b4 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -3,11 +3,11 @@ use HTTP::Status; use HTTP::Request; use HTTP::UserAgent::Exception; -class HTTP::Response-Lenient is HTTP::Message-Lenient { +class HTTP::Response is HTTP::Message { has $.status-line is rw; has $.code is rw; - has HTTP::Request-Lenient $.request is rw; + has HTTP::Request $.request is rw; my $CRLF = "\r\n"; @@ -31,7 +31,7 @@ class HTTP::Response-Lenient is HTTP::Message-Lenient { } multi method new(Int:D $code = 200, *%fields) { - my $header = HTTP::Header-Lenient.new(|%fields); + my $header = HTTP::Header.new(|%fields); self.bless(:$code, :$header); } @@ -65,8 +65,8 @@ class HTTP::Response-Lenient is HTTP::Message-Lenient { $!status-line = $code ~ " " ~ get_http_status_msg($code); } - method next-request(--> HTTP::Request-Lenient:D) { - my HTTP::Request-Lenient $new-request; + method next-request(--> HTTP::Request:D) { + my HTTP::Request $new-request; my $location = ~self.header.field('Location').values; @@ -83,7 +83,7 @@ class HTTP::Response-Lenient is HTTP::Message-Lenient { my %args = $method => $location; - $new-request = HTTP::Request-Lenient.new(|%args); + $new-request = HTTP::Request.new(|%args); unless ~$new-request.field('Host').values { my $hh = ~$!request.field('Host').values; @@ -103,10 +103,10 @@ class HTTP::Response-Lenient is HTTP::Message-Lenient { } } -class HTTP::Response-Strict is HTTP::Response-Lenient is HTTP::Message-Strict { +class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { my constant $CRLF = "\x[0D]\x[0A]"; - method next-request(--> HTTP::Request-Lenient:D) { + method next-request(--> HTTP::Request:D) { my HTTP::Request-Strict $new-request; my $location = ~self.header.field('Location').values; @@ -148,7 +148,7 @@ class HTTP::Response-Strict is HTTP::Response-Lenient is HTTP::Message-Strict { # if $strict and $strict eq 'strict' { # OUR::HTTP::Response := HTTP::Response-Strict; # } else { -# OUR::HTTP::Response := HTTP::Response-Lenient; +# OUR::HTTP::Response := HTTP::Response; # } # Map.new; # } diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 20afa6f..48c455a 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -12,7 +12,7 @@ use URI; use File::Temp; use MIME::Base64; -class HTTP::UserAgent-Lenient { +class HTTP::UserAgent { # use HTTP::Response:auth; # use HTTP::Request:auth; # use HTTP::Cookies; @@ -30,7 +30,7 @@ class HTTP::UserAgent-Lenient { # placeholder role to make signatures nicer # and enable greater abstraction role Connection { - method send-request(HTTP::Request-Lenient $request ) { + method send-request(HTTP::Request $request ) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { self.print($request.Str(:bin)); @@ -112,7 +112,7 @@ class HTTP::UserAgent-Lenient { proto method get(|) {*} multi method get(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Lenient.new(GET => $uri, |%header); + my $request = HTTP::Request.new(GET => $uri, |%header); self.request($request, :$bin) } @@ -123,7 +123,7 @@ class HTTP::UserAgent-Lenient { proto method post(|) {*} multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Lenient.new(POST => $uri, |%header); + my $request = HTTP::Request.new(POST => $uri, |%header); $request.add-form-data(%form); self.request($request, :$bin) } @@ -135,7 +135,7 @@ class HTTP::UserAgent-Lenient { proto method put(|) {*} multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Lenient.new(PUT => $uri, |%header); + my $request = HTTP::Request.new(PUT => $uri, |%header); $request.add-form-data(%form); self.request($request, :$bin) } @@ -147,7 +147,7 @@ class HTTP::UserAgent-Lenient { proto method delete(|) {*} multi method delete(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Lenient.new(DELETE => $uri, |%header); + my $request = HTTP::Request.new(DELETE => $uri, |%header); self.request($request, :$bin) } @@ -155,8 +155,8 @@ class HTTP::UserAgent-Lenient { self.delete(URI.new(_clear-url($uri)), :$bin, |%header) } - method request(HTTP::Request-Lenient $request, Bool :$bin --> HTTP::Response-Lenient:D) { - my HTTP::Response-Lenient $response; + method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { + my HTTP::Response $response; # add cookies to the request $request.add-cookies($.cookies); @@ -275,7 +275,7 @@ class HTTP::UserAgent-Lenient { $content } - method get-response(HTTP::Request-Lenient $request, Connection $conn, Bool :$bin --> HTTP::Response-Lenient:D) { + method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; @@ -313,7 +313,7 @@ class HTTP::UserAgent-Lenient { } - my HTTP::Response-Lenient $response = HTTP::Response-Lenient.new($header-chunk); + my HTTP::Response $response = HTTP::Response.new($header-chunk); $response.request = $request; if $response.has-content { @@ -350,7 +350,7 @@ class HTTP::UserAgent-Lenient { proto method get-connection(|) {*} - multi method get-connection(HTTP::Request-Lenient $request --> Connection:D) { + multi method get-connection(HTTP::Request $request --> Connection:D) { my $host = $request.host; my $port = $request.port; @@ -369,7 +369,7 @@ class HTTP::UserAgent-Lenient { } my $https_lock = Lock.new; - multi method get-connection(HTTP::Request-Lenient $request, Str $host, Int $port? --> Connection:D) { + multi method get-connection(HTTP::Request $request, Str $host, Int $port? --> Connection:D) { my $conn; if $request.scheme eq 'https' { $https_lock.lock; @@ -393,7 +393,7 @@ class HTTP::UserAgent-Lenient { has $.http-proxy; # want the request to possibly match scheme, no_proxy etc - method get-proxy(HTTP::Request-Lenient $request) { + method get-proxy(HTTP::Request $request) { $!http-proxy //= do if self.is-cgi { %*ENV || %*ENV; } @@ -423,7 +423,7 @@ class HTTP::UserAgent-Lenient { proto method use-proxy(|) {*} - multi method use-proxy(HTTP::Request-Lenient $request --> Bool:D) { + multi method use-proxy(HTTP::Request $request --> Bool:D) { self.use-proxy($request.host) } @@ -448,14 +448,14 @@ class HTTP::UserAgent-Lenient { "Basic " ~ MIME::Base64.encode-str($creds, :oneline); } - method setup-auth(HTTP::Request-Lenient $request) { + method setup-auth(HTTP::Request $request) { # use HTTP Auth if self.use-auth($request) { $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); } } - method use-auth(HTTP::Request-Lenient $request) { + method use-auth(HTTP::Request $request) { $!auth_login.defined && $!auth_password.defined; } @@ -468,12 +468,12 @@ class HTTP::UserAgent-Lenient { } our sub head(Str $url) is export(:simple) { - my $ua = HTTP::UserAgent-Lenient.new(:throw-exceptions); + my $ua = HTTP::UserAgent.new(:throw-exceptions); $ua.get($url).header.hash } our sub getprint(Str $url) is export(:simple) { - my $response = HTTP::UserAgent-Lenient.new(:throw-exceptions).get($url); + my $response = HTTP::UserAgent.new(:throw-exceptions).get($url); print $response.decoded-content; $response.code } @@ -489,7 +489,7 @@ class HTTP::UserAgent-Lenient { } } -class HTTP::UserAgent-Strict is HTTP::UserAgent-Lenient { +class HTTP::UserAgent-Strict is HTTP::UserAgent { constant CRLF = Buf.new(13, 10); role Connection { @@ -630,9 +630,9 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent-Lenient { # sub EXPORT ( $strict? ) { # if $strict and $strict eq 'strict' { -# OUR::HTTP::UserAgent := HTTP::UserAgent-Lenient; +# OUR::HTTP::UserAgent := HTTP::UserAgent; # } else { -# OUR::HTTP::UserAgent := HTTP::UserAgent-Lenient; +# OUR::HTTP::UserAgent := HTTP::UserAgent; # } # Map.new; # } diff --git a/lib/HTTP/UserAgent/Exception.rakumod b/lib/HTTP/UserAgent/Exception.rakumod index 8404994..25c3d55 100644 --- a/lib/HTTP/UserAgent/Exception.rakumod +++ b/lib/HTTP/UserAgent/Exception.rakumod @@ -3,7 +3,7 @@ module HTTP::UserAgent::Exception { class X::HTTP is Exception { has $.rc; - has HTTP::Message-Lenient $.response; + has HTTP::Message $.response; } class X::HTTP::Internal is Exception { From b7af1411169dccacda30bbdf21b1e42df68e9e0e Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 24 Jan 2026 15:24:16 -0800 Subject: [PATCH 04/28] fix expected error message --- t/040-request.rakutest | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/t/040-request.rakutest b/t/040-request.rakutest index a945c72..b162a39 100644 --- a/t/040-request.rakutest +++ b/t/040-request.rakutest @@ -45,7 +45,7 @@ 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"); +throws-like({ $r1.set-method: 'TEST' }, /'expected RequestMethod but got Str'/, "rejects wrong method"); lives-ok { $r1.set-method: 'PUT' }, "set method"; is $r1.method, 'PUT', 'set-method 1/1'; From 8ea164994c4b2d883df2c6e143e3fd1ee5766d16 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 24 Jan 2026 20:13:06 -0800 Subject: [PATCH 05/28] reorg modules; fix imports; restore original modules --- lib/HTTP/Header.rakumod | 297 ++++------ lib/HTTP/Message.rakumod | 465 +++++++--------- lib/HTTP/Request.rakumod | 508 ++++++++--------- lib/HTTP/Response.rakumod | 191 +++---- lib/HTTP/UA-Strict.rakumod | 431 +++++++++++++++ lib/HTTP/UserAgent.rakumod | 878 ++++++++++++------------------ t/021-message-issue-226.rakutest | 13 +- t/040-request.rakutest | 2 +- t/042-request-issue-226.rakutest | 3 +- t/051-response-issue-226.rakutest | 3 +- 10 files changed, 1361 insertions(+), 1430 deletions(-) create mode 100644 lib/HTTP/UA-Strict.rakumod diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 1c938c4..d4223aa 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -1,235 +1,132 @@ -use HTTP::Header::Field; +unit class HTTP::Header; -class HTTP::Header { +use HTTP::Header::Field; - # headers container - has @.fields; +# headers container +has @.fields; - grammar HTTP::Header::Grammar { - token TOP { - [ \r?\n ]* - } +our grammar HTTP::Header::Grammar { + token TOP { + [ \r?\n ]* + } - token message-header { - $=[ <-[:]>+ ] ':' - } + token message-header { + $=[ <-[:]>+ ] ':' + } - token field-value { - [ ( ['W/' | 'w/'] )? ? - $=[ <-[\r\n"]>+ ] || \h+ ]* - ? - } - token quot { - <['"]> - } + token field-value { + [ ( ['W/' | 'w/'] )? ? + $=[ <-[\r\n"]>+ ] || \h+ ]* + ? + } + token quot { + <['"]> } +} - class HTTP::Header::Actions { - method message-header($/) { - my $value = $.made; - my $k = ~$; - my @v = $value.Array; - - @v[0] = $value ~ @v[0] if $value && $k.lc ne 'etag'; - if $k && @v -> $v { - if $*OBJ.field($k) { - $*OBJ.push-field: |($k => $v); - } else { - $*OBJ.field: |($k => $v); - } - } - } +our class HTTP::Header::Actions { + method message-header($/) { + my $value = $.made; + my $k = ~$; + my @v = $value.Array; - method field-value($/) { - make { - prefix => $0, - content => $ ?? - $.Str.split(',')>>.trim !! Nil - } + @v[0] = $value ~ @v[0] if $value && $k.lc ne 'etag'; + if $k && @v -> $v { + if $*OBJ.field($k) { + $*OBJ.push-field: |($k => $v); + } else { + $*OBJ.field: |($k => $v); } + } } - # we want to pass arguments like this: .new(a => 1, b => 2 ...) - method new(*%fields) { - my @fields = %fields.sort(*.key).map: { - HTTP::Header::Field.new(:name(.key), :values(.value.list)); + method field-value($/) { + make { + prefix => $0, + content => $ ?? + $.Str.split(',')>>.trim !! Nil } - - self.bless(:@fields) } +} - proto method field(|) {*} - - # set fields - multi method field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $f = HTTP::Header::Field.new(:name($k), :values($v.list)); - if @.fields.first({ .name.lc eq $k.lc }) { - @.fields[@.fields.first({ .name.lc eq $k.lc }, :k)] = $f; - } - else { - @.fields.push: $f; - } - } +# we want to pass arguments like this: .new(a => 1, b => 2 ...) +method new(*%fields) { + my @fields = %fields.sort(*.key).map: { + HTTP::Header::Field.new(:name(.key), :values(.value.list)); } - # get fields - multi method field($field) { - my $field-lc := $field.lc; - @.fields.first(*.name.lc eq $field-lc) - } + self.bless(:@fields) +} - # initialize fields - method init-field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $k-lc := $k.lc; - @.fields.push: - HTTP::Header::Field.new(:name($k), :values($v.list)) - unless @.fields.first(*.name.lc eq $k-lc); - } - } +proto method field(|) {*} - # add value to existing fields - method push-field(*%fields) { - for %fields.sort(*.key) -> (:key($k), :value($v)) { - my $k-lc := $k.lc; - @.fields.first(*.name.lc eq $k-lc).values.append: $v.list; +# set fields +multi method field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $f = HTTP::Header::Field.new(:name($k), :values($v.list)); + if @.fields.first({ .name.lc eq $k.lc }) { + @.fields[@.fields.first({ .name.lc eq $k.lc }, :k)] = $f; + } + else { + @.fields.push: $f; } } +} - # remove a field - method remove-field(Str $field) { - my $field-lc := $field.lc; - @.fields.splice($_, 1) - with @.fields.first(*.name.lc eq $field-lc, :k); - } - - # get fields names - method header-field-names() { - @.fields.map(*.name) - } +# get fields +multi method field($field) { + my $field-lc := $field.lc; + @.fields.first(*.name.lc eq $field-lc) +} - # return the headers as name -> value hash - method hash(--> Hash:D) { - @.fields.map({ $_.name => $_.values }).Hash +# initialize fields +method init-field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $k-lc := $k.lc; + @.fields.push: + HTTP::Header::Field.new(:name($k), :values($v.list)) + unless @.fields.first(*.name.lc eq $k-lc); } +} - # remove all fields - method clear() { - @.fields = (); +# add value to existing fields +method push-field(*%fields) { + for %fields.sort(*.key) -> (:key($k), :value($v)) { + my $k-lc := $k.lc; + @.fields.first(*.name.lc eq $k-lc).values.append: $v.list; } +} - # get header as string - method Str($eol = "\n") { - @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join - } +# remove a field +method remove-field(Str $field) { + my $field-lc := $field.lc; + @.fields.splice($_, 1) + with @.fields.first(*.name.lc eq $field-lc, :k); +} - method parse($raw) { - my $*OBJ = self; - HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); - } +# get fields names +method header-field-names() { + @.fields.map(*.name) } +# return the headers as name -> value hash +method hash(--> Hash:D) { + @.fields.map({ $_.name => $_.values }).Hash +} -class HTTP::Header-Strict is HTTP::Header { - use HTTP::Header::ETag; - - grammar HTTP::Header-Strict::Grammar { - 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 { - \" \" - } - token opaque-content { - <[\x[21]..\x[FF]]-[\x[22]\x[7F]]>* - } - token vchars { <[\x[21]..\x[7E]]>+ } - token field-vchars { <[\x[21]..\x[FF]]-[\x[7F]]>+ } - token value { - [ <[\t\x[20]]>* ]* - } - token quoted-string { - \" \" - } - token quoted-content { - [ | ]* - } - token qtd-text { - <[\t\x[20]..\x[FF]]-[\x[22]\x[5C]\x[7F]]>+ - } - token quotable-char { - <[\t\x[20]..\x[FF]]-[\x[7F]]> - } - token quoted-pair { - \\ - } - } +# remove all fields +method clear() { + @.fields = (); +} - class HTTP::Header-Strict::Actions { - 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; - } - } - - multi method field ( HTTP::Header::ETag:D $etag ) { - @.fields.push: $etag; - } - - method parse($raw) { - my $*OBJ = self; - HTTP::Header-Strict::Grammar.parse: - $raw, - actions => HTTP::Header-Strict::Actions - ; - } +# get header as string +method Str($eol = "\n") { + @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } -# sub EXPORT ( $strict? ) { -# if $strict and $strict eq 'strict' { -# OUR::HTTP::Header := HTTP::Header-Strict; -# } else { -# OUR::HTTP::Header := HTTP::Header; -# } -# Map.new; -# } +method parse($raw) { + my $*OBJ = self; + HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); +} # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index b65d7d0..943de35 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -1,345 +1,252 @@ +unit class HTTP::Message; + use HTTP::Header; use HTTP::MediaType; use Encode; -class HTTP::Message { - - has HTTP::Header $.header = HTTP::Header.new; - has $.content is rw; +has HTTP::Header $.header = HTTP::Header.new; +has $.content is rw; - has $.protocol is rw = 'HTTP/1.1'; +has $.protocol is rw = 'HTTP/1.1'; - has Bool $.binary = False; - has Str @.text-types; +has Bool $.binary = False; +has Str @.text-types; - #| see https://docs.raku.org/language/grammars#Attributes_in_grammars - my constant $CRLF = "\x[0d]\x[0a]"; - my constant $DELIM = $CRLF x 2; +my $CRLF = "\r\n"; - method new($content?, *%fields) { - my $header = HTTP::Header.new(|%fields); +method new($content?, *%fields) { + my $header = HTTP::Header.new(|%fields); - self.bless(:$header, :$content); - } + self.bless(:$header, :$content); +} - method add-content($content) { - $.content ~= $content; - } +method add-content($content) { + $.content ~= $content; +} - class X::Decoding is Exception { - has HTTP::Message $.response; - has Blob $.content; - method message() { - "Problem decoding content"; - } +class X::Decoding is Exception { + has HTTP::Message $.response; + has Blob $.content; + method message() { + "Problem decoding content"; } +} - method content-type(--> Str:D) { - $!header.field('Content-Type').values[0] || ''; - } +method content-type(--> Str:D) { + $!header.field('Content-Type').values[0] || ''; +} - has HTTP::MediaType $!media-type; +has HTTP::MediaType $!media-type; - method media-type(--> HTTP::MediaType) { - without $!media-type { - if self.content-type() -> $ct { - $!media-type = HTTP::MediaType.parse($ct); - } +method media-type(--> HTTP::MediaType) { + without $!media-type { + if self.content-type() -> $ct { + $!media-type = HTTP::MediaType.parse($ct); } - $!media-type } + $!media-type +} - # Don't want to put the heuristic in the HTTP::MediaType - # Also moving this here makes it much more easy to test +# Don't want to put the heuristic in the HTTP::MediaType +# Also moving this here makes it much more easy to test - method charset(--> Str:D) { - if self.media-type -> $mt { - $mt.charset || ( $mt.major-type eq 'text' ?? $mt.sub-type eq 'html' ?? 'utf-8' !! 'iso-8859-1' !! 'utf-8'); - } - else { - # At this point we're probably screwed anyway - 'iso-8859-1' - } +method charset(--> Str:D) { + if self.media-type -> $mt { + $mt.charset || ( $mt.major-type eq 'text' ?? $mt.sub-type eq 'html' ?? 'utf-8' !! 'iso-8859-1' !! 'utf-8'); } + else { + # At this point we're probably screwed anyway + 'iso-8859-1' + } +} - # This is already a candidate for refactoring - # Just want to get it working - method is-text(--> Bool:D) { - if $!binary { - False +# This is already a candidate for refactoring +# Just want to get it working +method is-text(--> Bool:D) { + if $!binary { + False + } + elsif self.media-type -> $mt { + if $mt.type ~~ any(@!text-types) { + True } - elsif self.media-type -> $mt { - if $mt.type ~~ any(@!text-types) { - True - } - else { - given $mt.major-type { - when 'text' { - True - } - when any() { - False - } - when 'application' { - given $mt.sub-type { - when /xml|javascript|json/ { - True - } - default { - False - } + else { + given $mt.major-type { + when 'text' { + True + } + when any() { + False + } + when 'application' { + given $mt.sub-type { + when /xml|javascript|json/ { + True + } + default { + False } } - default { - # Not sure about this - True - } + } + default { + # Not sure about this + True } } } - else { - # No content type, try and blow up - True - } } + else { + # No content type, try and blow up + True + } +} - method is-binary(--> Bool:D) { !self.is-text } +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; - } +#| 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'); - } +method content-encoding() { + $!header.field('Content-Encoding'); +} - class X::Deflate is Exception { - has Str $.message; - } +class X::Deflate is Exception { + has Str $.message; +} - method inflate-content(--> Blob:D) { - if self.content-encoding -> $v is copy { - # This is a guess - $v = 'zlib' if $v eq 'compress' ; - $v = 'zlib' if $v eq 'deflate'; - try require ::('Compress::Zlib'); - if ::('Compress::Zlib::Stream') ~~ Failure { - X::Deflate.new(message => "Please install 'Compress::Zlib' to uncompress '$v' encoded content").throw; - } - else { - my $z = ::('Compress::Zlib::Stream').new( |{ $v => True }); - $z.inflate($!content); - } +method inflate-content(--> Blob:D) { + if self.content-encoding -> $v is copy { + # This is a guess + $v = 'zlib' if $v eq 'compress' ; + $v = 'zlib' if $v eq 'deflate'; + try require ::('Compress::Zlib'); + if ::('Compress::Zlib::Stream') ~~ Failure { + X::Deflate.new(message => "Please install 'Compress::Zlib' to uncompress '$v' encoded content").throw; } else { - $!content; + my $z = ::('Compress::Zlib::Stream').new( |{ $v => True }); + $z.inflate($!content); } } + else { + $!content; + } +} - method decoded-content(:$bin) { - return $!content if $!content ~~ Str || $!content.bytes == 0; - - my $content = self.inflate-content; - # [todo] - # If charset is missing from Content-Type, then before defaulting - # to anything it should attempt to extract it from $.content like (for HTML): - # - # - - my $decoded_content; - - if !$bin && self.is-text { - my $charset = self.charset; - $decoded_content = try { - Encode::decode($charset, $content); - } || try { - $content.decode('iso-8859-1'); - } || try { - $content.unpack("A*") - } || X::Decoding.new(content => $content, response => self).throw; - } - else { - $decoded_content = $content; - } +method decoded-content(:$bin) { + return $!content if $!content ~~ Str || $!content.bytes == 0; - $decoded_content - } + my $content = self.inflate-content; + # [todo] + # If charset is missing from Content-Type, then before defaulting + # to anything it should attempt to extract it from $.content like (for HTML): + # + # + + my $decoded_content; - multi method field(Str $f) { - $.header.field($f) + if !$bin && self.is-text { + my $charset = self.charset; + $decoded_content = try { + Encode::decode($charset, $content); + } || try { + $content.decode('iso-8859-1'); + } || try { + $content.unpack("A*") + } || X::Decoding.new(content => $content, response => self).throw; } - - multi method field(*%fields) { - $.header.field(|%fields) + else { + $decoded_content = $content; } - method push-field(*%fields) { - $.header.push-field(|%fields) - } + $decoded_content +} - method remove-field(Str $field) { - $.header.remove-field($field) - } +multi method field(Str $f) { + $.header.field($f) +} - method clear { - $.header.clear; - $.content = '' - } +multi method field(*%fields) { + $.header.field(|%fields) +} - method parse($raw_message) { - my @lines = $raw_message.split(/$CRLF/); +method push-field(*%fields) { + $.header.push-field(|%fields) +} - my ($first, $second, $third) = @lines.shift.split(/\s+/); +method remove-field(Str $field) { + $.header.remove-field($field) +} - if $third.index('/') { # is a request - $.protocol = $third; - } - else { # is a response - $.protocol = $first; - } +method clear { + $.header.clear; + $.content = '' +} - 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); - } - } - } else { - $.content = @lines.grep({ $_ }).join("\n"); - last; - } - } +method parse($raw_message) { + my @lines = $raw_message.split(/$CRLF/); + + my ($first, $second, $third) = @lines.shift.split(/\s+/); - self + if $third.index('/') { # is a request + $.protocol = $third; + } + else { # is a response + $.protocol = $first; } - method Str($eol = "\n", Bool :$strict, :$debug, Bool :$bin) { - my constant $max_size = 300; - my $s = $.header.Str($eol); - $s ~= $eol if $.content; - - # The :bin will be passed from the H::UA - if not $bin { - $s ~= $.content ~ $eol if $.content and !$debug; - } - if $.content and $debug { - if $bin || self.is-binary { - $s ~= $eol ~ "=Content size : " ~ $.content.elems ~ " bytes "; - $s ~= "$eol ** Not showing binary content ** $eol"; - } - else { - $s ~= $eol ~ "=Content size: "~$.content.Str.chars~" chars"; - $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; - $s ~= $eol ~ $.content.Str.substr(0, $max_size) ~ $eol; + 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); + } } + } else { + $.content = @lines.grep({ $_ }).join("\n"); + last; } - - $s } -} + self +} -class HTTP::Message-Strict is HTTP::Message { - #| see https://docs.raku.org/language/grammars#Attributes_in_grammars - my constant $CRLF = "\x[0d]\x[0a]"; - my constant $DELIM = $CRLF x 2; - - method new($content?, *%fields) { - my $header = HTTP::Header-Strict.new(|%fields); - - self.bless(:$header, :$content); - } +method Str($eol = "\n", :$debug, Bool :$bin) { + my constant $max_size = 300; + my $s = $.header.Str($eol); + $s ~= $eol if $.content; - method parse ( $raw_message ) { - my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; - my ( $fields, $content ) = $rest.split: $DELIM, 2; - - my ($first, $second, $third) = $start-line.split(/\s+/); - if $third.index('/') { # is a request - $.protocol = $third; - } - else { # is a response - $.protocol = $first; - } - - # $.header = HTTP::Header-Strict.new; - $.header.parse: $fields; - return self unless $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 *, - @lines.map: - -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } - ; - $.content = @lines.join; - return self; - } else { - $.content = $content; - return self; - } - - self + # The :bin will be passed from the H::UA + if not $bin { + $s ~= $.content ~ $eol if $.content and !$debug; } - - method Str ( :$debug, Bool :$bin ) { - my constant $max_size = 300; - # TODO : reference relevant section of relevant RFC - # TODO : need to consider Str vs Buf length ? - self.field: Content-Length => ( $.content.?encode or $.content ).bytes.Str - if $.content and not self.is-chunked; - my $s = $.header.Str: $CRLF; - - # The :bin will be passed from the H::UA - if not $bin { - # do not append CRLF unless chunked - # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 - # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 - # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 - $s = join $CRLF, $s, $.content if $.content; + if $.content and $debug { + if $bin || self.is-binary { + $s ~= $eol ~ "=Content size : " ~ $.content.elems ~ " bytes "; + $s ~= "$eol ** Not showing binary content ** $eol"; } - if $.content and $debug { - if $bin || self.is-binary { - $s ~= $CRLF ~ "=Content size : " ~ $.content.elems ~ " bytes "; - $s ~= "$CRLF ** Not showing binary content ** $CRLF"; - } - else { - $s ~= $CRLF ~ "=Content size: "~$.content.Str.chars~" chars"; - $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; - $s ~= $CRLF ~ $.content.Str.substr(0, $max_size) ~ $CRLF; - } + else { + $s ~= $eol ~ "=Content size: "~$.content.Str.chars~" chars"; + $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; + $s ~= $eol ~ $.content.Str.substr(0, $max_size) ~ $eol; } - - $s } + $s } -# sub EXPORT ( $strict? ) { -# if $strict and $strict eq 'strict' { -# OUR::HTTP::Message := HTTP::Message-Strict; -# } else { -# OUR::HTTP::Message := HTTP::Message; -# } -# Map.new; -# } - # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index 80bd26e..42c73c0 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -4,373 +4,291 @@ use URI::Escape; use HTTP::MediaType; use MIME::Base64; +unit class HTTP::Request is HTTP::Message; + subset RequestMethod of Str where any(); -class HTTP::Request is HTTP::Message { - - has RequestMethod $.method is rw; - has $.url is rw; - has $.file is rw; - has $.uri is rw; +has RequestMethod $.method is rw; +has $.url is rw; +has $.file is rw; +has $.uri is rw; - has Str $.host is rw; - has Int $.port is rw; - has Str $.scheme is rw; +has Str $.host is rw; +has Int $.port is rw; +has Str $.scheme is rw; - my $CRLF = "\r\n"; +my $CRLF = "\r\n"; - my $HRC_DEBUG = %*ENV.Bool; +my $HRC_DEBUG = %*ENV.Bool; - proto method new(|) {*} +proto method new(|) {*} - multi method new(Bool :$bin, *%args) { +multi method new(Bool :$bin, *%args) { - if %args { - my ($method, $url, $file, %fields, $uri); - for %args.kv -> $key, $value { - if $key.lc ~~ any() { - $uri = $value.isa(URI) ?? $value !! URI.new($value); - $method = $key.uc; - } - else { - %fields{$key} = $value; - } + if %args { + my ($method, $url, $file, %fields, $uri); + for %args.kv -> $key, $value { + if $key.lc ~~ any() { + $uri = $value.isa(URI) ?? $value !! URI.new($value); + $method = $key.uc; + } + else { + %fields{$key} = $value; } - - my $header = HTTP::Header.new(|%fields); - self.new($method // 'GET', $uri, $header, :$bin); - } - else { - self.bless } + + my $header = HTTP::Header.new(|%fields); + self.new($method // 'GET', $uri, $header, :$bin); + } + else { + self.bless } +} - multi method new() { self.bless } +multi method new() { self.bless } - multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { - my $url = $uri.grammar.parse_result.orig; - my $file = $uri.path_query || '/'; +multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, 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'); + $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) +} - sub get-host-value(URI $uri --> Str) { - my Str $host = $uri.host; +sub get-host-value(URI $uri --> Str) { + my Str $host = $uri.host; - if $host { - if ( $uri.port != $uri.default_port ) { - $host ~= ':' ~ $uri.port; - } + if $host { + if ( $uri.port != $uri.default_port ) { + $host ~= ':' ~ $uri.port; } - $host; } + $host; +} - method set-method($method) { $.method = $method.uc } +method set-method($method) { $.method = $method.uc } - proto method uri(|) {*} +proto method uri(|) {*} - multi method uri($uri is copy where URI|Str) { - $!uri = $uri.isa(Str) ?? URI.new($uri) !! $uri ; - $!url = $!uri.grammar.parse_result.orig; - $!file = $!uri.path_query || '/'; - self.field(Host => get-host-value($!uri)); - $!uri - } +multi method uri($uri is copy where URI|Str) { + $!uri = $uri.isa(Str) ?? URI.new($uri) !! $uri ; + $!url = $!uri.grammar.parse_result.orig; + $!file = $!uri.path_query || '/'; + self.field(Host => get-host-value($!uri)); + $!uri +} - multi method uri() is rw { $!uri } +multi method uri() is rw { $!uri } - proto method host(|) {*} +proto method host(|) {*} - multi method host(--> Str:D) is rw { - $!host = ~self.field('Host').values without $!host; - $!host - } +multi method host(--> Str:D) is rw { + $!host = ~self.field('Host').values without $!host; + $!host +} - proto method port(|) {*} +proto method port(|) {*} - multi method port(--> Int) is rw { - if not $!port.defined { - # if there isn't a scheme the no default port - if try self.uri.scheme { - $!port = self.uri.port; - } +multi method port(--> Int:D) is rw { + if not $!port.defined { + # if there isn't a scheme the no default port + if try self.uri.scheme { + $!port = self.uri.port; } - $!port } + $!port +} - proto method scheme(|) {*} +proto method scheme(|) {*} - multi method scheme(--> Str:D) is rw { - without $!scheme { - CATCH { - default { $!scheme = 'http' } - } - $!scheme = self.uri.scheme; +multi method scheme(--> Str:D) is rw { + without $!scheme { + CATCH { + default { $!scheme = 'http' } } - $!scheme + $!scheme = self.uri.scheme; } + $!scheme +} - method add-cookies($cookies) { - $cookies.add-cookie-header(self) if $cookies.cookies; - } +method add-cookies($cookies) { + $cookies.add-cookie-header(self) if $cookies.cookies; +} - proto method add-content(|) {*} +proto method add-content(|) {*} - multi method add-content(Str:D $content) { - self.content ~= $content; - self.header.field(Content-Length => self.content.encode.bytes.Str); - } +multi method add-content(Str:D $content) { + self.content ~= $content; + self.header.field(Content-Length => self.content.encode.bytes.Str); +} - proto method add-form-data(|) {*} +proto method add-form-data(|) {*} - multi method add-form-data(:$multipart, *%data) { - self.add-form-data(%data.sort.Array, :$multipart); - } +multi method add-form-data(:$multipart, *%data) { + self.add-form-data(%data.sort.Array, :$multipart); +} - multi method add-form-data(%data, :$multipart) { - self.add-form-data(%data.sort.Array, :$multipart); - } +multi method add-form-data(%data, :$multipart) { + self.add-form-data(%data.sort.Array, :$multipart); +} - multi method add-form-data(Array $data, :$multipart) { - my $ct = do { - my $f = self.header.field('Content-Type'); - if $f { - $f.values[0]; - } else { - if $multipart { - 'multipart/form-data'; - } - else { - 'application/x-www-form-urlencoded'; - } +multi method add-form-data(Array $data, :$multipart) { + my $ct = do { + my $f = self.header.field('Content-Type'); + if $f { + $f.values[0]; + } else { + if $multipart { + 'multipart/form-data'; } - }; - sub form-escape($s) { - uri-escape($s).subst(:g, '%20', '+').subst(:g, '%2A', '*'); - } - given $ct { - when 'application/x-www-form-urlencoded' { - my @parts; - for @$data { - @parts.push: form-escape(.key) ~ "=" ~ form-escape(.value); - } - self.content = @parts.join("&").encode; - self.header.field(Content-Length => self.content.bytes.Str); - + else { + 'application/x-www-form-urlencoded'; } - when m:i,^ "multipart/form-data" \s* ( ";" | $ ), { - say 'generating form-data' if $HRC_DEBUG; - - my $mt = HTTP::MediaType.parse($ct); - my Str $boundary = $mt.param('boundary') // self.make-boundary(10); - (my $generated-content, $boundary) = self.form-data($data, $boundary); - $mt.param('boundary', $boundary); - $ct = $mt.Str; - my Str $encoded-content = $generated-content; - self.content = $encoded-content; - self.header.field(Content-Length => $encoded-content.encode('ascii').bytes.Str); + } + }; + sub form-escape($s) { + uri-escape($s).subst(:g, '%20', '+').subst(:g, '%2A', '*'); + } + given $ct { + when 'application/x-www-form-urlencoded' { + my @parts; + for @$data { + @parts.push: form-escape(.key) ~ "=" ~ form-escape(.value); } + self.content = @parts.join("&").encode; + self.header.field(Content-Length => self.content.bytes.Str); + + } + when m:i,^ "multipart/form-data" \s* ( ";" | $ ), { + say 'generating form-data' if $HRC_DEBUG; + + my $mt = HTTP::MediaType.parse($ct); + my Str $boundary = $mt.param('boundary') // self.make-boundary(10); + (my $generated-content, $boundary) = self.form-data($data, $boundary); + $mt.param('boundary', $boundary); + $ct = $mt.Str; + my Str $encoded-content = $generated-content; + self.content = $encoded-content; + self.header.field(Content-Length => $encoded-content.encode('ascii').bytes.Str); } - self.header.field(Content-Type => $ct) } + self.header.field(Content-Type => $ct) +} - method form-data(Array:D $content, Str:D $boundary) { - my @parts; - for @$content { - my ($k, $v) = $_.key, $_.value; - given $v { - when Str { - $k ~~ s:g/(<[\\ \"]>)/\\$1/; # escape quotes and backslashes - @parts.push: qq!Content-Disposition: form-data; name="$k"$CRLF$CRLF$v!; +method form-data(Array:D $content, Str:D $boundary) { + my @parts; + for @$content { + my ($k, $v) = $_.key, $_.value; + given $v { + when Str { + $k ~~ s:g/(<[\\ \"]>)/\\$1/; # escape quotes and backslashes + @parts.push: qq!Content-Disposition: form-data; name="$k"$CRLF$CRLF$v!; + } + when Array { + my ($file, $usename, @headers) = @$v; + unless defined $usename { + $usename = $file; + $usename ~~ s!.* "/"!! if defined($usename); } - when Array { - my ($file, $usename, @headers) = @$v; - unless defined $usename { - $usename = $file; - $usename ~~ s!.* "/"!! if defined($usename); - } - $k ~~ s:g/(<[\\ \"]>)/\\$1/; - my $disp = qq!form-data; name="$k"!; - if (defined($usename) and $usename.elems > 0) { - $usename ~~ s:g/(<[\\ \"]>)/\\$1/; - $disp ~= qq!; filename="$usename"!; - } - my $content; - my $headers = HTTP::Header.new(|@headers); - if $file { - # TODO: dynamic file upload support - $content = $file.IO.slurp; - unless $headers.field('Content-Type') { - # TODO: LWP::MediaTypes - $headers.field(Content-Type => 'application/octet-stream'); - } - } - if $headers.field('Content-Disposition') { - $disp = $headers.field('Content-Disposition'); - $headers.remove-field('Content-Disposition'); + $k ~~ s:g/(<[\\ \"]>)/\\$1/; + my $disp = qq!form-data; name="$k"!; + if (defined($usename) and $usename.elems > 0) { + $usename ~~ s:g/(<[\\ \"]>)/\\$1/; + $disp ~= qq!; filename="$usename"!; + } + my $content; + my $headers = HTTP::Header.new(|@headers); + if $file { + # TODO: dynamic file upload support + $content = $file.IO.slurp; + unless $headers.field('Content-Type') { + # TODO: LWP::MediaTypes + $headers.field(Content-Type => 'application/octet-stream'); } - if $headers.field('Content') { - $content = $headers.field('Content'); - $headers.remove-field('Content'); + } + if $headers.field('Content-Disposition') { + $disp = $headers.field('Content-Disposition'); + $headers.remove-field('Content-Disposition'); + } + if $headers.field('Content') { + $content = $headers.field('Content'); + $headers.remove-field('Content'); + } + my $head = ["Content-Disposition: $disp", + $headers.Str($CRLF), + ""].join($CRLF); + given $content { + when Str { + @parts.push: $head ~ $content; } - my $head = ["Content-Disposition: $disp", - $headers.Str($CRLF), - ""].join($CRLF); - given $content { - when Str { - @parts.push: $head ~ $content; - } - default { - die "NYI" - } + default { + die "NYI" } } - default { - die "unsupported type: $v.WHAT.gist()($content.raku())"; - } } - } - - say $content if $HRC_DEBUG; - say @parts if $HRC_DEBUG; - return "", "none" unless @parts; - - my $contents; - # TODO: dynamic upload support - my $bno = 10; - CHECK_BOUNDARY: { - for @parts { - if $_.index($boundary).defined { - # must have a better boundary - $boundary = self.make-boundary(++$bno); - redo CHECK_BOUNDARY; - } + default { + die "unsupported type: $v.WHAT.gist()($content.raku())"; } } - my $generated-content = "--$boundary$CRLF" - ~ @parts.join("$CRLF--$boundary$CRLF") - ~ "$CRLF--$boundary--$CRLF"; - - $generated-content, $boundary } - - method make-boundary(int $size=10) { - my $str = (1..$size*3).map({(^256).pick.chr}).join(''); - my $b = MIME::Base64.new.encode_base64($str, :oneline); - $b ~~ s:g/\W/X/; # ensure alnum only - $b - } - - - method Str ( :$debug, Bool :$bin) { - $.file = '/' ~ $.file unless $.file.starts-with: '/'; - my $s = "$.method $.file $.protocol"; - join $CRLF, $s, callwith $CRLF, :$debug, :$bin; - } - - method parse($raw_request) { - my @lines = $raw_request.split($CRLF); - ($.method, $.file) = @lines.shift.split(' '); - - $.url = 'http://'; - - for @lines -> $line { - if $line ~~ m:i/host:/ { - $.url ~= $line.split(/\:\s*/)[1]; + say $content if $HRC_DEBUG; + say @parts if $HRC_DEBUG; + return "", "none" unless @parts; + + my $contents; + # TODO: dynamic upload support + my $bno = 10; + CHECK_BOUNDARY: { + for @parts { + if $_.index($boundary).defined { + # must have a better boundary + $boundary = self.make-boundary(++$bno); + redo CHECK_BOUNDARY; } } - - $.url ~= $.file; - - self.uri = URI.new($.url) ; - - nextsame; } + my $generated-content = "--$boundary$CRLF" + ~ @parts.join("$CRLF--$boundary$CRLF") + ~ "$CRLF--$boundary--$CRLF"; + + $generated-content, $boundary } -class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { - my constant $CRLF = "\x[0D]\x[0A]"; - - - sub get-host-value(URI $uri --> Str) { - my Str $host = $uri.host; - if $host { - if ( $uri.port != $uri.default_port ) { - $host ~= ':' ~ $uri.port; - } - } - $host; - } - - multi method new(Bool :$bin, *%args) { - - if %args { - my ($method, $url, $file, %fields, $uri); - for %args.kv -> $key, $value { - if $key.lc ~~ any() { - $uri = $value.isa(URI) ?? $value !! URI.new($value); - $method = $key.uc; - } - else { - %fields{$key} = $value; - } - } +method make-boundary(int $size=10) { + my $str = (1..$size*3).map({(^256).pick.chr}).join(''); + my $b = MIME::Base64.new.encode_base64($str, :oneline); + $b ~~ s:g/\W/X/; # ensure alnum only + $b +} - my $header = HTTP::Header-Strict.new(|%fields); - self.new($method // 'GET', $uri, $header, :$bin); - } - else { - self.bless: header => HTTP::Header-Strict.new - } - } - multi method new() { self.bless: header => HTTP::Header-Strict.new } +method Str (:$debug, Bool :$bin) { + $.file = '/' ~ $.file unless $.file.starts-with: '/'; + my $s = "$.method $.file $.protocol"; + $s ~= $CRLF ~ callwith($CRLF, :$debug, :$bin); +} - multi method new(RequestMethod $method, URI $uri, HTTP::Header-Strict $header, Bool :$bin) { - my $url = $uri.grammar.parse_result.orig; - my $file = $uri.path_query || '/'; +method parse($raw_request) { + my @lines = $raw_request.split($CRLF); + ($.method, $.file) = @lines.shift.split(' '); - $header.field(Host => get-host-value($uri)) without $header.field('Host'); + $.url = 'http://'; - self.bless(:$method, :$url, :$header, :$file, :$uri, binary => $bin) - } - - method Str ( :$debug, Bool :$bin ) { - $.file = '/' ~ $.file unless $.file.starts-with: '/'; - my $s = "$.method $.file $.protocol"; - join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug, :$bin; + for @lines -> $line { + if $line ~~ m:i/host:/ { + $.url ~= $line.split(/\:\s*/)[1]; + } } - method parse ( $raw_request ) { - my @lines = $raw_request.split($CRLF); - ($.method, $.file) = @lines.shift.split(' '); - $.url = 'http://'; + $.url ~= $.file; - for @lines -> $line { - if $line ~~ m:i/host:/ { - $.url ~= $line.split(/\:\s*/)[1]; - } - } - - $.url ~= $.file; + self.uri = URI.new($.url) ; - self.uri = URI.new($.url); - self.HTTP::Message-Strict::parse: $raw_request; - } + nextsame; } -# sub EXPORT ( $strict? ) { -# if $strict and $strict eq 'strict' { -# OUR::HTTP::Request := HTTP::Request-Strict; -# } else { -# OUR::HTTP::Request := HTTP::Request; -# } -# Map.new; -# } - # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index d1304b4..74dc2a9 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -3,154 +3,103 @@ use HTTP::Status; use HTTP::Request; use HTTP::UserAgent::Exception; -class HTTP::Response is HTTP::Message { +unit class HTTP::Response is HTTP::Message; - has $.status-line is rw; - has $.code is rw; - has HTTP::Request $.request is rw; +has $.status-line is rw; +has $.code is rw; +has HTTP::Request $.request is rw; - my $CRLF = "\r\n"; +my $CRLF = "\r\n"; - submethod BUILD(:$!code) { - $!status-line = self.set-code($!code); - } - - proto method new(|) {*} - - # This candidate makes it easier to test weird responses - multi method new(Blob:D $header-chunk) { - # See https://tools.ietf.org/html/rfc7230#section-3.2.4 - my ($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; +submethod BUILD(:$!code) { + $!status-line = self.set-code($!code); +} - $response - } +proto method new(|) {*} - multi method new(Int:D $code = 200, *%fields) { - my $header = HTTP::Header.new(|%fields); - self.bless(:$code, :$header); - } +# This candidate makes it easier to test weird responses +multi method new(Blob:D $header-chunk) { + # See https://tools.ietf.org/html/rfc7230#section-3.2.4 + my ($rl, $header) = $header-chunk.decode('ISO-8859-1').split(/\r?\n/, 2); + X::HTTP::NoResponse.new.throw unless $rl; - method content-length(--> Int) { - my $content-length = self.field('Content-Length').values[0]; + my $code = (try $rl.split(' ')[1].Int) // 500; + my $response = self.new($code); + $response.header.parse(.subst(/"\r"?"\n"$$/, '')) with $header; - with $content-length -> $c { - X::HTTP::ContentLength.new(message => "Content-Length header value '$c' is not numeric").throw - without $content-length = try +$content-length; - $content-length - } - else { - Int - } - } + $response +} - method is-success { is-success($!code).Bool } +multi method new(Int:D $code = 200, *%fields) { + my $header = HTTP::Header.new(|%fields); + self.bless(:$code, :$header); +} - # please extend as necessary - method has-content(--> Bool:D) { - (204, 304).grep({ $!code eq $_ }) ?? False !! True; - } +method content-length(--> Int:D) { + my $content-length = self.field('Content-Length').values[0]; - method is-chunked(--> Bool:D) { - self.field('Transfer-Encoding') - && self.field('Transfer-Encoding') eq 'chunked' + with $content-length -> $c { + X::HTTP::ContentLength.new(message => "Content-Length header value '$c' is not numeric").throw + without $content-length = try +$content-length; + $content-length } - - method set-code(Int:D $code) { - $!code = $code; - $!status-line = $code ~ " " ~ get_http_status_msg($code); + else { + Int } +} - method next-request(--> HTTP::Request:D) { - my HTTP::Request $new-request; - - my $location = ~self.header.field('Location').values; - - - if $location.defined { - # Special case for the HTTP status code 303 (redirection): - # The response to the request can be found under another URI using - # a separate GET method. This relates to POST, PUT, DELETE and PATCH - # methods. - my $method = $!request.method; - $method = "GET" - if self.code == 303 - && $!request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); - - my %args = $method => $location; - - $new-request = HTTP::Request.new(|%args); +method is-success { is-success($!code).Bool } - unless ~$new-request.field('Host').values { - my $hh = ~$!request.field('Host').values; - $new-request.field(Host => $hh); - $new-request.scheme = $!request.scheme; - $new-request.host = $!request.host; - $new-request.port = $!request.port; - } - } +# please extend as necessary +method has-content(--> Bool:D) { + (204, 304).grep({ $!code eq $_ }) ?? False !! True; +} - $new-request - } +method is-chunked(--> Bool:D) { + self.field('Transfer-Encoding') + && self.field('Transfer-Encoding') eq 'chunked' +} - method Str(:$debug) { - my $s = $.protocol ~ " " ~ $!status-line; - join $CRLF, $s, callwith $CRLF, :$debug; - } +method set-code(Int:D $code) { + $!code = $code; + $!status-line = $code ~ " " ~ get_http_status_msg($code); } -class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { - my constant $CRLF = "\x[0D]\x[0A]"; - - method next-request(--> HTTP::Request:D) { - my HTTP::Request-Strict $new-request; +method next-request(--> HTTP::Request:D) { + my HTTP::Request $new-request; - my $location = ~self.header.field('Location').values; + my $location = ~self.header.field('Location').values; - if $location.defined { - # Special case for the HTTP status code 303 (redirection): - # The response to the request can be found under another URI using - # a separate GET method. This relates to POST, PUT, DELETE and PATCH - # methods. - my $method = $.request.method; - $method = "GET" - if self.code == 303 - && $.request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); + if $location.defined { + # Special case for the HTTP status code 303 (redirection): + # The response to the request can be found under another URI using + # a separate GET method. This relates to POST, PUT, DELETE and PATCH + # methods. + my $method = $!request.method; + $method = "GET" + if self.code == 303 + && $!request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); - my %args = $method => $location; + my %args = $method => $location; - $new-request = HTTP::Request-Strict.new(|%args); + $new-request = HTTP::Request.new(|%args); - unless ~$new-request.field('Host').values { - my $hh = ~$.request.field('Host').values; - $new-request.field(Host => $hh); - $new-request.scheme = $.request.scheme; - $new-request.host = $.request.host; - $new-request.port = $.request.port; - } + unless ~$new-request.field('Host').values { + my $hh = ~$!request.field('Host').values; + $new-request.field(Host => $hh); + $new-request.scheme = $!request.scheme; + $new-request.host = $!request.host; + $new-request.port = $!request.port; } - - $new-request - } - - method Str(:$debug) { - my $s = $.protocol ~ " " ~ $.status-line; - join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug; } + + $new-request } -# sub EXPORT ( $strict? ) { -# if $strict and $strict eq 'strict' { -# OUR::HTTP::Response := HTTP::Response-Strict; -# } else { -# OUR::HTTP::Response := HTTP::Response; -# } -# Map.new; -# } +method Str(:$debug) { + my $s = $.protocol ~ " " ~ $!status-line; + $s ~= $CRLF ~ callwith($CRLF, :debug($debug)); +} # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA-Strict.rakumod new file mode 100644 index 0000000..9bee017 --- /dev/null +++ b/lib/HTTP/UA-Strict.rakumod @@ -0,0 +1,431 @@ +use URI; + +use HTTP::UserAgent; +use HTTP::Message; +use HTTP::Request; +use HTTP::Response; +use HTTP::Header; + +class HTTP::Header-Strict is HTTP::Header { + use HTTP::Header::ETag; + + grammar HTTP::Header-Strict::Grammar { + 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 { + \" \" + } + token opaque-content { + <[\x[21]..\x[FF]]-[\x[22]\x[7F]]>* + } + token vchars { <[\x[21]..\x[7E]]>+ } + token field-vchars { <[\x[21]..\x[FF]]-[\x[7F]]>+ } + token value { + [ <[\t\x[20]]>* ]* + } + token quoted-string { + \" \" + } + token quoted-content { + [ | ]* + } + token qtd-text { + <[\t\x[20]..\x[FF]]-[\x[22]\x[5C]\x[7F]]>+ + } + token quotable-char { + <[\t\x[20]..\x[FF]]-[\x[7F]]> + } + token quoted-pair { + \\ + } + } + + class HTTP::Header-Strict::Actions { + 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; + } + } + + multi method field ( HTTP::Header::ETag:D $etag ) { + @.fields.push: $etag; + } + + method parse($raw) { + my $*OBJ = self; + HTTP::Header-Strict::Grammar.parse: + $raw, + actions => HTTP::Header-Strict::Actions + ; + } +} + +class HTTP::Message-Strict is HTTP::Message { + #| see https://docs.raku.org/language/grammars#Attributes_in_grammars + my constant $CRLF = "\x[0d]\x[0a]"; + my constant $DELIM = $CRLF x 2; + + method new($content?, *%fields) { + my $header = HTTP::Header-Strict.new(|%fields); + + self.bless(:$header, :$content); + } + + method parse ( $raw_message ) { + my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; + my ( $fields, $content ) = $rest.split: $DELIM, 2; + + my ($first, $second, $third) = $start-line.split(/\s+/); + if $third.index('/') { # is a request + $.protocol = $third; + } + else { # is a response + $.protocol = $first; + } + + # $.header = HTTP::Header-Strict.new; + $.header.parse: $fields; + return self unless $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 *, + @lines.map: + -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } + ; + $.content = @lines.join; + return self; + } else { + $.content = $content; + return self; + } + + self + } + + method Str ( :$debug, Bool :$bin ) { + my constant $max_size = 300; + # TODO : reference relevant section of relevant RFC + # TODO : need to consider Str vs Buf length ? + self.field: Content-Length => ( $.content.?encode or $.content ).bytes.Str + if $.content and not self.is-chunked; + my $s = $.header.Str: $CRLF; + + # The :bin will be passed from the H::UA + if not $bin { + # do not append CRLF unless chunked + # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 + # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 + # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 + $s = join $CRLF, $s, $.content if $.content; + } + if $.content and $debug { + if $bin || self.is-binary { + $s ~= $CRLF ~ "=Content size : " ~ $.content.elems ~ " bytes "; + $s ~= "$CRLF ** Not showing binary content ** $CRLF"; + } + else { + $s ~= $CRLF ~ "=Content size: "~$.content.Str.chars~" chars"; + $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; + $s ~= $CRLF ~ $.content.Str.substr(0, $max_size) ~ $CRLF; + } + } + + $s + } + +} + +class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { + my constant $CRLF = "\x[0D]\x[0A]"; + + + sub get-host-value(URI $uri --> Str) { + my Str $host = $uri.host; + + if $host { + if ( $uri.port != $uri.default_port ) { + $host ~= ':' ~ $uri.port; + } + } + $host; + } + + multi method new(Bool :$bin, *%args) { + + if %args { + my ($method, $url, $file, %fields, $uri); + for %args.kv -> $key, $value { + if $key.lc ~~ any() { + $uri = $value.isa(URI) ?? $value !! URI.new($value); + $method = $key.uc; + } + else { + %fields{$key} = $value; + } + } + + my $header = HTTP::Header-Strict.new(|%fields); + self.new($method // 'GET', $uri, $header, :$bin); + } + else { + self.bless: header => HTTP::Header-Strict.new + } + } + + multi method new() { self.bless: header => HTTP::Header-Strict.new } + + multi method new(HTTP::Request::RequestMethod $method, URI $uri, HTTP::Header-Strict $header, 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) + } + + method Str ( :$debug, Bool :$bin ) { + $.file = '/' ~ $.file unless $.file.starts-with: '/'; + my $s = "$.method $.file $.protocol"; + join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug, :$bin; + } + method parse ( $raw_request ) { + my @lines = $raw_request.split($CRLF); + ($.method, $.file) = @lines.shift.split(' '); + + $.url = 'http://'; + + for @lines -> $line { + if $line ~~ m:i/host:/ { + $.url ~= $line.split(/\:\s*/)[1]; + } + } + + $.url ~= $.file; + + self.uri = URI.new($.url); + self.HTTP::Message-Strict::parse: $raw_request; + } +} + +class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { + my constant $CRLF = "\x[0D]\x[0A]"; + + method next-request(--> HTTP::Request:D) { + my HTTP::Request-Strict $new-request; + + my $location = ~self.header.field('Location').values; + + + if $location.defined { + # Special case for the HTTP status code 303 (redirection): + # The response to the request can be found under another URI using + # a separate GET method. This relates to POST, PUT, DELETE and PATCH + # methods. + my $method = $.request.method; + $method = "GET" + if self.code == 303 + && $.request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); + + my %args = $method => $location; + + $new-request = HTTP::Request-Strict.new(|%args); + + unless ~$new-request.field('Host').values { + my $hh = ~$.request.field('Host').values; + $new-request.field(Host => $hh); + $new-request.scheme = $.request.scheme; + $new-request.host = $.request.host; + $new-request.port = $.request.port; + } + } + + $new-request + } + + method Str(:$debug) { + my $s = $.protocol ~ " " ~ $.status-line; + join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug; + } +} + +class HTTP::UserAgent-Strict is HTTP::UserAgent { + constant CRLF = Buf.new(13, 10); + + role Connection { + method send-request(HTTP::Request-Strict $request ) { + $request.field(Connection => 'close') unless $request.field('Connection'); + if $request.binary { + self.print($request.Str(:bin)); + self.write($request.content); + } else { + self.print: $request.Str; + } + } + } + + multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { + basic-auth-token("{$login}:{$passwd}"); + + } + + multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { + "Basic " ~ MIME::Base64.encode-str($creds, :oneline); + } + + multi method get(URI $uri is copy, Bool :$bin, *%header ) { + my $request = HTTP::Request-Strict.new(GET => $uri, |%header); + self.request($request, :$bin) + } + + proto method post(|) {*} + + multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Strict.new(POST => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$bin) + } + + proto method put(|) {*} + + multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request-Strict.new(PUT => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$bin) + } + + proto method delete(|) {*} + + multi method delete(URI $uri is copy, Bool :$bin, *%header ) { + my $request = HTTP::Request-Strict.new(DELETE => $uri, |%header); + self.request($request, :$bin) + } + + method request(HTTP::Request-Strict $request, Bool :$bin --> HTTP::Response-Strict:D) { + my HTTP::Response-Strict $response; + + # add cookies to the request + $request.add-cookies($.cookies); + + # set the useragent + $request.field(User-Agent => $.useragent) if $.useragent.defined; + + # if auth has been provided add it to the request + self.setup-auth($request); + $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; + my Connection $conn = self.get-connection($request); + + if $conn.send-request($request) { + $response = self.get-response($request, $conn, :$bin); + } + $conn.close; + + X::HTTP::Response.new(:rc('No response')).throw unless $response; + + $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; + + # save cookies + $.cookies.extract-cookies($response); + + if $response.code ~~ /^30<[0123]>/ { + $.redirects-in-a-row++; + 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); + } + else { + $.redirects-in-a-row = 0; + } + if $.throw-exceptions { + given $response.code { + when /^4/ { + X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; + } + when /^5/ { + X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; + } + } + } + + $response + } + + multi method get-connection(HTTP::Request-Strict $request --> Connection:D) { + my $host = $request.host; + my $port = $request.port; + + + if self.get-proxy($request) -> $http_proxy { + $request.file = $request.url; + my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; + ($host, $port) = $proxy_host.split(':'); + $port.=Int; + if $proxy_auth.defined { + $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); + } + $request.field(Connection => 'close'); + } + self.get-connection($request, $host, $port) + } + + my $https_lock = Lock.new; + multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection:D) { + my $conn; + if $request.scheme eq 'https' { + $https_lock.lock; + try require ::("IO::Socket::SSL"); + $https_lock.unlock; + die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; + $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) + } + else { + $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); + } + $conn does Connection; + $conn + } +} diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 48c455a..0ca3c15 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -1,7 +1,7 @@ -# use HTTP::Response:auth; -# use HTTP::Request:auth; -use HTTP::Request; +unit class HTTP::UserAgent; + use HTTP::Response; +use HTTP::Request; use HTTP::Cookies; use HTTP::UserAgent::Common; use HTTP::UserAgent::Exception; @@ -12,629 +12,465 @@ use URI; use File::Temp; use MIME::Base64; -class HTTP::UserAgent { - # use HTTP::Response:auth; - # use HTTP::Request:auth; - # use HTTP::Cookies; - # use HTTP::UserAgent::Common; - # use HTTP::UserAgent::Exception; - - use Encode; - use URI; - - use File::Temp; - use MIME::Base64; - - constant CRLF = Buf.new(13, 10); - - # placeholder role to make signatures nicer - # and enable greater abstraction - role Connection { - method send-request(HTTP::Request $request ) { - $request.field(Connection => 'close') unless $request.field('Connection'); - if $request.binary { - self.print($request.Str(:bin)); - self.write($request.content); - } - elsif $request.method.Str eq 'POST' | 'PUT' { - self.print: $request.Str: :strict; - } else { - self.print($request.Str ~ "\r\n"); - } - } - } +constant CRLF = Buf.new(13, 10); - has Int $.timeout is rw = 180; - has $.useragent; - has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( - file => tempfile[0], - autosave => 1, - ); - has $.auth_login; - has $.auth_password; - has Int $.max-redirects is rw; - has $.redirects-in-a-row; - has Bool $.throw-exceptions; - has $.debug; - has IO::Handle $.debug-handle; - - my sub search-header-end(Blob $input) { - my $i = 0; - my $input-bytes = $input.bytes; - while $i+2 <= $input-bytes { - # CRLF - if $i+4 <= $input-bytes && $input[$i] == 0x0d && $input[$i+1]==0x0a && $input[$i+2]==0x0d && $input[$i+3]==0x0a { - return $i+4; - } - # LF - if $input[$i] == 0x0a && $input[$i+1]==0x0a { - return $i+2; - } - $i++; +# placeholder role to make signatures nicer +# and enable greater abstraction +role Connection { + method send-request(HTTP::Request $request ) { + $request.field(Connection => 'close') unless $request.field('Connection'); + if $request.binary { + self.print($request.Str(:bin)); + self.write($request.content); + } + else { + self.print($request.Str ~ "\r\n"); } - Nil } +} - my sub _index_buf(Blob $input, Blob $sub) { - my $end-pos = 0; - while $end-pos < $input.bytes { - if $sub eq $input.subbuf($end-pos, $sub.bytes) { - return $end-pos; - } - $end-pos++; +has Int $.timeout is rw = 180; +has $.useragent; +has HTTP::Cookies $.cookies is rw = HTTP::Cookies.new( + file => tempfile[0], + autosave => 1, +); +has $.auth_login; +has $.auth_password; +has Int $.max-redirects is rw; +has $.redirects-in-a-row; +has Bool $.throw-exceptions; +has $.debug; +has IO::Handle $.debug-handle; + +my sub search-header-end(Blob $input) { + my $i = 0; + my $input-bytes = $input.bytes; + while $i+2 <= $input-bytes { + # CRLF + if $i+4 <= $input-bytes && $input[$i] == 0x0d && $input[$i+1]==0x0a && $input[$i+2]==0x0d && $input[$i+3]==0x0a { + return $i+4; + } + # LF + if $input[$i] == 0x0a && $input[$i+1]==0x0a { + return $i+2; + } + $i++; + } + Nil +} + +my sub _index_buf(Blob $input, Blob $sub) { + my $end-pos = 0; + while $end-pos < $input.bytes { + if $sub eq $input.subbuf($end-pos, $sub.bytes) { + return $end-pos; } - -1 + $end-pos++; } + -1 +} - submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { - $!useragent = get-ua($!useragent) if $!useragent.defined; - if $!debug.defined { - if $!debug ~~ Bool and $!debug == True { - $!debug-handle = $*OUT; - } - if $!debug ~~ Str { - say $!debug; - $!debug-handle = open($!debug, :w); - $!debug = True; - } - if $!debug ~~ IO::Handle { - $!debug-handle = $!debug; - $!debug = True; - } +submethod BUILD(:$!useragent, Bool :$!throw-exceptions, :$!max-redirects = 5, :$!debug, :$!redirects-in-a-row) { + $!useragent = get-ua($!useragent) if $!useragent.defined; + if $!debug.defined { + if $!debug ~~ Bool and $!debug == True { + $!debug-handle = $*OUT; + } + if $!debug ~~ Str { + say $!debug; + $!debug-handle = open($!debug, :w); + $!debug = True; + } + if $!debug ~~ IO::Handle { + $!debug-handle = $!debug; + $!debug = True; } } +} - method auth(Str $login, Str $password) { - $!auth_login = $login; - $!auth_password = $password; - } +method auth(Str $login, Str $password) { + $!auth_login = $login; + $!auth_password = $password; +} - proto method get(|) {*} +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 :$bin, *%header ) { + my $request = HTTP::Request.new(GET => $uri, |%header); + self.request($request, :$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 :$bin, *%header ) { + self.get(URI.new(_clear-url($uri)), :$bin, |%header) +} - proto method post(|) {*} +proto method post(|) {*} - multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(POST => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) - } +multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request.new(POST => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$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 :$bin, *%header ) { + self.post(URI.new(_clear-url($uri)), %form, |%header) +} - proto method put(|) {*} +proto method put(|) {*} - multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request.new(PUT => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) - } +multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { + my $request = HTTP::Request.new(PUT => $uri, |%header); + $request.add-form-data(%form); + self.request($request, :$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 :$bin, *%header ) { + self.put(URI.new(_clear-url($uri)), %form, |%header) +} - proto method delete(|) {*} +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 :$bin, *%header ) { + my $request = HTTP::Request.new(DELETE => $uri, |%header); + self.request($request, :$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 :$bin, *%header ) { + self.delete(URI.new(_clear-url($uri)), :$bin, |%header) +} - method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { - my HTTP::Response $response; +method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { + my HTTP::Response $response; - # add cookies to the request - $request.add-cookies($.cookies); + # add cookies to the request + $request.add-cookies($.cookies); - # set the useragent - $request.field(User-Agent => $.useragent) if $.useragent.defined; + # set the useragent + $request.field(User-Agent => $.useragent) if $.useragent.defined; - # if auth has been provided add it to the request - self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection $conn = self.get-connection($request); + # if auth has been provided add it to the request + self.setup-auth($request); + $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; + my Connection $conn = self.get-connection($request); - if $conn.send-request($request) { - $response = self.get-response($request, $conn, :$bin); - } - $conn.close; + if $conn.send-request($request) { + $response = self.get-response($request, $conn, :$bin); + } + $conn.close; - X::HTTP::Response.new(:rc('No response')).throw unless $response; + X::HTTP::Response.new(:rc('No response')).throw unless $response; - $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; + $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; - # save cookies - $.cookies.extract-cookies($response); + # save cookies + $.cookies.extract-cookies($response); - if $response.code ~~ /^30<[0123]>/ { - $!redirects-in-a-row++; - 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); - } - else { - $!redirects-in-a-row = 0; - } - if $!throw-exceptions { - given $response.code { - when /^4/ { - X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; - } - when /^5/ { - X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; - } - } + if $response.code ~~ /^30<[0123]>/ { + $!redirects-in-a-row++; + if $.max-redirects < $.redirects-in-a-row { + X::HTTP::Response.new(:rc('Max redirects exceeded'), :response($response)).throw; } - - $response + my $new-request = $response.next-request(); + return self.request($new-request); } - - proto method get-content(|) {*} - - # When we have a content-length - multi method get-content(Connection $conn, Blob $content, $content-length --> Blob:D) { - if $content.bytes == $content-length { - $content - } - else { - # Create a Buf with what we have now and append onto - # it until we've read the right amount. - my $buf = Buf.new($content); - my int $total-bytes-read = $content.bytes; - while $content-length > $total-bytes-read { - my $read = $conn.recv($content-length - $total-bytes-read, :bin); - $buf.append($read); - $total-bytes-read += $read.bytes; + else { + $!redirects-in-a-row = 0; + } + if $!throw-exceptions { + given $response.code { + when /^4/ { + X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; + } + when /^5/ { + X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; } - $buf } } - # fallback when not chunked and no content length - multi method get-content(Connection $conn, Blob $content is rw --> Blob:D) { + $response +} + +proto method get-content(|) {*} - while my $new_content = $conn.recv(:bin) { - $content ~= $new_content; +# When we have a content-length +multi method get-content(Connection $conn, Blob $content, $content-length --> Blob:D) { + if $content.bytes == $content-length { + $content + } + else { + # Create a Buf with what we have now and append onto + # it until we've read the right amount. + my $buf = Buf.new($content); + my int $total-bytes-read = $content.bytes; + while $content-length > $total-bytes-read { + my $read = $conn.recv($content-length - $total-bytes-read, :bin); + $buf.append($read); + $total-bytes-read += $read.bytes; } - $content; + $buf } +} - method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { - my Buf $chunk = $content.clone; - $content = Buf.new; - # We carry on as long as we receive something. - PARSE_CHUNK: loop { - my $end_pos = _index_buf($chunk, CRLF); - if $end_pos >= 0 { - my $size = $chunk.subbuf(0, $end_pos).decode; - # remove optional chunk extensions - $size = $size.subst(/';'.*$/, ''); - # www.yahoo.com sends additional spaces(maybe invalid) - $size = $size.subst(/' '*$/, ''); - $chunk = $chunk.subbuf($end_pos+2); - my $chunk-size = :16($size); - if $chunk-size == 0 { - last PARSE_CHUNK; - } - while $chunk-size+2 > $chunk.bytes { - $chunk ~= $conn.recv($chunk-size+2-$chunk.bytes, :bin); - } - $content ~= $chunk.subbuf(0, $chunk-size); - $chunk = $chunk.subbuf($chunk-size+2); - } - else { - # XXX Reading 1 byte is inefficient code. - # - # But IO::Socket#read/IO::Socket#recv reads from socket until - # fill the requested size. - # - # It cause hang-up on socket reading. - my $byte = $conn.recv(1, :bin); - last PARSE_CHUNK unless $byte.elems; - $chunk ~= $byte; - } - }; +# fallback when not chunked and no content length +multi method get-content(Connection $conn, Blob $content is rw --> Blob:D) { - $content + while my $new_content = $conn.recv(:bin) { + $content ~= $new_content; } + $content; +} - method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { - my Blob[uint8] $first-chunk = Blob[uint8].new; - my $msg-body-pos; - - CATCH { - when X::HTTP::NoResponse { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; +method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { + my Buf $chunk = $content.clone; + $content = Buf.new; + # We carry on as long as we receive something. + PARSE_CHUNK: loop { + my $end_pos = _index_buf($chunk, CRLF); + if $end_pos >= 0 { + my $size = $chunk.subbuf(0, $end_pos).decode; + # remove optional chunk extensions + $size = $size.subst(/';'.*$/, ''); + # www.yahoo.com sends additional spaces(maybe invalid) + $size = $size.subst(/' '*$/, ''); + $chunk = $chunk.subbuf($end_pos+2); + my $chunk-size = :16($size); + if $chunk-size == 0 { + last PARSE_CHUNK; } - when /'Connection reset by peer'/ { - X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; + while $chunk-size+2 > $chunk.bytes { + $chunk ~= $conn.recv($chunk-size+2-$chunk.bytes, :bin); } + $content ~= $chunk.subbuf(0, $chunk-size); + $chunk = $chunk.subbuf($chunk-size+2); } + else { + # XXX Reading 1 byte is inefficient code. + # + # But IO::Socket#read/IO::Socket#recv reads from socket until + # fill the requested size. + # + # It cause hang-up on socket reading. + my $byte = $conn.recv(1, :bin); + last PARSE_CHUNK unless $byte.elems; + $chunk ~= $byte; + } + }; + + $content +} - # Header can be longer than one chunk - while my $t = $conn.recv( :bin ) { - $first-chunk ~= $t; - - # Find the header/body separator in the chunk, which means - # we can parse the header seperately and are able to figure - # out the correct encoding of the body. - $msg-body-pos = search-header-end($first-chunk); - last if $msg-body-pos.defined; - } - +method get-response(HTTP::Request $request, Connection $conn, Bool :$bin --> HTTP::Response:D) { + my Blob[uint8] $first-chunk = Blob[uint8].new; + my $msg-body-pos; - # If the header would indicate that there won't - # be any content there may not be a \r\n\r\n at - # the end of the header. - my $header-chunk = do if $msg-body-pos.defined { - $first-chunk.subbuf(0, $msg-body-pos); + CATCH { + when X::HTTP::NoResponse { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; } - else { - # Assume we have the whole header because if the server - # didn't send it we're stuffed anyway - $first-chunk; + when /'Connection reset by peer'/ { + X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; } + } + # Header can be longer than one chunk + while my $t = $conn.recv( :bin ) { + $first-chunk ~= $t; - my HTTP::Response $response = HTTP::Response.new($header-chunk); - $response.request = $request; - - if $response.has-content { - if !$msg-body-pos.defined { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; - } - + # Find the header/body separator in the chunk, which means + # we can parse the header seperately and are able to figure + # out the correct encoding of the body. + $msg-body-pos = search-header-end($first-chunk); + last if $msg-body-pos.defined; + } - my $content = $first-chunk.subbuf($msg-body-pos); - # Turn the inner exceptions to ours - # This may really want to be outside - CATCH { - when X::HTTP::ContentLength { - X::HTTP::Header.new( :rc($_.message), :response($response) ).throw - } - } - # We also need to handle 'Transfer-Encoding: chunked', which means - # that we request more chunks and assemble the response body. - if $response.is-chunked { - $content = self.get-chunked-content($conn, $content); - } - elsif $response.content-length -> $content-length is copy { - $content = self.get-content($conn, $content, $content-length); - } - else { - $content = self.get-content($conn, $content); - } - $response.content = $content andthen $response.content = $response.decoded-content(:$bin); - } - $response + # If the header would indicate that there won't + # be any content there may not be a \r\n\r\n at + # the end of the header. + my $header-chunk = do if $msg-body-pos.defined { + $first-chunk.subbuf(0, $msg-body-pos); + } + else { + # Assume we have the whole header because if the server + # didn't send it we're stuffed anyway + $first-chunk; } - proto method get-connection(|) {*} + my HTTP::Response $response = HTTP::Response.new($header-chunk); + $response.request = $request; - multi method get-connection(HTTP::Request $request --> Connection:D) { - my $host = $request.host; - my $port = $request.port; + if $response.has-content { + if !$msg-body-pos.defined { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; + } - if self.get-proxy($request) -> $http_proxy { - $request.file = $request.url; - my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; - ($host, $port) = $proxy_host.split(':'); - $port.=Int; - if $proxy_auth.defined { - $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); + my $content = $first-chunk.subbuf($msg-body-pos); + # Turn the inner exceptions to ours + # This may really want to be outside + CATCH { + when X::HTTP::ContentLength { + X::HTTP::Header.new( :rc($_.message), :response($response) ).throw } - $request.field(Connection => 'close'); - } - self.get-connection($request, $host, $port) - } - - my $https_lock = Lock.new; - multi method get-connection(HTTP::Request $request, Str $host, Int $port? --> Connection:D) { - my $conn; - if $request.scheme eq 'https' { - $https_lock.lock; - try require ::("IO::Socket::SSL"); - $https_lock.unlock; - die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; - $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) } - else { - $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); + # We also need to handle 'Transfer-Encoding: chunked', which means + # that we request more chunks and assemble the response body. + if $response.is-chunked { + $content = self.get-chunked-content($conn, $content); } - $conn does Connection; - $conn - } - - # heuristic to determine whether we are running in the CGI - # please adjust as required - method is-cgi() returns Bool { - %*ENV:exists or %*ENV:exists; - } - - has $.http-proxy; - # want the request to possibly match scheme, no_proxy etc - method get-proxy(HTTP::Request $request) { - $!http-proxy //= do if self.is-cgi { - %*ENV || %*ENV; + elsif $response.content-length -> $content-length is copy { + $content = self.get-content($conn, $content, $content-length); } else { - %*ENV || %*ENV; + $content = self.get-content($conn, $content); } - if self.use-proxy( $request ) { - $!http-proxy; - } - } - - has @.no-proxy; - has Bool $!no-proxy-check = False; - - method no-proxy() { - if @!no-proxy.elems == 0 { - if not $!no-proxy-check { - if (%*ENV || %*ENV ) -> $no-proxy { - @!no-proxy = $no-proxy.split: /\s*\,\s*/; - } - $!no-proxy-check = True; - } - } - @!no-proxy; - } - - proto method use-proxy(|) {*} - - multi method use-proxy(HTTP::Request $request --> Bool:D) { - self.use-proxy($request.host) + $response.content = $content andthen $response.content = $response.decoded-content(:$bin); } + $response +} - multi method use-proxy(Str $host) returns Bool { - my $rc = True; - for self.no-proxy -> $no-proxy { - if $host ~~ /$no-proxy/ { - $rc = False; - last; - } - } - $rc - } +proto method get-connection(|) {*} - multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { - basic-auth-token("{$login}:{$passwd}"); +multi method get-connection(HTTP::Request $request --> Connection:D) { + my $host = $request.host; + my $port = $request.port; - } - multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { - "Basic " ~ MIME::Base64.encode-str($creds, :oneline); - } - - method setup-auth(HTTP::Request $request) { - # use HTTP Auth - if self.use-auth($request) { - $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); + if self.get-proxy($request) -> $http_proxy { + $request.file = $request.url; + my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; + ($host, $port) = $proxy_host.split(':'); + $port.=Int; + if $proxy_auth.defined { + $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); } + $request.field(Connection => 'close'); } + self.get-connection($request, $host, $port) +} - method use-auth(HTTP::Request $request) { - $!auth_login.defined && $!auth_password.defined; - } +my $https_lock = Lock.new; +multi method get-connection(HTTP::Request $request, Str $host, Int $port? --> Connection:D) { + my $conn; + if $request.scheme eq 'https' { + $https_lock.lock; + try require ::("IO::Socket::SSL"); + $https_lock.unlock; + die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; + $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) + } + else { + $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); + } + $conn does Connection; + $conn +} - # :simple - our sub get($target where URI|Str) is export(:simple) { - my $ua = HTTP::UserAgent.new(:throw-exceptions); - my $response = $ua.get($target); +# heuristic to determine whether we are running in the CGI +# please adjust as required +method is-cgi() returns Bool { + %*ENV:exists or %*ENV:exists; +} - $response.decoded-content +has $.http-proxy; +# want the request to possibly match scheme, no_proxy etc +method get-proxy(HTTP::Request $request) { + $!http-proxy //= do if self.is-cgi { + %*ENV || %*ENV; } - - our sub head(Str $url) is export(:simple) { - my $ua = HTTP::UserAgent.new(:throw-exceptions); - $ua.get($url).header.hash + else { + %*ENV || %*ENV; } - - our sub getprint(Str $url) is export(:simple) { - my $response = HTTP::UserAgent.new(:throw-exceptions).get($url); - print $response.decoded-content; - $response.code + if self.use-proxy( $request ) { + $!http-proxy; } +} - our sub getstore(Str $url, Str $file) is export(:simple) { - $file.IO.spurt: get($url) - } +has @.no-proxy; - sub _clear-url(Str $url is copy) { - $url.starts-with('http://' | 'https://') - ?? $url - !! "http://$url" - } -} +has Bool $!no-proxy-check = False; -class HTTP::UserAgent-Strict is HTTP::UserAgent { - constant CRLF = Buf.new(13, 10); - - role Connection { - method send-request(HTTP::Request-Strict $request ) { - $request.field(Connection => 'close') unless $request.field('Connection'); - if $request.binary { - self.print($request.Str(:bin)); - self.write($request.content); - } else { - self.print: $request.Str; +method no-proxy() { + if @!no-proxy.elems == 0 { + if not $!no-proxy-check { + if (%*ENV || %*ENV ) -> $no-proxy { + @!no-proxy = $no-proxy.split: /\s*\,\s*/; } + $!no-proxy-check = True; } } - - multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { - basic-auth-token("{$login}:{$passwd}"); + @!no-proxy; +} - } +proto method use-proxy(|) {*} - multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { - "Basic " ~ MIME::Base64.encode-str($creds, :oneline); - } - - multi method get(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Strict.new(GET => $uri, |%header); - self.request($request, :$bin) - } +multi method use-proxy(HTTP::Request $request --> Bool:D) { + self.use-proxy($request.host) +} - proto method post(|) {*} +multi method use-proxy(Str $host) returns Bool { + my $rc = True; - multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Strict.new(POST => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) + for self.no-proxy -> $no-proxy { + if $host ~~ /$no-proxy/ { + $rc = False; + last; + } } + $rc +} - proto method put(|) {*} +multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { + basic-auth-token("{$login}:{$passwd}"); - multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Strict.new(PUT => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) - } +} - proto method delete(|) {*} +multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { + "Basic " ~ MIME::Base64.encode-str($creds, :oneline); +} - multi method delete(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Strict.new(DELETE => $uri, |%header); - self.request($request, :$bin) +method setup-auth(HTTP::Request $request) { + # use HTTP Auth + if self.use-auth($request) { + $request.field(Authorization => basic-auth-token($!auth_login,$!auth_password)); } +} - method request(HTTP::Request-Strict $request, Bool :$bin --> HTTP::Response-Strict:D) { - my HTTP::Response-Strict $response; - - # add cookies to the request - $request.add-cookies($.cookies); - - # set the useragent - $request.field(User-Agent => $.useragent) if $.useragent.defined; - - # if auth has been provided add it to the request - self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection $conn = self.get-connection($request); - - if $conn.send-request($request) { - $response = self.get-response($request, $conn, :$bin); - } - $conn.close; - - X::HTTP::Response.new(:rc('No response')).throw unless $response; +method use-auth(HTTP::Request $request) { + $!auth_login.defined && $!auth_password.defined; +} - $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; +# :simple +our sub get($target where URI|Str) is export(:simple) { + my $ua = HTTP::UserAgent.new(:throw-exceptions); + my $response = $ua.get($target); - # save cookies - $.cookies.extract-cookies($response); + $response.decoded-content +} - if $response.code ~~ /^30<[0123]>/ { - $.redirects-in-a-row++; - 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); - } - else { - $.redirects-in-a-row = 0; - } - if $.throw-exceptions { - given $response.code { - when /^4/ { - X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; - } - when /^5/ { - X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; - } - } - } +our sub head(Str $url) is export(:simple) { + my $ua = HTTP::UserAgent.new(:throw-exceptions); + $ua.get($url).header.hash +} - $response - } - - multi method get-connection(HTTP::Request-Strict $request --> Connection:D) { - my $host = $request.host; - my $port = $request.port; - - - if self.get-proxy($request) -> $http_proxy { - $request.file = $request.url; - my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; - ($host, $port) = $proxy_host.split(':'); - $port.=Int; - if $proxy_auth.defined { - $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); - } - $request.field(Connection => 'close'); - } - self.get-connection($request, $host, $port) - } +our sub getprint(Str $url) is export(:simple) { + my $response = HTTP::UserAgent.new(:throw-exceptions).get($url); + print $response.decoded-content; + $response.code +} - my $https_lock = Lock.new; - multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection:D) { - my $conn; - if $request.scheme eq 'https' { - $https_lock.lock; - try require ::("IO::Socket::SSL"); - $https_lock.unlock; - die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; - $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) - } - else { - $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); - } - $conn does Connection; - $conn - } +our sub getstore(Str $url, Str $file) is export(:simple) { + $file.IO.spurt: get($url) } -# sub EXPORT ( $strict? ) { -# if $strict and $strict eq 'strict' { -# OUR::HTTP::UserAgent := HTTP::UserAgent; -# } else { -# OUR::HTTP::UserAgent := HTTP::UserAgent; -# } -# Map.new; -# } +sub _clear-url(Str $url is copy) { + $url.starts-with('http://' | 'https://') + ?? $url + !! "http://$url" +} # vim: expandtab shiftwidth=4 diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index 6397747..0f9e2c8 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -1,15 +1,6 @@ use Test; -# use HTTP::Message 'strict'; -# use HTTP::Request 'strict'; -# use HTTP::Response 'strict'; - -use HTTP::UA 'strict'; -use HTTP::UserAgent; -use HTTP::Message; -use HTTP::Request; -use HTTP::Response; -use HTTP::Header; -# use HTTP::Request; + +use HTTP::UA-Strict; plan 23; diff --git a/t/040-request.rakutest b/t/040-request.rakutest index b162a39..a945c72 100644 --- a/t/040-request.rakutest +++ b/t/040-request.rakutest @@ -45,7 +45,7 @@ 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 RequestMethod but got Str'/, "rejects wrong 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'; diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index 341c16f..10a3841 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -1,6 +1,7 @@ use Test; + use URI; -use HTTP::Request; +use HTTP::UA-Strict; plan 1; diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest index 381e6c0..7a1afbd 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -1,5 +1,6 @@ use Test; -use HTTP::Response; + +use HTTP::UA-Strict; plan 1; From 842cf811e27e2a914f679e876d0f3fde4f9ff146 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sun, 25 Jan 2026 06:54:59 -0800 Subject: [PATCH 06/28] make sure strict classes pass original tests --- t/011-headers-strict.rakutest | 96 ++++++++++++++++++++++++ t/042-request-issue-226.rakutest | 117 +++++++++++++++++++++++++++++- t/051-response-issue-226.rakutest | 85 +++++++++++++++++++++- 3 files changed, 293 insertions(+), 5 deletions(-) create mode 100644 t/011-headers-strict.rakutest diff --git a/t/011-headers-strict.rakutest b/t/011-headers-strict.rakutest new file mode 100644 index 0000000..2eeab5e --- /dev/null +++ b/t/011-headers-strict.rakutest @@ -0,0 +1,96 @@ +use Test; +use HTTP::UA-Strict; + +plan 24; + +my constant $CRLF = "\x[0D]\x[0A]"; + +# new +my $h = HTTP::Header-Strict.new(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, "a: a, a2, a3\nb: B\n", 'Str 1/2'; +is-deeply $h.Str('|'), 'a: a, a2, a3|b: B|', '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-Strict.new(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-Strict.new(); + +lives-ok { $h.parse('ETag: W/"1201-51b0ce7ad3900"') }, "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') }, "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') }, "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-Strict.new; + $h.parse($htest); + 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/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index 10a3841..70c7389 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -3,9 +3,122 @@ use Test; use URI; use HTTP::UA-Strict; -plan 1; +plan 29; -my constant $CRLF = "\r\n"; +my constant $CRLF = "\x[0D]\x[0A]"; + +############################################################################### + +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-Strict.new(POST => $url, test_field => 'this_is_field'); + +is $r1.method, 'post'.uc, 'new 1/8'; +is $r1.url, $url, 'new 2/8'; +is $r1.file, $file, 'new 3/8'; +is $r1.field('Host'), $host, 'new 4/8'; +is $r1.field('test_field'), 'this_is_field', 'new 5/8'; +ok $r1.Str ~~ /^POST\s$file/, 'new 6/8'; +isa-ok $r1, HTTP::Request-Strict, 'new 7/8'; +isa-ok $r1, HTTP::Message-Strict, 'new 8/8'; + +# 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-Strict.new.parse($req); + +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, $exp, 'parse 6/6'; + +subtest { + my $r; + lives-ok { $r = HTTP::Request-Strict.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new(Foo => 'bar') ) }, "mew 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-Strict.new(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-Strict.new(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-Strict.new(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-Strict.new(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-Strict.new(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, /"multipart\/form-data"/, "and got multipart data"; + }, 'multipart explicit'; + subtest { + my $req = HTTP::Request-Strict.new(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, /"multipart\/form-data"/, "and got multipart data"; + }, 'multipart explicit with slurpy hash (check no gobble adverb)'; +}, 'add-form-data'; + +############################################################################### my Str:D $host = 'dne.site'; my Str:D $resource = 'resource'; diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest index 7a1afbd..abbfc05 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -2,13 +2,92 @@ use Test; use HTTP::UA-Strict; -plan 1; +plan 29; -my constant $CRLF = "\r\n"; +my constant $CRLF = "\x[0D]\x[0A]"; + +############################################################################### + +# new +my $r = HTTP::Response-Strict.new(200, a => 'a'); + +isa-ok $r, HTTP::Response-Strict, 'new 1/3'; +isa-ok $r, HTTP::Message-Strict, 'new 2/3'; +is $r.field('a'), 'a', 'new 3/3'; + +# 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-Strict.new.parse($res); +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-Strict.new(204); +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, 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, 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, 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, 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, 10, 65, 99, 99, 101, 112, 116, 45, 82, 97, 110, 103, 101, 115, 58, 32, 98, 121, 116, 101, 115, 10, 67, 111, 110, 116, 101, 110, 116, 45, 76, 101, 110, 103, 116, 104, 58, 32, 52, 54, 48, 57, 10, 67, 111, 110, 110, 101, 99, 116, 105, 111, 110, 58, 32, 99, 108, 111, 115, 101, 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, 10, 10, 10); + +lives-ok { $r = HTTP::Response-Strict.new($buf) }, "create Response-Strict 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-Strict.new(200, Content-Length => "hsh") }, "create a response with a Content-Length"; +throws-like { $r.content-length }, X::HTTP::ContentLength; +lives-ok { $r = HTTP::Response-Strict.new(200, 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) }, 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-Strict.new($garbage); + }, "create with garbage"; + is $r.code, 500, "and got a 500 response"; + +}, "failure modes"; + +subtest { + my $res = HTTP::Response-Strict.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode; + 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; +# my $r = HTTP::Response-Strict.new; # my Str:D $expected = join $CRLF, # 'HTTP/1.1 200 OK', # status line # 'Content-Type: text/plain', # header From 014bfd01ff769c0490239f044d9c30371462d9fb Mon Sep 17 00:00:00 2001 From: Zachary J Hyun Marlow Date: Sun, 25 Jan 2026 09:48:44 -0800 Subject: [PATCH 07/28] fix variable redeclaration --- t/042-request-issue-226.rakutest | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index 70c7389..db52cd5 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -120,9 +120,9 @@ subtest { ############################################################################### -my Str:D $host = 'dne.site'; +$host = 'dne.site'; my Str:D $resource = 'resource'; -my $url = "http://$host/$resource"; +$url = "http://$host/$resource"; my Str:D $expected = join $CRLF, "POST /$resource HTTP/1.1", # request line From 4a289b6ba13fa8da40c3efaadb6bd1a77de92754 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 06:57:14 -0800 Subject: [PATCH 08/28] fix body-less Message.Str --- lib/HTTP/UA-Strict.rakumod | 87 +++++++++++++++++++++++++++++--- lib/HTTP/UserAgent.rakumod | 4 +- t/021-message-issue-226.rakutest | 2 +- 3 files changed, 83 insertions(+), 10 deletions(-) diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA-Strict.rakumod index 9bee017..7444c61 100644 --- a/lib/HTTP/UA-Strict.rakumod +++ b/lib/HTTP/UA-Strict.rakumod @@ -159,7 +159,8 @@ class HTTP::Message-Strict is HTTP::Message { # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 - $s = join $CRLF, $s, $.content if $.content; + # not supporting chunked Str atm + $s = join $CRLF, $s, $.content || ''; } if $.content and $debug { if $bin || self.is-binary { @@ -294,7 +295,7 @@ class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { class HTTP::UserAgent-Strict is HTTP::UserAgent { constant CRLF = Buf.new(13, 10); - role Connection { + role Connection-Strict does HTTP::UserAgent::Connection { method send-request(HTTP::Request-Strict $request ) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { @@ -355,7 +356,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { # if auth has been provided add it to the request self.setup-auth($request); $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection $conn = self.get-connection($request); + my Connection-Strict $conn = self.get-connection($request); if $conn.send-request($request) { $response = self.get-response($request, $conn, :$bin); @@ -394,7 +395,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { $response } - multi method get-connection(HTTP::Request-Strict $request --> Connection:D) { + multi method get-connection(HTTP::Request-Strict $request --> Connection-Strict:D) { my $host = $request.host; my $port = $request.port; @@ -407,13 +408,13 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { if $proxy_auth.defined { $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); } - $request.field(Connection => 'close'); + $request.field(Connection-Strict => 'close'); } self.get-connection($request, $host, $port) } my $https_lock = Lock.new; - multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection:D) { + multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection-Strict:D) { my $conn; if $request.scheme eq 'https' { $https_lock.lock; @@ -425,7 +426,79 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { else { $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); } - $conn does Connection; + $conn does Connection-Strict; $conn } + + method get-response(HTTP::Request-Strict $request, Connection-Strict $conn, Bool :$bin --> HTTP::Response-Strict:D) { + my Blob[uint8] $first-chunk = Blob[uint8].new; + my $msg-body-pos; + + CATCH { + when X::HTTP::NoResponse { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; + } + when /'Connection reset by peer'/ { + X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; + } + } + + # Header can be longer than one chunk + while my $t = $conn.recv( :bin ) { + $first-chunk ~= $t; + + # Find the header/body separator in the chunk, which means + # we can parse the header seperately and are able to figure + # out the correct encoding of the body. + $msg-body-pos = HTTP::UserAgent::search-header-end($first-chunk); + last if $msg-body-pos.defined; + } + + + # If the header would indicate that there won't + # be any content there may not be a \r\n\r\n at + # the end of the header. + my $header-chunk = do if $msg-body-pos.defined { + $first-chunk.subbuf(0, $msg-body-pos); + } + else { + # Assume we have the whole header because if the server + # didn't send it we're stuffed anyway + $first-chunk; + } + + + my HTTP::Response-Strict $response = HTTP::Response-Strict.new($header-chunk); + $response.request = $request; + + if $response.has-content { + if !$msg-body-pos.defined { + X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; + } + + + my $content = $first-chunk.subbuf($msg-body-pos); + # Turn the inner exceptions to ours + # This may really want to be outside + CATCH { + when X::HTTP::ContentLength { + X::HTTP::Header.new( :rc($_.message), :response($response) ).throw + } + } + # We also need to handle 'Transfer-Encoding: chunked', which means + # that we request more chunks and assemble the response body. + if $response.is-chunked { + $content = self.get-chunked-content($conn, $content); + } + elsif $response.content-length -> $content-length is copy { + $content = self.get-content($conn, $content, $content-length); + } + else { + $content = self.get-content($conn, $content); + } + + $response.content = $content andthen $response.content = $response.decoded-content(:$bin); + } + $response + } } diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 0ca3c15..ee7d5d0 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -16,7 +16,7 @@ constant CRLF = Buf.new(13, 10); # placeholder role to make signatures nicer # and enable greater abstraction -role Connection { +our role Connection { method send-request(HTTP::Request $request ) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { @@ -43,7 +43,7 @@ has Bool $.throw-exceptions; has $.debug; has IO::Handle $.debug-handle; -my sub search-header-end(Blob $input) { +our sub search-header-end(Blob $input) { my $i = 0; my $input-bytes = $input.bytes; while $i+2 <= $input-bytes { diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index 0f9e2c8..b176291 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -56,7 +56,7 @@ is $m.Str, "a: b, c, d\r\nContent-Length: 6\r\n\r\nline\r\n", 'Str'; # clear $m.clear; -is $m.Str, '', 'clear 1/2'; +is $m.Str, "\r\n", 'clear 1/2 - body-less messages require final CRLF'; is $m.content, '', 'clear 2/2'; ## parse a more complex example From 37f292f2742d347f5dde822295f271cf943744d8 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 07:18:09 -0800 Subject: [PATCH 09/28] was test issue --- lib/HTTP/UA-Strict.rakumod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA-Strict.rakumod index 7444c61..a2c9542 100644 --- a/lib/HTTP/UA-Strict.rakumod +++ b/lib/HTTP/UA-Strict.rakumod @@ -160,7 +160,7 @@ class HTTP::Message-Strict is HTTP::Message { # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 # not supporting chunked Str atm - $s = join $CRLF, $s, $.content || ''; + $s = join $CRLF, $s, $.content; } if $.content and $debug { if $bin || self.is-binary { From 5e802adf773d9b70023f3b1d923d839d4f005690 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 08:22:03 -0800 Subject: [PATCH 10/28] auth --- lib/HTTP/Response.rakumod | 2 +- lib/HTTP/UA-Strict.rakumod | 4 ++-- lib/HTTP/UserAgent.rakumod | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index 74dc2a9..100ff5b 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -1,6 +1,6 @@ use HTTP::Message; use HTTP::Status; -use HTTP::Request; +use HTTP::Request:auth; use HTTP::UserAgent::Exception; unit class HTTP::Response is HTTP::Message; diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA-Strict.rakumod index a2c9542..9a87e18 100644 --- a/lib/HTTP/UA-Strict.rakumod +++ b/lib/HTTP/UA-Strict.rakumod @@ -2,8 +2,8 @@ use URI; use HTTP::UserAgent; use HTTP::Message; -use HTTP::Request; -use HTTP::Response; +use HTTP::Request:auth; +use HTTP::Response:auth; use HTTP::Header; class HTTP::Header-Strict is HTTP::Header { diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index ee7d5d0..8d3bd9f 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -1,7 +1,7 @@ unit class HTTP::UserAgent; -use HTTP::Response; -use HTTP::Request; +use HTTP::Response:auth; +use HTTP::Request:auth; use HTTP::Cookies; use HTTP::UserAgent::Common; use HTTP::UserAgent::Exception; From bfc08bce7b9fc3aa51f70fda1d9701a0bf3444e6 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 08:38:23 -0800 Subject: [PATCH 11/28] reinstate auth; add Str as URL convenience methods to UA-Strict --- lib/HTTP/UA-Strict.rakumod | 18 +++++- lib/HTTP/UserAgent.rakumod | 2 +- t/081-ua-strict.rakutest | 111 +++++++++++++++++++++++++++++++++++++ 3 files changed, 129 insertions(+), 2 deletions(-) create mode 100644 t/081-ua-strict.rakutest diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA-Strict.rakumod index 9a87e18..8eb3449 100644 --- a/lib/HTTP/UA-Strict.rakumod +++ b/lib/HTTP/UA-Strict.rakumod @@ -160,7 +160,7 @@ class HTTP::Message-Strict is HTTP::Message { # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 # not supporting chunked Str atm - $s = join $CRLF, $s, $.content; + $s = join $CRLF, $s, $.content || ''; } if $.content and $debug { if $bin || self.is-binary { @@ -321,6 +321,10 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { self.request($request, :$bin) } + multi method get(Str $uri is copy, Bool :$bin, *%header ) { + self.get(URI.new(HTTP::UserAgent::_clear-url($uri)), :$bin, |%header) + } + proto method post(|) {*} multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { @@ -329,6 +333,10 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { self.request($request, :$bin) } + multi method post(Str $uri is copy, %form, Bool :$bin, *%header ) { + self.post(URI.new(HTTP::UserAgent::_clear-url($uri)), %form, |%header) + } + proto method put(|) {*} multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { @@ -337,6 +345,10 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { self.request($request, :$bin) } + multi method put(Str $uri is copy, %form, Bool :$bin, *%header ) { + self.put(URI.new(HTTP::UserAgent::_clear-url($uri)), %form, |%header) + } + proto method delete(|) {*} multi method delete(URI $uri is copy, Bool :$bin, *%header ) { @@ -344,6 +356,10 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { self.request($request, :$bin) } + multi method delete(Str $uri is copy, Bool :$bin, *%header ) { + self.delete(URI.new(HTTP::UserAgent::_clear-url($uri)), :$bin, |%header) + } + method request(HTTP::Request-Strict $request, Bool :$bin --> HTTP::Response-Strict:D) { my HTTP::Response-Strict $response; diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 8d3bd9f..d621084 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -467,7 +467,7 @@ our sub getstore(Str $url, Str $file) is export(:simple) { $file.IO.spurt: get($url) } -sub _clear-url(Str $url is copy) { +our sub _clear-url(Str $url is copy) { $url.starts-with('http://' | 'https://') ?? $url !! "http://$url" diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest new file mode 100644 index 0000000..a7044db --- /dev/null +++ b/t/081-ua-strict.rakutest @@ -0,0 +1,111 @@ +use HTTP::UA-Strict; +use HTTP::UserAgent::Common; +use Test; + +use URI; + +plan 11; + +# new +my $ua = HTTP::UserAgent-Strict.new; +nok $ua.useragent, 'new 1/3'; + +$ua = HTTP::UserAgent-Strict.new(:useragent('test')); +is $ua.useragent, 'test', 'new 2/3'; + +my $newua = get-ua('chrome_linux'); +$ua = HTTP::UserAgent-Strict.new(:useragent('chrome_linux')); +is $ua.useragent, $newua, 'new 3/3'; + +if %*ENV { +# user agent + like $ua.get('http://httpbin.org/user-agent').content, /$newua/, 'useragent 1/1'; + +# get + todo "possibly flaky host", 4; + lives-ok { + my $response = $ua.get('github.com/'); + ok $response, 'get 1/3'; + isa-ok $response, HTTP::Response-Strict, 'get 2/3'; + ok $response.is-success, 'get 3/3'; + }, "get from 'github.com/'"; + +# non-ascii encodings (github issue #35) + lives-ok { HTTP::UserAgent-Strict.new.get('http://www.baidu.com') }, 'Lived through gb2312 encoding'; + +# chunked encoding. + + skip 'Site changed. Need new site to cover this problem See #208'; +# lives-ok { HTTP::UserAgent-Strict.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-Strict.new; + my $res; + lives-ok { $res = $ua.post(URI.new($uri), %data, 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-Strict.new; + my $res; + lives-ok { $res = $ua.post(URI.new($uri), %data, 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-Strict.new; + my $res; + lives-ok { $res = $ua.post($uri, %data, 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 From 01ce9fa22764587feffc3e62dc6f15cf6c037d3d Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 08:50:56 -0800 Subject: [PATCH 12/28] auth --- lib/HTTP/Cookies.rakumod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/HTTP/Cookies.rakumod b/lib/HTTP/Cookies.rakumod index 808a52d..1e2d03c 100644 --- a/lib/HTTP/Cookies.rakumod +++ b/lib/HTTP/Cookies.rakumod @@ -2,7 +2,7 @@ unit class HTTP::Cookies; use HTTP::Cookie; use HTTP::Response; -use HTTP::Request; +use HTTP::Request:auth; use DateTime::Parse; has @.cookies; From 85bb7c840d6e8eb196806f1208cb8b444440cd4a Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 10:27:47 -0800 Subject: [PATCH 13/28] update provides --- META6.json | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/META6.json b/META6.json index 9cf97c5..6ccf6d9 100644 --- a/META6.json +++ b/META6.json @@ -30,7 +30,12 @@ "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::UserAgent-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::Message-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::Request-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::Response-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::Header-Strict": "lib/HTTP/UA-Strict.rakumod" }, "raku": "6.*", "resources": [ From f94507ca3eb04caef3e4dd7431069a909f2d7fe0 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 10:28:14 -0800 Subject: [PATCH 14/28] update provides --- META6.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/META6.json b/META6.json index 6ccf6d9..3f6bfd5 100644 --- a/META6.json +++ b/META6.json @@ -35,7 +35,8 @@ "HTTP::Message-Strict": "lib/HTTP/UA-Strict.rakumod", "HTTP::Request-Strict": "lib/HTTP/UA-Strict.rakumod", "HTTP::Response-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::Header-Strict": "lib/HTTP/UA-Strict.rakumod" + "HTTP::Header-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::Header::ETag": "lib/HTTP/Header/ETag.rakumod" }, "raku": "6.*", "resources": [ From 5e565d257c043a37af3e1d251e33446462097a57 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 10:41:32 -0800 Subject: [PATCH 15/28] fix return --- lib/HTTP/Response.rakumod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/HTTP/Response.rakumod b/lib/HTTP/Response.rakumod index 100ff5b..7dcd253 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -35,7 +35,7 @@ multi method new(Int:D $code = 200, *%fields) { self.bless(:$code, :$header); } -method content-length(--> Int:D) { +method content-length(--> Int) { my $content-length = self.field('Content-Length').values[0]; with $content-length -> $c { From e7fbc7b1422c17bf9666e3616d1e437adb502184 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 10:46:32 -0800 Subject: [PATCH 16/28] fix return --- lib/HTTP/Request.rakumod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index 42c73c0..a5af450 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -90,7 +90,7 @@ multi method host(--> Str:D) is rw { proto method port(|) {*} -multi method port(--> Int:D) is rw { +multi method port(--> Int) is rw { if not $!port.defined { # if there isn't a scheme the no default port if try self.uri.scheme { From 4120d594813b249796b86d161aa83e5bcf633ea5 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 26 Jan 2026 11:04:06 -0800 Subject: [PATCH 17/28] add UA-Strict itself to provides --- META6.json | 1 + 1 file changed, 1 insertion(+) diff --git a/META6.json b/META6.json index 3f6bfd5..04afb23 100644 --- a/META6.json +++ b/META6.json @@ -32,6 +32,7 @@ "HTTP::UserAgent::Common": "lib/HTTP/UserAgent/Common.rakumod", "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod", "HTTP::UserAgent-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::UA-Strict": "lib/HTTP/UA-Strict.rakumod", "HTTP::Message-Strict": "lib/HTTP/UA-Strict.rakumod", "HTTP::Request-Strict": "lib/HTTP/UA-Strict.rakumod", "HTTP::Response-Strict": "lib/HTTP/UA-Strict.rakumod", From ae92947e8b710d310d2536fb332db2ebc37327c0 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Tue, 3 Feb 2026 01:13:48 -0800 Subject: [PATCH 18/28] -Strict to ::Strict --- META6.json | 12 ++-- .../{UA-Strict.rakumod => UA/Strict.rakumod} | 70 +++++++++---------- t/011-headers-strict.rakutest | 10 +-- t/021-message-issue-226.rakutest | 28 ++++---- t/042-request-issue-226.rakutest | 28 ++++---- t/051-response-issue-226.rakutest | 26 +++---- t/081-ua-strict.rakutest | 20 +++--- 7 files changed, 97 insertions(+), 97 deletions(-) rename lib/HTTP/{UA-Strict.rakumod => UA/Strict.rakumod} (86%) diff --git a/META6.json b/META6.json index 04afb23..f88eef6 100644 --- a/META6.json +++ b/META6.json @@ -31,12 +31,12 @@ "HTTP::UserAgent": "lib/HTTP/UserAgent.rakumod", "HTTP::UserAgent::Common": "lib/HTTP/UserAgent/Common.rakumod", "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod", - "HTTP::UserAgent-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::UA-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::Message-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::Request-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::Response-Strict": "lib/HTTP/UA-Strict.rakumod", - "HTTP::Header-Strict": "lib/HTTP/UA-Strict.rakumod", + "HTTP::UserAgent::Strict": "lib/HTTP/UA/Strict.rakumod", + "HTTP::UA::Strict": "lib/HTTP/UA/Strict.rakumod", + "HTTP::Message::Strict": "lib/HTTP/UA/Strict.rakumod", + "HTTP::Request::Strict": "lib/HTTP/UA/Strict.rakumod", + "HTTP::Response::Strict": "lib/HTTP/UA/Strict.rakumod", + "HTTP::Header::Strict": "lib/HTTP/UA/Strict.rakumod", "HTTP::Header::ETag": "lib/HTTP/Header/ETag.rakumod" }, "raku": "6.*", diff --git a/lib/HTTP/UA-Strict.rakumod b/lib/HTTP/UA/Strict.rakumod similarity index 86% rename from lib/HTTP/UA-Strict.rakumod rename to lib/HTTP/UA/Strict.rakumod index 8eb3449..d89e7aa 100644 --- a/lib/HTTP/UA-Strict.rakumod +++ b/lib/HTTP/UA/Strict.rakumod @@ -6,10 +6,10 @@ use HTTP::Request:auth; use HTTP::Response:auth; use HTTP::Header; -class HTTP::Header-Strict is HTTP::Header { +class HTTP::Header::Strict is HTTP::Header { use HTTP::Header::ETag; - grammar HTTP::Header-Strict::Grammar { + grammar HTTP::Header::Strict::Grammar { token TOP { } @@ -59,7 +59,7 @@ class HTTP::Header-Strict is HTTP::Header { } } - class HTTP::Header-Strict::Actions { + class HTTP::Header::Strict::Actions { method etag ( $/ ) { $*OBJ.field: HTTP::Header::ETag.new: @@ -91,20 +91,20 @@ class HTTP::Header-Strict is HTTP::Header { method parse($raw) { my $*OBJ = self; - HTTP::Header-Strict::Grammar.parse: + HTTP::Header::Strict::Grammar.parse: $raw, - actions => HTTP::Header-Strict::Actions + actions => HTTP::Header::Strict::Actions ; } } -class HTTP::Message-Strict is HTTP::Message { +class HTTP::Message::Strict is HTTP::Message { #| see https://docs.raku.org/language/grammars#Attributes_in_grammars my constant $CRLF = "\x[0d]\x[0a]"; my constant $DELIM = $CRLF x 2; method new($content?, *%fields) { - my $header = HTTP::Header-Strict.new(|%fields); + my $header = HTTP::Header::Strict.new(|%fields); self.bless(:$header, :$content); } @@ -121,7 +121,7 @@ class HTTP::Message-Strict is HTTP::Message { $.protocol = $first; } - # $.header = HTTP::Header-Strict.new; + # $.header = HTTP::Header::Strict.new; $.header.parse: $fields; return self unless $content; @@ -179,7 +179,7 @@ class HTTP::Message-Strict is HTTP::Message { } -class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { +class HTTP::Request::Strict is HTTP::Message::Strict is HTTP::Request { my constant $CRLF = "\x[0D]\x[0A]"; @@ -208,17 +208,17 @@ class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { } } - my $header = HTTP::Header-Strict.new(|%fields); + my $header = HTTP::Header::Strict.new(|%fields); self.new($method // 'GET', $uri, $header, :$bin); } else { - self.bless: header => HTTP::Header-Strict.new + self.bless: header => HTTP::Header::Strict.new } } - multi method new() { self.bless: header => HTTP::Header-Strict.new } + multi method new() { self.bless: header => HTTP::Header::Strict.new } - multi method new(HTTP::Request::RequestMethod $method, URI $uri, HTTP::Header-Strict $header, Bool :$bin) { + multi method new(HTTP::Request::RequestMethod $method, URI $uri, HTTP::Header::Strict $header, Bool :$bin) { my $url = $uri.grammar.parse_result.orig; my $file = $uri.path_query || '/'; @@ -230,7 +230,7 @@ class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { method Str ( :$debug, Bool :$bin ) { $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; - join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug, :$bin; + join $CRLF, $s, self.HTTP::Message::Strict::Str: :$debug, :$bin; } method parse ( $raw_request ) { my @lines = $raw_request.split($CRLF); @@ -247,15 +247,15 @@ class HTTP::Request-Strict is HTTP::Message-Strict is HTTP::Request { $.url ~= $.file; self.uri = URI.new($.url); - self.HTTP::Message-Strict::parse: $raw_request; + self.HTTP::Message::Strict::parse: $raw_request; } } -class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { +class HTTP::Response::Strict is HTTP::Response is HTTP::Message::Strict { my constant $CRLF = "\x[0D]\x[0A]"; method next-request(--> HTTP::Request:D) { - my HTTP::Request-Strict $new-request; + my HTTP::Request::Strict $new-request; my $location = ~self.header.field('Location').values; @@ -272,7 +272,7 @@ class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { my %args = $method => $location; - $new-request = HTTP::Request-Strict.new(|%args); + $new-request = HTTP::Request::Strict.new(|%args); unless ~$new-request.field('Host').values { my $hh = ~$.request.field('Host').values; @@ -288,15 +288,15 @@ class HTTP::Response-Strict is HTTP::Response is HTTP::Message-Strict { method Str(:$debug) { my $s = $.protocol ~ " " ~ $.status-line; - join $CRLF, $s, self.HTTP::Message-Strict::Str: :$debug; + join $CRLF, $s, self.HTTP::Message::Strict::Str: :$debug; } } -class HTTP::UserAgent-Strict is HTTP::UserAgent { +class HTTP::UserAgent::Strict is HTTP::UserAgent { constant CRLF = Buf.new(13, 10); - role Connection-Strict does HTTP::UserAgent::Connection { - method send-request(HTTP::Request-Strict $request ) { + role Connection::Strict does HTTP::UserAgent::Connection { + method send-request(HTTP::Request::Strict $request ) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { self.print($request.Str(:bin)); @@ -317,7 +317,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { } multi method get(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Strict.new(GET => $uri, |%header); + my $request = HTTP::Request::Strict.new(GET => $uri, |%header); self.request($request, :$bin) } @@ -328,7 +328,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { proto method post(|) {*} multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Strict.new(POST => $uri, |%header); + my $request = HTTP::Request::Strict.new(POST => $uri, |%header); $request.add-form-data(%form); self.request($request, :$bin) } @@ -340,7 +340,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { proto method put(|) {*} multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request-Strict.new(PUT => $uri, |%header); + my $request = HTTP::Request::Strict.new(PUT => $uri, |%header); $request.add-form-data(%form); self.request($request, :$bin) } @@ -352,7 +352,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { proto method delete(|) {*} multi method delete(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request-Strict.new(DELETE => $uri, |%header); + my $request = HTTP::Request::Strict.new(DELETE => $uri, |%header); self.request($request, :$bin) } @@ -360,8 +360,8 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { self.delete(URI.new(HTTP::UserAgent::_clear-url($uri)), :$bin, |%header) } - method request(HTTP::Request-Strict $request, Bool :$bin --> HTTP::Response-Strict:D) { - my HTTP::Response-Strict $response; + method request(HTTP::Request::Strict $request, Bool :$bin --> HTTP::Response::Strict:D) { + my HTTP::Response::Strict $response; # add cookies to the request $request.add-cookies($.cookies); @@ -372,7 +372,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { # if auth has been provided add it to the request self.setup-auth($request); $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection-Strict $conn = self.get-connection($request); + my Connection::Strict $conn = self.get-connection($request); if $conn.send-request($request) { $response = self.get-response($request, $conn, :$bin); @@ -411,7 +411,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { $response } - multi method get-connection(HTTP::Request-Strict $request --> Connection-Strict:D) { + multi method get-connection(HTTP::Request::Strict $request --> Connection::Strict:D) { my $host = $request.host; my $port = $request.port; @@ -424,13 +424,13 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { if $proxy_auth.defined { $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); } - $request.field(Connection-Strict => 'close'); + $request.field(Connection::Strict => 'close'); } self.get-connection($request, $host, $port) } my $https_lock = Lock.new; - multi method get-connection(HTTP::Request-Strict $request, Str $host, Int $port? --> Connection-Strict:D) { + multi method get-connection(HTTP::Request::Strict $request, Str $host, Int $port? --> Connection::Strict:D) { my $conn; if $request.scheme eq 'https' { $https_lock.lock; @@ -442,11 +442,11 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { else { $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); } - $conn does Connection-Strict; + $conn does Connection::Strict; $conn } - method get-response(HTTP::Request-Strict $request, Connection-Strict $conn, Bool :$bin --> HTTP::Response-Strict:D) { + method get-response(HTTP::Request::Strict $request, Connection::Strict $conn, Bool :$bin --> HTTP::Response::Strict:D) { my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; @@ -484,7 +484,7 @@ class HTTP::UserAgent-Strict is HTTP::UserAgent { } - my HTTP::Response-Strict $response = HTTP::Response-Strict.new($header-chunk); + my HTTP::Response::Strict $response = HTTP::Response::Strict.new($header-chunk); $response.request = $request; if $response.has-content { diff --git a/t/011-headers-strict.rakutest b/t/011-headers-strict.rakutest index 2eeab5e..9a13d1e 100644 --- a/t/011-headers-strict.rakutest +++ b/t/011-headers-strict.rakutest @@ -1,12 +1,12 @@ use Test; -use HTTP::UA-Strict; +use HTTP::UA::Strict; plan 24; my constant $CRLF = "\x[0D]\x[0A]"; # new -my $h = HTTP::Header-Strict.new(a => "A", b => "B"); +my $h = HTTP::Header::Strict.new(a => "A", b => "B"); is ~$h.field('b'), 'B', 'new'; @@ -47,12 +47,12 @@ ok not $h.field('a'), 'remove-field 1/1'; $h.clear; ok not $h.field('b'), 'clear 1/1'; -$h = HTTP::Header-Strict.new(One => "one", Two => "two"); +$h = HTTP::Header::Strict.new(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-Strict.new(); +$h = HTTP::Header::Strict.new(); lives-ok { $h.parse('ETag: W/"1201-51b0ce7ad3900"') }, "parses ETag"; is ~$h.field('ETag'), "1201-51b0ce7ad3900", "got the value we expected"; @@ -86,7 +86,7 @@ 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-Strict.new; + my $h = HTTP::Header::Strict.new; $h.parse($htest); is $h.fields.elems,17, "got the number of fields we expected"; ok $h.field('ETag').weak.defined, 'ETag\'s weakness is defined'; diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index b176291..e518d4f 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -1,6 +1,6 @@ use Test; -use HTTP::UA-Strict; +use HTTP::UA::Strict; plan 23; @@ -9,14 +9,14 @@ my constant $CRLF = "\x[0d]\x[0a]"; ################################################################################ # new -# is HTTP::Message.^name, 'HTTP::Message-Strict', 'strict import'; -is HTTP::Message-Strict.^name, 'HTTP::Message-Strict', 'can use strict explicitly'; +# is HTTP::Message.^name, 'HTTP::Message::Strict', 'strict import'; +is HTTP::Message::Strict.^name, 'HTTP::Message::Strict', 'can use strict explicitly'; -my $m = HTTP::Message-Strict.new('somecontent', a => ['a1', 'a2']); +my $m = HTTP::Message::Strict.new('somecontent', a => ['a1', 'a2']); # isa-ok $m, HTTP::Message, 'new 1/5'; # isa-ok $m.header, HTTP::Header, 'new 2/5'; -isa-ok $m.header, HTTP::Header-Strict, 'new 3/5'; +isa-ok $m.header, HTTP::Header::Strict, 'new 3/5'; is $m.field('a'), 'a1, a2', 'new 4/5'; is $m.content, 'somecontent', 'new 5/5'; @@ -61,7 +61,7 @@ is $m.content, '', 'clear 2/2'; ## parse a more complex example # new -my $m2 = HTTP::Message-Strict.new; +my $m2 = HTTP::Message::Strict.new; # parse $to_parse = "HTTP/1.1 200 OK\r\n" @@ -97,16 +97,16 @@ 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-Strict.new.charset, 'iso-8859-1', "dumb default charset"; - is HTTP::Message-Strict.new(Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; - is HTTP::Message-Strict.new(Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; - is HTTP::Message-Strict.new(Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; + is HTTP::Message::Strict.new.charset, 'iso-8859-1', "dumb default charset"; + is HTTP::Message::Strict.new(Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; + is HTTP::Message::Strict.new(Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; + is HTTP::Message::Strict.new(Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; }, "charset"; ################################################################################ # construct request - move to request 042-request-issue-226.rakutest -# my $m = HTTP::Message-Strict.new: +# my $m = HTTP::Message::Strict.new: # 'four', # Content-Type => 'text/plain', # Transfer-Encoding => 'chunked' @@ -123,7 +123,7 @@ subtest { '0', # last chunk $CRLF, # end of chunk body ; # FIXME : does not test: trailer, chunk extension, binary - my HTTP::Request-Strict:D $m = HTTP::Request-Strict.new.parse: $to-parse; + my HTTP::Request::Strict:D $m = HTTP::Request::Strict.new.parse: $to-parse; is $m.protocol, 'HTTP/1.1', 'protocol'; is $m.field('Transfer-Encoding'), 'chunked', 'parsed header'; @@ -166,7 +166,7 @@ subtest { ~ "Content-Length: 3\r\n" ~ "\r\n" ~ "a\nb"; - my HTTP::Response-Strict:D $m2 = HTTP::Response-Strict.new.parse($to_parse); + my HTTP::Response::Strict:D $m2 = HTTP::Response::Strict.new.parse($to_parse); ok $m2.is-text, 'text'; nok $m2.is-binary, 'not binary'; is $m2.field('Content-Length'), '3', 'Content-Length'; @@ -187,7 +187,7 @@ subtest { ~ "0\r\n" ~ "\r\n" ; - my HTTP::Response-Strict:D $m2 = HTTP::Response-Strict.new.parse($to_parse); + my HTTP::Response::Strict:D $m2 = HTTP::Response::Strict.new.parse($to_parse); ok $m2.is-text, 'text'; nok $m2.is-binary, 'not binary'; diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index db52cd5..c3e2a02 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -1,7 +1,7 @@ use Test; use URI; -use HTTP::UA-Strict; +use HTTP::UA::Strict; plan 29; @@ -14,7 +14,7 @@ my $file = '/cat/f.h?q=1&q=2'; my $host = 'testsite.ext'; # new -my $r1 = HTTP::Request-Strict.new(POST => $url, test_field => 'this_is_field'); +my $r1 = HTTP::Request::Strict.new(POST => $url, test_field => 'this_is_field'); is $r1.method, 'post'.uc, 'new 1/8'; is $r1.url, $url, 'new 2/8'; @@ -22,8 +22,8 @@ is $r1.file, $file, 'new 3/8'; is $r1.field('Host'), $host, 'new 4/8'; is $r1.field('test_field'), 'this_is_field', 'new 5/8'; ok $r1.Str ~~ /^POST\s$file/, 'new 6/8'; -isa-ok $r1, HTTP::Request-Strict, 'new 7/8'; -isa-ok $r1, HTTP::Message-Strict, 'new 8/8'; +isa-ok $r1, HTTP::Request::Strict, 'new 7/8'; +isa-ok $r1, HTTP::Message::Strict, 'new 8/8'; # content $r1.add-content('n1=v1&a'); @@ -56,7 +56,7 @@ 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-Strict.new.parse($req); +$r1 = HTTP::Request::Strict.new.parse($req); is $r1.method, 'get'.uc, 'parse 1/6'; is $r1.file, '/index', 'parse 2/6'; @@ -67,7 +67,7 @@ is $r1.Str, $exp, 'parse 6/6'; subtest { my $r; - lives-ok { $r = HTTP::Request-Strict.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new(Foo => 'bar') ) }, "mew with positionals"; + lives-ok { $r = HTTP::Request::Strict.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new(Foo => 'bar') ) }, "mew with positionals"; is $r.method, 'GET', "right method"; is $r.file, '/bar', "right file"; is $r.field('Host'), 'foo.com', 'got right host'; @@ -75,7 +75,7 @@ subtest { subtest { subtest { - my $req = HTTP::Request-Strict.new(POST => URI.new('http://127.0.0.1/')); + my $req = HTTP::Request::Strict.new(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'; @@ -83,7 +83,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with positional Hash'; subtest { - my $req = HTTP::Request-Strict.new(POST => URI.new('http://127.0.0.1/')); + my $req = HTTP::Request::Strict.new(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'; @@ -91,7 +91,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with slurpy hash'; subtest { - my $req = HTTP::Request-Strict.new(POST => 'http://127.0.0.1/', X-Foo => 'Bar'); + my $req = HTTP::Request::Strict.new(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'; @@ -101,18 +101,18 @@ subtest { }, 'content by array'; subtest { # need to set the host up front so it compares with the data nicely - my $req = HTTP::Request-Strict.new(POST => 'http://127.0.0.1/', Host => '127.0.0.1', content-type => 'multipart/form-data; boundary=XxYyZ'); + my $req = HTTP::Request::Strict.new(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-Strict.new(POST => 'http://127.0.0.1/'); + my $req = HTTP::Request::Strict.new(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, /"multipart\/form-data"/, "and got multipart data"; }, 'multipart explicit'; subtest { - my $req = HTTP::Request-Strict.new(POST => 'http://127.0.0.1/'); + my $req = HTTP::Request::Strict.new(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, /"multipart\/form-data"/, "and got multipart data"; }, 'multipart explicit with slurpy hash (check no gobble adverb)'; @@ -132,8 +132,8 @@ my Str:D $expected = join $CRLF, "- four\n- five", # content ; # FIXME : does not test: trailer, chunk extension, binary -my HTTP::Request-Strict $r = - HTTP::Request-Strict.new: +my HTTP::Request::Strict $r = + HTTP::Request::Strict.new: POST => $url; $r.add-content: "- four\n- five"; is $r.Str, $expected, 'build non-chunked post'; diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest index abbfc05..2abdf9f 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -1,6 +1,6 @@ use Test; -use HTTP::UA-Strict; +use HTTP::UA::Strict; plan 29; @@ -9,10 +9,10 @@ my constant $CRLF = "\x[0D]\x[0A]"; ############################################################################### # new -my $r = HTTP::Response-Strict.new(200, a => 'a'); +my $r = HTTP::Response::Strict.new(200, a => 'a'); -isa-ok $r, HTTP::Response-Strict, 'new 1/3'; -isa-ok $r, HTTP::Message-Strict, 'new 2/3'; +isa-ok $r, HTTP::Response::Strict, 'new 1/3'; +isa-ok $r, HTTP::Message::Strict, 'new 2/3'; is $r.field('a'), 'a', 'new 3/3'; # field @@ -38,7 +38,7 @@ 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-Strict.new.parse($res); +$r = HTTP::Response::Strict.new.parse($res); 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'; @@ -46,7 +46,7 @@ is $r.protocol, 'HTTP/1.1', 'parse - protocol 4/4'; # has-content -$r = HTTP::Response-Strict.new(204); +$r = HTTP::Response::Strict.new(204); ok !$r.has-content, "has-content 1/3"; $r.set-code(304); ok !$r.has-content, "has-content 2/3"; @@ -55,13 +55,13 @@ 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, 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, 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, 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, 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, 10, 65, 99, 99, 101, 112, 116, 45, 82, 97, 110, 103, 101, 115, 58, 32, 98, 121, 116, 101, 115, 10, 67, 111, 110, 116, 101, 110, 116, 45, 76, 101, 110, 103, 116, 104, 58, 32, 52, 54, 48, 57, 10, 67, 111, 110, 110, 101, 99, 116, 105, 111, 110, 58, 32, 99, 108, 111, 115, 101, 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, 10, 10, 10); -lives-ok { $r = HTTP::Response-Strict.new($buf) }, "create Response-Strict from a Buf"; +lives-ok { $r = HTTP::Response::Strict.new($buf) }, "create Response::Strict 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-Strict.new(200, Content-Length => "hsh") }, "create a response with a Content-Length"; +lives-ok { $r = HTTP::Response::Strict.new(200, Content-Length => "hsh") }, "create a response with a Content-Length"; throws-like { $r.content-length }, X::HTTP::ContentLength; -lives-ok { $r = HTTP::Response-Strict.new(200, Content-Length => "888") }, "create a response with a Content-Length"; +lives-ok { $r = HTTP::Response::Strict.new(200, 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"; @@ -71,14 +71,14 @@ subtest { throws-like { $r = HTTP::Response.new(Buf.new) }, 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-Strict.new($garbage); + $r = HTTP::Response::Strict.new($garbage); }, "create with garbage"; is $r.code, 500, "and got a 500 response"; }, "failure modes"; subtest { - my $res = HTTP::Response-Strict.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode; + my $res = HTTP::Response::Strict.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode; 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'; @@ -87,7 +87,7 @@ subtest { # subtest { # plan 4; -# my $r = HTTP::Response-Strict.new; +# my $r = HTTP::Response::Strict.new; # my Str:D $expected = join $CRLF, # 'HTTP/1.1 200 OK', # status line # 'Content-Type: text/plain', # header @@ -108,7 +108,7 @@ subtest { subtest { plan 4; - my $r = HTTP::Response-Strict.new; + my $r = HTTP::Response::Strict.new; my Str:D $expected = join $CRLF, 'HTTP/1.1 200 OK', # status line 'Content-Length: 7', # header diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest index a7044db..552dc67 100644 --- a/t/081-ua-strict.rakutest +++ b/t/081-ua-strict.rakutest @@ -1,4 +1,4 @@ -use HTTP::UA-Strict; +use HTTP::UA::Strict; use HTTP::UserAgent::Common; use Test; @@ -7,14 +7,14 @@ use URI; plan 11; # new -my $ua = HTTP::UserAgent-Strict.new; +my $ua = HTTP::UserAgent::Strict.new; nok $ua.useragent, 'new 1/3'; -$ua = HTTP::UserAgent-Strict.new(:useragent('test')); +$ua = HTTP::UserAgent::Strict.new(:useragent('test')); is $ua.useragent, 'test', 'new 2/3'; my $newua = get-ua('chrome_linux'); -$ua = HTTP::UserAgent-Strict.new(:useragent('chrome_linux')); +$ua = HTTP::UserAgent::Strict.new(:useragent('chrome_linux')); is $ua.useragent, $newua, 'new 3/3'; if %*ENV { @@ -26,17 +26,17 @@ if %*ENV { lives-ok { my $response = $ua.get('github.com/'); ok $response, 'get 1/3'; - isa-ok $response, HTTP::Response-Strict, 'get 2/3'; + isa-ok $response, HTTP::Response::Strict, 'get 2/3'; ok $response.is-success, 'get 3/3'; }, "get from 'github.com/'"; # non-ascii encodings (github issue #35) - lives-ok { HTTP::UserAgent-Strict.new.get('http://www.baidu.com') }, 'Lived through gb2312 encoding'; + lives-ok { HTTP::UserAgent::Strict.new.get('http://www.baidu.com') }, 'Lived through gb2312 encoding'; # chunked encoding. skip 'Site changed. Need new site to cover this problem See #208'; -# lives-ok { HTTP::UserAgent-Strict.new.get('http://rakudo.org') }, "issue#51 - get rakudo.org (chunked encoding foul-up results in incomplete UTF-8 data)"; +# lives-ok { HTTP::UserAgent::Strict.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; @@ -52,7 +52,7 @@ if %*ENV { subtest { my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; my %data = :72foo, :bar<♵>; - my $ua = HTTP::UserAgent-Strict.new; + my $ua = HTTP::UserAgent::Strict.new; my $res; lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "new make post"; my $ret-data; @@ -69,7 +69,7 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent-Strict.new; + my $ua = HTTP::UserAgent::Strict.new; my $res; lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "make post"; my $ret-data; @@ -86,7 +86,7 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent-Strict.new; + my $ua = HTTP::UserAgent::Strict.new; my $res; lives-ok { $res = $ua.post($uri, %data, X-Foo => "foodle") }, "make post"; my $ret-data; From bb8c04942ead925cb97254096ac941f867076e0b Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Tue, 3 Feb 2026 01:24:55 -0800 Subject: [PATCH 19/28] rename nested grammar --- lib/HTTP/UA/Strict.rakumod | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/HTTP/UA/Strict.rakumod b/lib/HTTP/UA/Strict.rakumod index d89e7aa..25f8f47 100644 --- a/lib/HTTP/UA/Strict.rakumod +++ b/lib/HTTP/UA/Strict.rakumod @@ -9,7 +9,7 @@ use HTTP::Header; class HTTP::Header::Strict is HTTP::Header { use HTTP::Header::ETag; - grammar HTTP::Header::Strict::Grammar { + grammar Grammar { token TOP { } @@ -59,7 +59,7 @@ class HTTP::Header::Strict is HTTP::Header { } } - class HTTP::Header::Strict::Actions { + class Grammar::Actions { method etag ( $/ ) { $*OBJ.field: HTTP::Header::ETag.new: @@ -91,9 +91,9 @@ class HTTP::Header::Strict is HTTP::Header { method parse($raw) { my $*OBJ = self; - HTTP::Header::Strict::Grammar.parse: + Grammar.parse: $raw, - actions => HTTP::Header::Strict::Actions + actions => Grammar::Actions ; } } From 4a598f3767b775167f148d82416f05c9d3b594aa Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Tue, 3 Feb 2026 13:08:19 -0800 Subject: [PATCH 20/28] add back auth --- lib/HTTP/Cookies.rakumod | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/HTTP/Cookies.rakumod b/lib/HTTP/Cookies.rakumod index 1e2d03c..35f0a0d 100644 --- a/lib/HTTP/Cookies.rakumod +++ b/lib/HTTP/Cookies.rakumod @@ -1,7 +1,7 @@ unit class HTTP::Cookies; use HTTP::Cookie; -use HTTP::Response; +use HTTP::Response:auth; use HTTP::Request:auth; use DateTime::Parse; From 851eff9b2eb476fca9c0fe78062028f03f641d66 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Fri, 6 Feb 2026 06:20:49 -0800 Subject: [PATCH 21/28] flag implementation of strict --- META6.json | 6 - lib/HTTP/Header.rakumod | 106 +++++- lib/HTTP/Message.rakumod | 65 +++- lib/HTTP/Request.rakumod | 23 +- lib/HTTP/Response.rakumod | 30 +- lib/HTTP/UA/Strict.rakumod | 520 ------------------------------ lib/HTTP/UserAgent.rakumod | 77 +++-- t/011-headers-strict.rakutest | 23 +- t/021-message-issue-226.rakutest | 78 ++--- t/042-request-issue-226.rakutest | 49 ++- t/051-response-issue-226.rakutest | 51 +-- t/081-ua-strict.rakutest | 38 +-- 12 files changed, 335 insertions(+), 731 deletions(-) delete mode 100644 lib/HTTP/UA/Strict.rakumod diff --git a/META6.json b/META6.json index f88eef6..5a32b69 100644 --- a/META6.json +++ b/META6.json @@ -31,12 +31,6 @@ "HTTP::UserAgent": "lib/HTTP/UserAgent.rakumod", "HTTP::UserAgent::Common": "lib/HTTP/UserAgent/Common.rakumod", "HTTP::UserAgent::Exception": "lib/HTTP/UserAgent/Exception.rakumod", - "HTTP::UserAgent::Strict": "lib/HTTP/UA/Strict.rakumod", - "HTTP::UA::Strict": "lib/HTTP/UA/Strict.rakumod", - "HTTP::Message::Strict": "lib/HTTP/UA/Strict.rakumod", - "HTTP::Request::Strict": "lib/HTTP/UA/Strict.rakumod", - "HTTP::Response::Strict": "lib/HTTP/UA/Strict.rakumod", - "HTTP::Header::Strict": "lib/HTTP/UA/Strict.rakumod", "HTTP::Header::ETag": "lib/HTTP/Header/ETag.rakumod" }, "raku": "6.*", diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index d4223aa..1b9f0e0 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, *%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,19 @@ method clear() { } # get header as string -method Str($eol = "\n") { +method Str($eol is copy = "\n", Bool :$strict) { + $eol = $CRLF if $!strict or $strict; @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } -method parse($raw) { - my $*OBJ = self; - HTTP::Header::Grammar.parse($raw, :actions(HTTP::Header::Actions)); +method parse($raw, Bool :$strict) { + if $!strict or $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/Message.rakumod b/lib/HTTP/Message.rakumod index 943de35..ba2e866 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,13 @@ 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; -method new($content?, *%fields) { - my $header = HTTP::Header.new(|%fields); +method new($content?, Bool :$strict, *%fields) { + my $header = HTTP::Header.new(:$strict, |%fields); - self.bless(:$header, :$content); + self.bless(:$header, :$content, :$strict); } method add-content($content) { @@ -191,7 +193,43 @@ method clear { $.content = '' } -method parse($raw_message) { +method !parse ( $raw_message ) { + my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; + my ( $fields, $content ) = $rest.split: $DELIM, 2; + + my ($first, $second, $third) = $start-line.split(/\s+/); + if $third.index('/') { # is a request + $.protocol = $third; + } + else { # is a response + $.protocol = $first; + } + + # $.header = HTTP::Header::Strict.new; + $.header.parse: $fields, :strict; + return self unless $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 *, + @lines.map: + -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } + ; + $.content = @lines.join; + } else { + $.content = $content; + } + + self +} + +method parse($raw_message, Bool :$strict) { + return self!parse: $raw_message if $!strict or $strict; + my @lines = $raw_message.split(/$CRLF/); my ($first, $second, $third) = @lines.shift.split(/\s+/); @@ -225,14 +263,23 @@ method parse($raw_message) { self } -method Str($eol = "\n", :$debug, Bool :$bin) { +method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict is copy) { + $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 unless $strict or not $.content; # The :bin will be passed from the H::UA if not $bin { - $s ~= $.content ~ $eol if $.content and !$debug; + if $strict { + $s = join $CRLF, $s, $.content || ''; + } else { + $s ~= $.content ~ $eol if $.content and !$debug; + } } if $.content and $debug { if $bin || self.is-binary { diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index a5af450..da42df0 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -16,14 +16,15 @@ has $.uri is rw; has Str $.host is rw; has Int $.port is rw; has Str $.scheme is rw; +has Bool $.strict is rw; -my $CRLF = "\r\n"; +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 :$bin, Bool :$strict, *%args) { if %args { my ($method, $url, $file, %fields, $uri); @@ -37,23 +38,23 @@ 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, :$bin, :$strict); } else { self.bless } } -multi method new() { self.bless } +multi method new(Bool :$strict) { self.bless: :$strict } -multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin) { +multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin, Bool :$strict) { 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 +267,15 @@ method make-boundary(int $size=10) { } -method Str (:$debug, Bool :$bin) { +method Str (:$debug, Bool :$bin, Bool :$strict is copy) { + $strict ||= $!strict; $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; - $s ~= $CRLF ~ callwith($CRLF, :$debug, :$bin); + join $CRLF, $s, callwith $CRLF, :$debug, :$bin, :$strict; } -method parse($raw_request) { +method parse($raw_request, Bool :$strict is copy) { + $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..c9c3c18 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,29 @@ 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) { # 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); +multi method new(Int:D $code = 200, Bool :$strict, *%fields) { + my $header = HTTP::Header.new(:$strict, |%fields); + self.bless(:$code, :$header, :$strict); } method content-length(--> Int) { @@ -97,9 +106,10 @@ method next-request(--> HTTP::Request:D) { $new-request } -method Str(:$debug) { +method Str(:$debug, Bool :$strict is copy) { + $strict ||= $!strict; my $s = $.protocol ~ " " ~ $!status-line; - $s ~= $CRLF ~ callwith($CRLF, :debug($debug)); + join $CRLF, $s, callwith $CRLF, :$debug, :$strict; } # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UA/Strict.rakumod b/lib/HTTP/UA/Strict.rakumod deleted file mode 100644 index 25f8f47..0000000 --- a/lib/HTTP/UA/Strict.rakumod +++ /dev/null @@ -1,520 +0,0 @@ -use URI; - -use HTTP::UserAgent; -use HTTP::Message; -use HTTP::Request:auth; -use HTTP::Response:auth; -use HTTP::Header; - -class HTTP::Header::Strict is HTTP::Header { - use HTTP::Header::ETag; - - grammar Grammar { - 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 { - \" \" - } - token opaque-content { - <[\x[21]..\x[FF]]-[\x[22]\x[7F]]>* - } - token vchars { <[\x[21]..\x[7E]]>+ } - token field-vchars { <[\x[21]..\x[FF]]-[\x[7F]]>+ } - token value { - [ <[\t\x[20]]>* ]* - } - token quoted-string { - \" \" - } - token quoted-content { - [ | ]* - } - token qtd-text { - <[\t\x[20]..\x[FF]]-[\x[22]\x[5C]\x[7F]]>+ - } - token quotable-char { - <[\t\x[20]..\x[FF]]-[\x[7F]]> - } - token quoted-pair { - \\ - } - } - - class Grammar::Actions { - 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; - } - } - - multi method field ( HTTP::Header::ETag:D $etag ) { - @.fields.push: $etag; - } - - method parse($raw) { - my $*OBJ = self; - Grammar.parse: - $raw, - actions => Grammar::Actions - ; - } -} - -class HTTP::Message::Strict is HTTP::Message { - #| see https://docs.raku.org/language/grammars#Attributes_in_grammars - my constant $CRLF = "\x[0d]\x[0a]"; - my constant $DELIM = $CRLF x 2; - - method new($content?, *%fields) { - my $header = HTTP::Header::Strict.new(|%fields); - - self.bless(:$header, :$content); - } - - method parse ( $raw_message ) { - my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; - my ( $fields, $content ) = $rest.split: $DELIM, 2; - - my ($first, $second, $third) = $start-line.split(/\s+/); - if $third.index('/') { # is a request - $.protocol = $third; - } - else { # is a response - $.protocol = $first; - } - - # $.header = HTTP::Header::Strict.new; - $.header.parse: $fields; - return self unless $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 *, - @lines.map: - -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } - ; - $.content = @lines.join; - return self; - } else { - $.content = $content; - return self; - } - - self - } - - method Str ( :$debug, Bool :$bin ) { - my constant $max_size = 300; - # TODO : reference relevant section of relevant RFC - # TODO : need to consider Str vs Buf length ? - self.field: Content-Length => ( $.content.?encode or $.content ).bytes.Str - if $.content and not self.is-chunked; - my $s = $.header.Str: $CRLF; - - # The :bin will be passed from the H::UA - if not $bin { - # do not append CRLF unless chunked - # https://datatracker.ietf.org/doc/html/rfc2616#section-4.3 - # https://datatracker.ietf.org/doc/html/rfc2616#section-7.2 - # https://datatracker.ietf.org/doc/html/rfc2616#section-14.41 - # not supporting chunked Str atm - $s = join $CRLF, $s, $.content || ''; - } - if $.content and $debug { - if $bin || self.is-binary { - $s ~= $CRLF ~ "=Content size : " ~ $.content.elems ~ " bytes "; - $s ~= "$CRLF ** Not showing binary content ** $CRLF"; - } - else { - $s ~= $CRLF ~ "=Content size: "~$.content.Str.chars~" chars"; - $s ~= "- Displaying only $max_size" if $.content.Str.chars > $max_size; - $s ~= $CRLF ~ $.content.Str.substr(0, $max_size) ~ $CRLF; - } - } - - $s - } - -} - -class HTTP::Request::Strict is HTTP::Message::Strict is HTTP::Request { - my constant $CRLF = "\x[0D]\x[0A]"; - - - sub get-host-value(URI $uri --> Str) { - my Str $host = $uri.host; - - if $host { - if ( $uri.port != $uri.default_port ) { - $host ~= ':' ~ $uri.port; - } - } - $host; - } - - multi method new(Bool :$bin, *%args) { - - if %args { - my ($method, $url, $file, %fields, $uri); - for %args.kv -> $key, $value { - if $key.lc ~~ any() { - $uri = $value.isa(URI) ?? $value !! URI.new($value); - $method = $key.uc; - } - else { - %fields{$key} = $value; - } - } - - my $header = HTTP::Header::Strict.new(|%fields); - self.new($method // 'GET', $uri, $header, :$bin); - } - else { - self.bless: header => HTTP::Header::Strict.new - } - } - - multi method new() { self.bless: header => HTTP::Header::Strict.new } - - multi method new(HTTP::Request::RequestMethod $method, URI $uri, HTTP::Header::Strict $header, 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) - } - - method Str ( :$debug, Bool :$bin ) { - $.file = '/' ~ $.file unless $.file.starts-with: '/'; - my $s = "$.method $.file $.protocol"; - join $CRLF, $s, self.HTTP::Message::Strict::Str: :$debug, :$bin; - } - method parse ( $raw_request ) { - my @lines = $raw_request.split($CRLF); - ($.method, $.file) = @lines.shift.split(' '); - - $.url = 'http://'; - - for @lines -> $line { - if $line ~~ m:i/host:/ { - $.url ~= $line.split(/\:\s*/)[1]; - } - } - - $.url ~= $.file; - - self.uri = URI.new($.url); - self.HTTP::Message::Strict::parse: $raw_request; - } -} - -class HTTP::Response::Strict is HTTP::Response is HTTP::Message::Strict { - my constant $CRLF = "\x[0D]\x[0A]"; - - method next-request(--> HTTP::Request:D) { - my HTTP::Request::Strict $new-request; - - my $location = ~self.header.field('Location').values; - - - if $location.defined { - # Special case for the HTTP status code 303 (redirection): - # The response to the request can be found under another URI using - # a separate GET method. This relates to POST, PUT, DELETE and PATCH - # methods. - my $method = $.request.method; - $method = "GET" - if self.code == 303 - && $.request.method eq any('POST', 'PUT', 'DELETE', 'PATCH'); - - my %args = $method => $location; - - $new-request = HTTP::Request::Strict.new(|%args); - - unless ~$new-request.field('Host').values { - my $hh = ~$.request.field('Host').values; - $new-request.field(Host => $hh); - $new-request.scheme = $.request.scheme; - $new-request.host = $.request.host; - $new-request.port = $.request.port; - } - } - - $new-request - } - - method Str(:$debug) { - my $s = $.protocol ~ " " ~ $.status-line; - join $CRLF, $s, self.HTTP::Message::Strict::Str: :$debug; - } -} - -class HTTP::UserAgent::Strict is HTTP::UserAgent { - constant CRLF = Buf.new(13, 10); - - role Connection::Strict does HTTP::UserAgent::Connection { - method send-request(HTTP::Request::Strict $request ) { - $request.field(Connection => 'close') unless $request.field('Connection'); - if $request.binary { - self.print($request.Str(:bin)); - self.write($request.content); - } else { - self.print: $request.Str; - } - } - } - - multi sub basic-auth-token(Str $login, Str $passwd --> Str:D) { - basic-auth-token("{$login}:{$passwd}"); - - } - - multi sub basic-auth-token(Str $creds where * ~~ /':'/ --> Str:D) { - "Basic " ~ MIME::Base64.encode-str($creds, :oneline); - } - - multi method get(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request::Strict.new(GET => $uri, |%header); - self.request($request, :$bin) - } - - multi method get(Str $uri is copy, Bool :$bin, *%header ) { - self.get(URI.new(HTTP::UserAgent::_clear-url($uri)), :$bin, |%header) - } - - proto method post(|) {*} - - multi method post(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request::Strict.new(POST => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) - } - - multi method post(Str $uri is copy, %form, Bool :$bin, *%header ) { - self.post(URI.new(HTTP::UserAgent::_clear-url($uri)), %form, |%header) - } - - proto method put(|) {*} - - multi method put(URI $uri is copy, %form , Bool :$bin, *%header) { - my $request = HTTP::Request::Strict.new(PUT => $uri, |%header); - $request.add-form-data(%form); - self.request($request, :$bin) - } - - multi method put(Str $uri is copy, %form, Bool :$bin, *%header ) { - self.put(URI.new(HTTP::UserAgent::_clear-url($uri)), %form, |%header) - } - - proto method delete(|) {*} - - multi method delete(URI $uri is copy, Bool :$bin, *%header ) { - my $request = HTTP::Request::Strict.new(DELETE => $uri, |%header); - self.request($request, :$bin) - } - - multi method delete(Str $uri is copy, Bool :$bin, *%header ) { - self.delete(URI.new(HTTP::UserAgent::_clear-url($uri)), :$bin, |%header) - } - - method request(HTTP::Request::Strict $request, Bool :$bin --> HTTP::Response::Strict:D) { - my HTTP::Response::Strict $response; - - # add cookies to the request - $request.add-cookies($.cookies); - - # set the useragent - $request.field(User-Agent => $.useragent) if $.useragent.defined; - - # if auth has been provided add it to the request - self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug)) if $.debug; - my Connection::Strict $conn = self.get-connection($request); - - if $conn.send-request($request) { - $response = self.get-response($request, $conn, :$bin); - } - $conn.close; - - X::HTTP::Response.new(:rc('No response')).throw unless $response; - - $.debug-handle.say("<<==Recv\n" ~ $response.Str(:debug)) if $.debug; - - # save cookies - $.cookies.extract-cookies($response); - - if $response.code ~~ /^30<[0123]>/ { - $.redirects-in-a-row++; - 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); - } - else { - $.redirects-in-a-row = 0; - } - if $.throw-exceptions { - given $response.code { - when /^4/ { - X::HTTP::Response.new(:rc($response.status-line), :response($response)).throw; - } - when /^5/ { - X::HTTP::Server.new(:rc($response.status-line), :response($response)).throw; - } - } - } - - $response - } - - multi method get-connection(HTTP::Request::Strict $request --> Connection::Strict:D) { - my $host = $request.host; - my $port = $request.port; - - - if self.get-proxy($request) -> $http_proxy { - $request.file = $request.url; - my ($proxy_host, $proxy_auth) = $http_proxy.split('/').[2].split('@', 2).reverse; - ($host, $port) = $proxy_host.split(':'); - $port.=Int; - if $proxy_auth.defined { - $request.field(Proxy-Authorization => basic-auth-token($proxy_auth)); - } - $request.field(Connection::Strict => 'close'); - } - self.get-connection($request, $host, $port) - } - - my $https_lock = Lock.new; - multi method get-connection(HTTP::Request::Strict $request, Str $host, Int $port? --> Connection::Strict:D) { - my $conn; - if $request.scheme eq 'https' { - $https_lock.lock; - try require ::("IO::Socket::SSL"); - $https_lock.unlock; - die "Please install IO::Socket::SSL in order to fetch https sites" if ::('IO::Socket::SSL') ~~ Failure; - $conn = ::('IO::Socket::SSL').new(:$host, :port($port // 443), :timeout($.timeout)) - } - else { - $conn = IO::Socket::INET.new(:$host, :port($port // 80), :timeout($.timeout)); - } - $conn does Connection::Strict; - $conn - } - - method get-response(HTTP::Request::Strict $request, Connection::Strict $conn, Bool :$bin --> HTTP::Response::Strict:D) { - my Blob[uint8] $first-chunk = Blob[uint8].new; - my $msg-body-pos; - - CATCH { - when X::HTTP::NoResponse { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; - } - when /'Connection reset by peer'/ { - X::HTTP::Internal.new(rc => 500, reason => "Connection reset by peer").throw; - } - } - - # Header can be longer than one chunk - while my $t = $conn.recv( :bin ) { - $first-chunk ~= $t; - - # Find the header/body separator in the chunk, which means - # we can parse the header seperately and are able to figure - # out the correct encoding of the body. - $msg-body-pos = HTTP::UserAgent::search-header-end($first-chunk); - last if $msg-body-pos.defined; - } - - - # If the header would indicate that there won't - # be any content there may not be a \r\n\r\n at - # the end of the header. - my $header-chunk = do if $msg-body-pos.defined { - $first-chunk.subbuf(0, $msg-body-pos); - } - else { - # Assume we have the whole header because if the server - # didn't send it we're stuffed anyway - $first-chunk; - } - - - my HTTP::Response::Strict $response = HTTP::Response::Strict.new($header-chunk); - $response.request = $request; - - if $response.has-content { - if !$msg-body-pos.defined { - X::HTTP::Internal.new(rc => 500, reason => "server returned no data").throw; - } - - - my $content = $first-chunk.subbuf($msg-body-pos); - # Turn the inner exceptions to ours - # This may really want to be outside - CATCH { - when X::HTTP::ContentLength { - X::HTTP::Header.new( :rc($_.message), :response($response) ).throw - } - } - # We also need to handle 'Transfer-Encoding: chunked', which means - # that we request more chunks and assemble the response body. - if $response.is-chunked { - $content = self.get-chunked-content($conn, $content); - } - elsif $response.content-length -> $content-length is copy { - $content = self.get-content($conn, $content, $content-length); - } - else { - $content = self.get-content($conn, $content); - } - - $response.content = $content andthen $response.content = $response.decoded-content(:$bin); - } - $response - } -} diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index d621084..caaffcd 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -16,19 +16,23 @@ constant CRLF = Buf.new(13, 10); # placeholder role to make signatures nicer # and enable greater abstraction -our role Connection { - method send-request(HTTP::Request $request ) { +role Connection { + method send-request(HTTP::Request $request, Bool :$strict) { $request.field(Connection => 'close') unless $request.field('Connection'); if $request.binary { self.print($request.Str(:bin)); self.write($request.content); } + elsif $strict { + self.print: $request.Str; + } 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( @@ -43,7 +47,7 @@ has Bool $.throw-exceptions; has $.debug; has IO::Handle $.debug-handle; -our sub search-header-end(Blob $input) { +my sub search-header-end(Blob $input) { my $i = 0; my $input-bytes = $input.bytes; while $i+2 <= $input-bytes { @@ -71,7 +75,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 { @@ -96,51 +100,57 @@ 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 :$bin, Bool :$strict is copy, *%header ) { + $strict ||= $!strict; + my $request = HTTP::Request.new(GET => $uri, :$strict, |%header); + self.request($request, :$bin, :$strict) } -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 :$bin, Bool :$strict, *%header ) { + self.get(URI.new(_clear-url($uri)), :$bin, :$strict, |%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 :$bin, Bool :$strict is copy, *%header) { + $strict ||= $!strict; + my $request = HTTP::Request.new(POST => $uri, :$strict, |%header); $request.add-form-data(%form); - self.request($request, :$bin) + self.request($request, :$bin, :$strict) } -multi method post(Str $uri is copy, %form, Bool :$bin, *%header ) { - self.post(URI.new(_clear-url($uri)), %form, |%header) +# should :$bin also be passed along? +multi method post(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) { + self.post(URI.new(_clear-url($uri)), %form, :$strict, |%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 :$bin, Bool :$strict is copy, *%header) { + $strict ||= $!strict; + my $request = HTTP::Request.new(PUT => $uri, :$strict, |%header); $request.add-form-data(%form); - self.request($request, :$bin) + self.request($request, :$bin, :$strict) } -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 :$bin, Bool :$strict, *%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 :$bin, Bool :$strict is copy, *%header ) { + $strict ||= $!strict; + my $request = HTTP::Request.new(DELETE => $uri, :$strict, |%header); + self.request($request, :$bin, :$strict) } -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 :$bin, Bool :$strict, *%header ) { + self.delete(URI.new(_clear-url($uri)), :$bin, :$strict, |%header) } -method request(HTTP::Request $request, Bool :$bin --> HTTP::Response:D) { +method request(HTTP::Request $request, Bool :$bin, Bool :$strict is copy --> HTTP::Response:D) { + $strict ||= $!strict; my HTTP::Response $response; # add cookies to the request @@ -151,11 +161,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(:debug, :$strict)) 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, :$bin, :$strict); } $conn.close; @@ -171,8 +181,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 +270,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 :$bin, Bool :$strict is copy --> HTTP::Response:D) { + $strict ||= $!strict; my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; @@ -298,7 +309,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 { @@ -467,7 +478,7 @@ our sub getstore(Str $url, Str $file) is export(:simple) { $file.IO.spurt: get($url) } -our sub _clear-url(Str $url is copy) { +sub _clear-url(Str $url is copy) { $url.starts-with('http://' | 'https://') ?? $url !! "http://$url" diff --git a/t/011-headers-strict.rakutest b/t/011-headers-strict.rakutest index 9a13d1e..27ccf5f 100644 --- a/t/011-headers-strict.rakutest +++ b/t/011-headers-strict.rakutest @@ -1,12 +1,13 @@ use Test; -use HTTP::UA::Strict; +use HTTP::UserAgent; +use HTTP::Header; plan 24; my constant $CRLF = "\x[0D]\x[0A]"; # new -my $h = HTTP::Header::Strict.new(a => "A", b => "B"); +my $h = HTTP::Header.new(:strict, a => "A", b => "B"); is ~$h.field('b'), 'B', 'new'; @@ -36,8 +37,8 @@ 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, "a: a, a2, a3\nb: B\n", 'Str 1/2'; -is-deeply $h.Str('|'), 'a: a, a2, a3|b: B|', 'Str 2/2'; +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'); @@ -47,22 +48,22 @@ ok not $h.field('a'), 'remove-field 1/1'; $h.clear; ok not $h.field('b'), 'clear 1/1'; -$h = HTTP::Header::Strict.new(One => "one", Two => "two"); +$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::Strict.new(); +$h = HTTP::Header.new: :strict; -lives-ok { $h.parse('ETag: W/"1201-51b0ce7ad3900"') }, "parses ETag"; +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') }, "parses date on a Wed"; +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') }, "parses ETag like"; +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 { @@ -86,8 +87,8 @@ 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::Strict.new; - $h.parse($htest); + 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'; diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index e518d4f..856d3ab 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -1,6 +1,6 @@ use Test; -use HTTP::UA::Strict; +use HTTP::UserAgent; plan 23; @@ -9,16 +9,12 @@ my constant $CRLF = "\x[0d]\x[0a]"; ################################################################################ # new -# is HTTP::Message.^name, 'HTTP::Message::Strict', 'strict import'; -is HTTP::Message::Strict.^name, 'HTTP::Message::Strict', 'can use strict explicitly'; +my $m = HTTP::Message.new('somecontent', :strict, a => ['a1', 'a2']); -my $m = HTTP::Message::Strict.new('somecontent', a => ['a1', 'a2']); - -# isa-ok $m, HTTP::Message, 'new 1/5'; -# isa-ok $m.header, HTTP::Header, 'new 2/5'; -isa-ok $m.header, HTTP::Header::Strict, 'new 3/5'; -is $m.field('a'), 'a1, a2', 'new 4/5'; -is $m.content, 'somecontent', 'new 5/5'; +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'); @@ -41,27 +37,26 @@ nok $m.field('a'), 'remove-field 1/1'; # 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\r\na: b, c\r\na: d\r\n" - ~ "\r\nline\r\n"; -$m.parse($to_parse); +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', 'parse 3/4'; -is $m.content, "line\r\n", 'parse 3/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, "a: b, c, d\r\nContent-Length: 6\r\n\r\nline\r\n", 'Str'; +is $m.Str(:strict), "a: b, c, d{$CRLF}Content-Length: 6{$CRLF x 2}line$CRLF", 'Str'; # clear $m.clear; -is $m.Str, "\r\n", 'clear 1/2 - body-less messages require final CRLF'; +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::Strict.new; +my $m2 = HTTP::Message.new: :strict; # parse $to_parse = "HTTP/1.1 200 OK\r\n" @@ -84,7 +79,7 @@ $to_parse = "HTTP/1.1 200 OK\r\n" ~ "# Last updated Sat May 31 16:39:01 2014 (UTC)\n" ~ "# \n" ~ "# Explanation of the syntax:\n"; -$m2.parse($to_parse); +$m2.parse($to_parse, :strict); # quotes generally not considered part of the content. please see # RFC 9110, section 5.5, second-to-last paragraph @@ -97,20 +92,14 @@ 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::Strict.new.charset, 'iso-8859-1', "dumb default charset"; - is HTTP::Message::Strict.new(Content-Type => 'text/plain').charset, 'iso-8859-1', 'default text charset'; - is HTTP::Message::Strict.new(Content-Type => 'application/xml').charset, 'utf-8', 'default "non-text" charset'; - is HTTP::Message::Strict.new(Content-Type => 'text/html; charset=utf-8').charset, 'utf-8', "explicity charset"; + 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"; ################################################################################ -# construct request - move to request 042-request-issue-226.rakutest -# my $m = HTTP::Message::Strict.new: -# 'four', -# Content-Type => 'text/plain', -# Transfer-Encoding => 'chunked' -# ; subtest { plan 8; my Str:D $to-parse = join $CRLF, @@ -123,7 +112,7 @@ subtest { '0', # last chunk $CRLF, # end of chunk body ; # FIXME : does not test: trailer, chunk extension, binary - my HTTP::Request::Strict:D $m = HTTP::Request::Strict.new.parse: $to-parse; + 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'; @@ -141,7 +130,7 @@ subtest { '- four' # chunk data ; - is $m.Str, $expected, 'Str'; + is $m.Str(:strict), $expected, 'Str'; # add-content $m.add-content: "\n- five"; @@ -154,7 +143,7 @@ subtest { '', # end of header "- four\n- five", # content ; # FIXME : does not test: trailer, chunk extension, binary - is $m.Str, $expected, 'non-chunked Str'; + is $m.Str(:strict), $expected, 'non-chunked Str'; }, 'chunked request'; @@ -166,12 +155,12 @@ subtest { ~ "Content-Length: 3\r\n" ~ "\r\n" ~ "a\nb"; - my HTTP::Response::Strict:D $m2 = HTTP::Response::Strict.new.parse($to_parse); + my HTTP::Response:D $m2 = HTTP::Response.new(: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, $to_parse, 'non-chunked Str'; + is $m2.Str(:strict), $to_parse, 'non-chunked Str'; }, 'parse non-chunked response'; @@ -179,15 +168,16 @@ subtest { subtest { plan 3; # parse - my Str:D $to_parse = "HTTP/1.1 200 OK\r\n" - ~ "Transfer-Encoding: chunked\r\n" - ~ "\r\n" - ~ "3\r\n" - ~ "a\nb\r\n" - ~ "0\r\n" - ~ "\r\n" - ; - my HTTP::Response::Strict:D $m2 = HTTP::Response::Strict.new.parse($to_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(:strict).parse($to_parse, :strict); ok $m2.is-text, 'text'; nok $m2.is-binary, 'not binary'; @@ -200,7 +190,7 @@ subtest { "a\nb", # chunk data ; - is $m2.Str, $expected, 'Str'; + 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 index c3e2a02..f99c123 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -1,9 +1,9 @@ use Test; use URI; -use HTTP::UA::Strict; +use HTTP::UserAgent; -plan 29; +plan 27; my constant $CRLF = "\x[0D]\x[0A]"; @@ -14,16 +14,14 @@ my $file = '/cat/f.h?q=1&q=2'; my $host = 'testsite.ext'; # new -my $r1 = HTTP::Request::Strict.new(POST => $url, test_field => 'this_is_field'); +my $r1 = HTTP::Request.new(POST => $url, :strict, test_field => 'this_is_field'); -is $r1.method, 'post'.uc, 'new 1/8'; -is $r1.url, $url, 'new 2/8'; -is $r1.file, $file, 'new 3/8'; -is $r1.field('Host'), $host, 'new 4/8'; -is $r1.field('test_field'), 'this_is_field', 'new 5/8'; -ok $r1.Str ~~ /^POST\s$file/, 'new 6/8'; -isa-ok $r1, HTTP::Request::Strict, 'new 7/8'; -isa-ok $r1, HTTP::Message::Strict, 'new 8/8'; +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'); @@ -56,18 +54,18 @@ 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::Strict.new.parse($req); +$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, $exp, 'parse 6/6'; +is $r1.Str(:strict), $exp, 'parse 6/6'; subtest { my $r; - lives-ok { $r = HTTP::Request::Strict.new('GET', URI.new('http://foo.com/bar'), HTTP::Header.new(Foo => 'bar') ) }, "mew with positionals"; + 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'; @@ -75,7 +73,7 @@ subtest { subtest { subtest { - my $req = HTTP::Request::Strict.new(POST => URI.new('http://127.0.0.1/')); + my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/'), :strict); 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'; @@ -83,7 +81,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with positional Hash'; subtest { - my $req = HTTP::Request::Strict.new(POST => URI.new('http://127.0.0.1/')); + my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/'), :strict); 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'; @@ -91,7 +89,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with slurpy hash'; subtest { - my $req = HTTP::Request::Strict.new(POST => 'http://127.0.0.1/', X-Foo => 'Bar'); + my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', X-Foo => 'Bar', :strict); 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'; @@ -101,20 +99,20 @@ subtest { }, 'content by array'; subtest { # need to set the host up front so it compares with the data nicely - my $req = HTTP::Request::Strict.new(POST => 'http://127.0.0.1/', Host => '127.0.0.1', content-type => 'multipart/form-data; boundary=XxYyZ'); + my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', Host => '127.0.0.1', :strict, 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::Strict.new(POST => 'http://127.0.0.1/'); + my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', :strict); 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, /"multipart\/form-data"/, "and got multipart data"; + like $req.header.field('content-type').Str, rx|'multipart/form-data'|, "and got multipart data"; }, 'multipart explicit'; subtest { - my $req = HTTP::Request::Strict.new(POST => 'http://127.0.0.1/'); + my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', :strict); 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, /"multipart\/form-data"/, "and got multipart 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'; @@ -132,10 +130,9 @@ my Str:D $expected = join $CRLF, "- four\n- five", # content ; # FIXME : does not test: trailer, chunk extension, binary -my HTTP::Request::Strict $r = - HTTP::Request::Strict.new: - POST => $url; +my HTTP::Request $r = + HTTP::Request.new: POST => $url, :strict; $r.add-content: "- four\n- five"; -is $r.Str, $expected, 'build non-chunked post'; +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 index 2abdf9f..ce1ceab 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -1,19 +1,17 @@ use Test; -use HTTP::UA::Strict; +use HTTP::UserAgent; -plan 29; +plan 27; my constant $CRLF = "\x[0D]\x[0A]"; ############################################################################### # new -my $r = HTTP::Response::Strict.new(200, a => 'a'); +my $r = HTTP::Response.new(200, :strict, a => 'a'); -isa-ok $r, HTTP::Response::Strict, 'new 1/3'; -isa-ok $r, HTTP::Message::Strict, 'new 2/3'; -is $r.field('a'), 'a', 'new 3/3'; +is $r.field('a'), 'a', 'new'; # field $r.field(h => 'h'); @@ -38,7 +36,7 @@ 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::Strict.new.parse($res); +$r = HTTP::Response.new(: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'; @@ -46,22 +44,22 @@ is $r.protocol, 'HTTP/1.1', 'parse - protocol 4/4'; # has-content -$r = HTTP::Response::Strict.new(204); +$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, 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, 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, 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, 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, 10, 65, 99, 99, 101, 112, 116, 45, 82, 97, 110, 103, 101, 115, 58, 32, 98, 121, 116, 101, 115, 10, 67, 111, 110, 116, 101, 110, 116, 45, 76, 101, 110, 103, 116, 104, 58, 32, 52, 54, 48, 57, 10, 67, 111, 110, 110, 101, 99, 116, 105, 111, 110, 58, 32, 99, 108, 111, 115, 101, 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, 10, 10, 10); +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::Strict.new($buf) }, "create Response::Strict from a Buf"; +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::Strict.new(200, Content-Length => "hsh") }, "create a response with a Content-Length"; +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::Strict.new(200, Content-Length => "888") }, "create a response with a Content-Length"; +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"; @@ -71,44 +69,23 @@ subtest { throws-like { $r = HTTP::Response.new(Buf.new) }, 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::Strict.new($garbage); + $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::Strict.new: "HTTP/1.1 200 OK\r\nX-Duck: 🦆\r\n".encode; + 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::Strict.new; -# my Str:D $expected = join $CRLF, -# 'HTTP/1.1 200 OK', # status line -# 'Content-Type: text/plain', # header -# 'Transfer-Encoding: chunked', # header -# '', # end header -# '7', # chunk size -# 'content', # chunk data -# '0', # last chunk -# $CRLF # end chunk body -# ; -# $r.field: Content-Type => 'text/plain', Transfer-Encoding => 'chunked'; -# $r.add-content: 'content'; -# ok $r.is-text, 'is text'; -# nok $r.is-binary, 'not binary'; -# is $r.content, 'content', 'content'; -# is $r.Str, $expected, 'Str'; -# }, 'build chunked Str'; - subtest { plan 4; - my $r = HTTP::Response::Strict.new; + my $r = HTTP::Response.new: :strict; my Str:D $expected = join $CRLF, 'HTTP/1.1 200 OK', # status line 'Content-Length: 7', # header @@ -121,7 +98,7 @@ subtest { ok $r.is-text, 'is text'; nok $r.is-binary, 'not binary'; is $r.content, 'content', 'content'; - is $r.Str, $expected, 'Str'; + is $r.Str(:strict), $expected, 'Str'; }, 'build non-chunked Str'; # vim: expandtab shiftwidth=4 diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest index 552dc67..b95c909 100644 --- a/t/081-ua-strict.rakutest +++ b/t/081-ua-strict.rakutest @@ -1,42 +1,42 @@ -use HTTP::UA::Strict; +use HTTP::UserAgent; use HTTP::UserAgent::Common; use Test; use URI; -plan 11; +plan 8; # new -my $ua = HTTP::UserAgent::Strict.new; +my $ua = HTTP::UserAgent.new: :strict; nok $ua.useragent, 'new 1/3'; -$ua = HTTP::UserAgent::Strict.new(:useragent('test')); +$ua = HTTP::UserAgent.new: useragent => 'test', :strict; is $ua.useragent, 'test', 'new 2/3'; my $newua = get-ua('chrome_linux'); -$ua = HTTP::UserAgent::Strict.new(:useragent('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').content, /$newua/, 'useragent 1/1'; + 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/'); + my $response = $ua.get('github.com/', :strict); ok $response, 'get 1/3'; - isa-ok $response, HTTP::Response::Strict, 'get 2/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::Strict.new.get('http://www.baidu.com') }, 'Lived through gb2312 encoding'; + 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::Strict.new.get('http://rakudo.org') }, "issue#51 - get rakudo.org (chunked encoding foul-up results in incomplete UTF-8 data)"; +# 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; @@ -49,12 +49,12 @@ if %*ENV { my $uri = 'http://httpbin.org/post'; my %data = (foo => 'bar', baz => 'quux'); - subtest { - my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; + subtest { + my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; my %data = :72foo, :bar<♵>; - my $ua = HTTP::UserAgent::Strict.new; + my $ua = HTTP::UserAgent.new: :strict; my $res; - lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "new make post"; + lives-ok { $res = $ua.post(URI.new($uri), %data, :strict, X-Foo => "foodle") }, "new make post"; my $ret-data; if $have-json { @@ -69,9 +69,9 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent::Strict.new; + my $ua = HTTP::UserAgent.new: :strict; my $res; - lives-ok { $res = $ua.post(URI.new($uri), %data, X-Foo => "foodle") }, "make post"; + lives-ok { $res = $ua.post(URI.new($uri), %data, :strict, X-Foo => "foodle") }, "make post"; my $ret-data; if $have-json { @@ -86,9 +86,9 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent::Strict.new; + my $ua = HTTP::UserAgent.new: :strict; my $res; - lives-ok { $res = $ua.post($uri, %data, X-Foo => "foodle") }, "make post"; + 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"; @@ -105,7 +105,7 @@ if %*ENV { }, "post"; } else { - skip "NETWORK_TESTING not set", 8; + skip "NETWORK_TESTING not set", 5; } # vim: expandtab shiftwidth=4 From a3a177f980955379d697b17de2abd5a4b6e141df Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 7 Feb 2026 05:27:58 -0800 Subject: [PATCH 22/28] remove redundant attr; fix new; fix strict print logic; add interop tests --- lib/HTTP/Request.rakumod | 7 ++-- lib/HTTP/UserAgent.rakumod | 4 +- t/081-ua-strict-interop.rakutest | 66 ++++++++++++++++++++++++++++++++ t/081-ua-strict.rakutest | 2 +- t/110-redirect-cookies.rakutest | 4 +- t/lib/TestServer.rakumod | 28 ++++++++++++++ 6 files changed, 103 insertions(+), 8 deletions(-) create mode 100644 t/081-ua-strict-interop.rakutest diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index da42df0..a97563b 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -16,7 +16,6 @@ has $.uri is rw; has Str $.host is rw; has Int $.port is rw; has Str $.scheme is rw; -has Bool $.strict is rw; my constant $CRLF = "\x[0D]\x[0A]"; @@ -42,7 +41,7 @@ multi method new(Bool :$bin, Bool :$strict, *%args) { self.new($method // 'GET', $uri, $header, :$bin, :$strict); } else { - self.bless + self.bless: :$strict; } } @@ -268,14 +267,14 @@ method make-boundary(int $size=10) { method Str (:$debug, Bool :$bin, Bool :$strict is copy) { - $strict ||= $!strict; + $strict ||= $.strict; $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; join $CRLF, $s, callwith $CRLF, :$debug, :$bin, :$strict; } method parse($raw_request, Bool :$strict is copy) { - $strict ||= $!strict; + $strict ||= $.strict; my @lines = $raw_request.split($CRLF); ($.method, $.file) = @lines.shift.split(' '); diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index caaffcd..9b4ca95 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -23,8 +23,8 @@ role Connection { self.print($request.Str(:bin)); self.write($request.content); } - elsif $strict { - self.print: $request.Str; + elsif $strict or $request.strict { + self.print: $request.Str: :strict; } else { self.print($request.Str ~ "\r\n"); diff --git a/t/081-ua-strict-interop.rakutest b/t/081-ua-strict-interop.rakutest new file mode 100644 index 0000000..0e77668 --- /dev/null +++ b/t/081-ua-strict-interop.rakutest @@ -0,0 +1,66 @@ +use lib ; + +use Test; +use HTTP::UserAgent; +use HTTP::Request; +use Test::Util::ServerPort; +use TestServer; + +my constant $CRLF = "\x[0D]\x[0A]"; + +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: :!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; + ( $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: :!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 index b95c909..d10099c 100644 --- a/t/081-ua-strict.rakutest +++ b/t/081-ua-strict.rakutest @@ -4,7 +4,7 @@ use Test; use URI; -plan 8; +plan 11; # new my $ua = HTTP::UserAgent.new: :strict; diff --git a/t/110-redirect-cookies.rakutest b/t/110-redirect-cookies.rakutest index f931622..2d4ccf2 100644 --- a/t/110-redirect-cookies.rakutest +++ b/t/110-redirect-cookies.rakutest @@ -1,10 +1,12 @@ +use lib ; + use HTTP::UserAgent; use Test::Util::ServerPort; use Test; my $port = get-unused-port(); -use lib $*PROGRAM.sibling('lib').Str; +# use lib $*PROGRAM.sibling('lib').Str; use TestServer; %*ENV = 'localhost'; diff --git a/t/lib/TestServer.rakumod b/t/lib/TestServer.rakumod index 733baf5..70cb2a6 100644 --- a/t/lib/TestServer.rakumod +++ b/t/lib/TestServer.rakumod @@ -62,6 +62,34 @@ module TestServer { } $server-promise } + + use HTTP::Request; + 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 From 9f09027a1cfe92af738b363f4ff765cb4c447ecc Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 7 Feb 2026 05:32:18 -0800 Subject: [PATCH 23/28] TestServer location --- t/110-redirect-cookies.rakutest | 2 +- t/230-binary-request.rakutest | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/t/110-redirect-cookies.rakutest b/t/110-redirect-cookies.rakutest index 2d4ccf2..82848f1 100644 --- a/t/110-redirect-cookies.rakutest +++ b/t/110-redirect-cookies.rakutest @@ -1,4 +1,4 @@ -use lib ; +use lib ; use HTTP::UserAgent; use Test::Util::ServerPort; diff --git a/t/230-binary-request.rakutest b/t/230-binary-request.rakutest index 583ba87..8f745b3 100644 --- a/t/230-binary-request.rakutest +++ b/t/230-binary-request.rakutest @@ -1,3 +1,5 @@ +use lib ; + use HTTP::UserAgent; use HTTP::Request::Common; use Test::Util::ServerPort; @@ -6,7 +8,7 @@ use Test; plan 6; -use lib $*PROGRAM.sibling('lib').Str; +# use lib $*PROGRAM.sibling('lib').Str; use TestServer; %*ENV = 'localhost'; From d18d28427f3332f7a31f7f61c55e341b8623c5c8 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sat, 14 Feb 2026 13:47:50 -0800 Subject: [PATCH 24/28] pre strict sig change --- lib/HTTP/Header.rakumod | 6 +++--- lib/HTTP/Message.rakumod | 22 +++++++++++++--------- lib/HTTP/Request.rakumod | 10 +++++----- lib/HTTP/Response.rakumod | 5 ++--- lib/HTTP/UserAgent.rakumod | 18 ++++++------------ t/081-ua-strict-interop.rakutest | 11 ++++++++++- t/081-ua-strict.rakutest | 2 +- t/110-redirect-cookies.rakutest | 4 +--- t/230-binary-request.rakutest | 4 +--- 9 files changed, 42 insertions(+), 40 deletions(-) diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 1b9f0e0..3c2ae79 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -133,7 +133,7 @@ our class HTTP::Header::Actions { } # we want to pass arguments like this: .new(a => 1, b => 2 ...) -method new(Bool :$strict, *%fields) { +method new(Bool $strict = False, *%fields) { my @fields = %fields.sort(*.key).map: { HTTP::Header::Field.new(:name(.key), :values(.value.list)); } @@ -213,8 +213,8 @@ method Str($eol is copy = "\n", Bool :$strict) { @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } -method parse($raw, Bool :$strict) { - if $!strict or $strict { +method parse($raw, Bool :$strict = $!strict) { + if $strict { my $*OBJ = self; Grammar::Strict.parse: $raw, actions => Actions::Strict; } else { diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index ba2e866..029c77d 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -16,12 +16,18 @@ has Str @.text-types; my constant $CRLF = "\x[0d]\x[0a]"; my constant $DELIM = $CRLF x 2; -method new($content?, Bool :$strict, *%fields) { +multi method new($content, Bool $strict = False, *%fields) { my $header = HTTP::Header.new(:$strict, |%fields); self.bless(:$header, :$content, :$strict); } +multi method new(Bool $strict = False, *%fields) { + my $header = HTTP::Header.new(:$strict, |%fields); + + self.bless(:$header, :$strict); +} + method add-content($content) { $.content ~= $content; } @@ -193,7 +199,7 @@ method clear { $.content = '' } -method !parse ( $raw_message ) { +method !parse-strict ( $raw_message ) { my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; my ( $fields, $content ) = $rest.split: $DELIM, 2; @@ -205,7 +211,6 @@ method !parse ( $raw_message ) { $.protocol = $first; } - # $.header = HTTP::Header::Strict.new; $.header.parse: $fields, :strict; return self unless $content; @@ -217,7 +222,7 @@ method !parse ( $raw_message ) { @lines.pop if @lines %2; @lines = grep *, @lines.map: - -> $d, $s { $d ~~ /^\d/ ?? $s !! Str } + -> $d, $s { $d ~~ /^<[0..9]>/ ?? $s !! Str } ; $.content = @lines.join; } else { @@ -228,7 +233,7 @@ method !parse ( $raw_message ) { } method parse($raw_message, Bool :$strict) { - return self!parse: $raw_message if $!strict or $strict; + return self!parse-strict: $raw_message if $!strict or $strict; my @lines = $raw_message.split(/$CRLF/); @@ -263,20 +268,19 @@ method parse($raw_message, Bool :$strict) { self } -method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict is copy) { - $strict ||= $!strict; +method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict = $!strict) { $eol = $CRLF if $strict; my constant $max_size = 300; 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 unless $strict or not $.content; + $s ~= $eol if $!content and not $strict; # The :bin will be passed from the H::UA if not $bin { if $strict { - $s = join $CRLF, $s, $.content || ''; + $s ~= $CRLF ~ ( $.content || '' ); } else { $s ~= $.content ~ $eol if $.content and !$debug; } diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index a97563b..183e8b5 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -17,6 +17,8 @@ has Str $.host is rw; has Int $.port is rw; has Str $.scheme is rw; +has Bool $.strict is rw; + my constant $CRLF = "\x[0D]\x[0A]"; my $HRC_DEBUG = %*ENV.Bool; @@ -266,15 +268,13 @@ method make-boundary(int $size=10) { } -method Str (:$debug, Bool :$bin, Bool :$strict is copy) { - $strict ||= $.strict; +method Str (:$debug, Bool :$bin, Bool :$strict = $!strict) { $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; - join $CRLF, $s, callwith $CRLF, :$debug, :$bin, :$strict; + $s ~ $CRLF ~ callwith $CRLF, :$debug, :$bin, :$strict; } -method parse($raw_request, Bool :$strict is copy) { - $strict ||= $.strict; +method parse($raw_request, Bool :$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 c9c3c18..0973cfb 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -106,10 +106,9 @@ method next-request(--> HTTP::Request:D) { $new-request } -method Str(:$debug, Bool :$strict is copy) { - $strict ||= $!strict; +method Str(:$debug, Bool :$strict = $!strict) { my $s = $.protocol ~ " " ~ $!status-line; - join $CRLF, $s, callwith $CRLF, :$debug, :$strict; + $s ~ $CRLF ~ callwith $CRLF, :$debug, :$strict; } # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 9b4ca95..8945f71 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -100,8 +100,7 @@ method auth(Str $login, Str $password) { proto method get(|) {*} -multi method get(URI $uri is copy, Bool :$bin, Bool :$strict is copy, *%header ) { - $strict ||= $!strict; +multi method get(URI $uri is copy, Bool :$bin, Bool :$strict = $!strict, *%header ) { my $request = HTTP::Request.new(GET => $uri, :$strict, |%header); self.request($request, :$bin, :$strict) } @@ -112,8 +111,7 @@ multi method get(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { proto method post(|) {*} -multi method post(URI $uri is copy, %form , Bool :$bin, Bool :$strict is copy, *%header) { - $strict ||= $!strict; +multi method post(URI $uri is copy, %form , Bool :$bin, Bool :$strict = $!strict, *%header) { my $request = HTTP::Request.new(POST => $uri, :$strict, |%header); $request.add-form-data(%form); self.request($request, :$bin, :$strict) @@ -126,8 +124,7 @@ multi method post(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) proto method put(|) {*} -multi method put(URI $uri is copy, %form , Bool :$bin, Bool :$strict is copy, *%header) { - $strict ||= $!strict; +multi method put(URI $uri is copy, %form , Bool :$bin, Bool :$strict = $!strict, *%header) { my $request = HTTP::Request.new(PUT => $uri, :$strict, |%header); $request.add-form-data(%form); self.request($request, :$bin, :$strict) @@ -139,8 +136,7 @@ multi method put(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) proto method delete(|) {*} -multi method delete(URI $uri is copy, Bool :$bin, Bool :$strict is copy, *%header ) { - $strict ||= $!strict; +multi method delete(URI $uri is copy, Bool :$bin, Bool :$strict = $!strict, *%header ) { my $request = HTTP::Request.new(DELETE => $uri, :$strict, |%header); self.request($request, :$bin, :$strict) } @@ -149,8 +145,7 @@ multi method delete(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { self.delete(URI.new(_clear-url($uri)), :$bin, :$strict, |%header) } -method request(HTTP::Request $request, Bool :$bin, Bool :$strict is copy --> HTTP::Response:D) { - $strict ||= $!strict; +method request(HTTP::Request $request, Bool :$bin, Bool :$strict = $!strict --> HTTP::Response:D) { my HTTP::Response $response; # add cookies to the request @@ -270,8 +265,7 @@ method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { $content } -method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool :$strict is copy --> HTTP::Response:D) { - $strict ||= $!strict; +method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool :$strict = $!strict --> HTTP::Response:D) { my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; diff --git a/t/081-ua-strict-interop.rakutest b/t/081-ua-strict-interop.rakutest index 0e77668..31b1130 100644 --- a/t/081-ua-strict-interop.rakutest +++ b/t/081-ua-strict-interop.rakutest @@ -8,7 +8,7 @@ use TestServer; my constant $CRLF = "\x[0D]\x[0A]"; -plan 3; +plan 4; my $port = get-unused-port; @@ -61,6 +61,15 @@ subtest { is $lok, 'T', 'UA:strict with Message:!strict - length matches'; }, 'UA:strict is still strict with Message:!strict'; +subtest { + plan 2; + my $uas = HTTP::UserAgent.new: :strict; + my $rs = $uas.delete: "http://localhost:$port/DELETE"; + my ( $eol, $lok ) = $rs.content.split: "\x0d"; + is $eol, 'F', 'no extra eol'; + is $lok, 'T', 'length matches'; +}, 'UA:strict delete'; + $done-promise.keep: 'shutdown'; # UA:strict with Message:!strict diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest index d10099c..5480f55 100644 --- a/t/081-ua-strict.rakutest +++ b/t/081-ua-strict.rakutest @@ -105,7 +105,7 @@ if %*ENV { }, "post"; } else { - skip "NETWORK_TESTING not set", 5; + skip "NETWORK_TESTING not set", 8; } # vim: expandtab shiftwidth=4 diff --git a/t/110-redirect-cookies.rakutest b/t/110-redirect-cookies.rakutest index 82848f1..f931622 100644 --- a/t/110-redirect-cookies.rakutest +++ b/t/110-redirect-cookies.rakutest @@ -1,12 +1,10 @@ -use lib ; - use HTTP::UserAgent; use Test::Util::ServerPort; use Test; my $port = get-unused-port(); -# use lib $*PROGRAM.sibling('lib').Str; +use lib $*PROGRAM.sibling('lib').Str; use TestServer; %*ENV = 'localhost'; diff --git a/t/230-binary-request.rakutest b/t/230-binary-request.rakutest index 8f745b3..583ba87 100644 --- a/t/230-binary-request.rakutest +++ b/t/230-binary-request.rakutest @@ -1,5 +1,3 @@ -use lib ; - use HTTP::UserAgent; use HTTP::Request::Common; use Test::Util::ServerPort; @@ -8,7 +6,7 @@ use Test; plan 6; -# use lib $*PROGRAM.sibling('lib').Str; +use lib $*PROGRAM.sibling('lib').Str; use TestServer; %*ENV = 'localhost'; From c725a7fe7dd5b0105a1b9c8a77610bd426ad631f Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sun, 15 Feb 2026 22:09:11 -0800 Subject: [PATCH 25/28] refactor Message parse methods; make $strict default to $!strict in Header --- lib/HTTP/Header.rakumod | 4 +-- lib/HTTP/Message.rakumod | 73 +++++++++++++++++++--------------------- 2 files changed, 36 insertions(+), 41 deletions(-) diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 3c2ae79..163a2ac 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -208,8 +208,8 @@ method clear() { } # get header as string -method Str($eol is copy = "\n", Bool :$strict) { - $eol = $CRLF if $!strict or $strict; +method Str($eol is copy = "\n", Bool :$strict = $!strict) { + $eol = $CRLF if $strict; @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 029c77d..63e3ddb 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -15,6 +15,7 @@ has Str @.text-types; my constant $CRLF = "\x[0d]\x[0a]"; my constant $DELIM = $CRLF x 2; +my constant $STRICT = True; # prepare for assoc. strict to positional strict multi method new($content, Bool $strict = False, *%fields) { my $header = HTTP::Header.new(:$strict, |%fields); @@ -199,21 +200,9 @@ method clear { $.content = '' } -method !parse-strict ( $raw_message ) { - my ( $start-line, $rest ) = $raw_message.split: $CRLF, 2; - my ( $fields, $content ) = $rest.split: $DELIM, 2; - - my ($first, $second, $third) = $start-line.split(/\s+/); - if $third.index('/') { # is a request - $.protocol = $third; - } - else { # is a response - $.protocol = $first; - } - - $.header.parse: $fields, :strict; - return self unless $content; - +# 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; @@ -228,43 +217,49 @@ method !parse-strict ( $raw_message ) { } else { $.content = $content; } - - self } -method parse($raw_message, Bool :$strict) { - return self!parse-strict: $raw_message if $!strict or $strict; - - my @lines = $raw_message.split(/$CRLF/); - - my ($first, $second, $third) = @lines.shift.split(/\s+/); - +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 = $!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 = $content; + } self } From ed51d784a0206b31fd8f3cb25cb8d30693fa79f2 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Sun, 15 Feb 2026 22:20:16 -0800 Subject: [PATCH 26/28] pass $strict when sending binary request, too --- lib/HTTP/UserAgent.rakumod | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 8945f71..fe4a4ac 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -17,13 +17,13 @@ constant CRLF = Buf.new(13, 10); # placeholder role to make signatures nicer # and enable greater abstraction role Connection { - method send-request(HTTP::Request $request, Bool :$strict) { + 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(:bin, :$strict)); self.write($request.content); } - elsif $strict or $request.strict { + elsif $strict { self.print: $request.Str: :strict; } else { From 9a38dca686ea7879f27e6765b2c42e5c299f9f9c Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Mon, 16 Feb 2026 12:26:46 -0800 Subject: [PATCH 27/28] preliminary sig changes --- lib/HTTP/Header.rakumod | 6 ++++-- lib/HTTP/Message.rakumod | 14 ++++++++------ lib/HTTP/Request.rakumod | 18 +++++++++--------- lib/HTTP/Response.rakumod | 13 +++++++++---- lib/HTTP/UserAgent.rakumod | 21 +++++++++++++-------- t/011-headers-strict.rakutest | 9 +++++---- t/021-message-issue-226.rakutest | 19 ++++++++++--------- t/042-request-issue-226.rakutest | 19 ++++++++++--------- t/051-response-issue-226.rakutest | 21 +++++++++++---------- t/081-ua-strict-interop.rakutest | 9 +++++---- 10 files changed, 84 insertions(+), 65 deletions(-) diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 163a2ac..37070b2 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -208,12 +208,14 @@ method clear() { } # get header as string -method Str($eol is copy = "\n", Bool :$strict = $!strict) { +method Str($eol is copy = "\n", Bool :$strict is copy) { + $strict ||= $!strict; $eol = $CRLF if $strict; @.fields.map({ "$_.name(): {self.field($_.name)}$eol" }).join } -method parse($raw, Bool :$strict = $!strict) { +method parse($raw, Bool :$strict is copy) { + $strict ||= $!strict; if $strict { my $*OBJ = self; Grammar::Strict.parse: $raw, actions => Actions::Strict; diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 63e3ddb..41e0ad8 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -18,13 +18,13 @@ my constant $DELIM = $CRLF x 2; my constant $STRICT = True; # prepare for assoc. strict to positional strict multi method new($content, Bool $strict = False, *%fields) { - my $header = HTTP::Header.new(:$strict, |%fields); + my $header = HTTP::Header.new($strict, |%fields); self.bless(:$header, :$content, :$strict); } -multi method new(Bool $strict = False, *%fields) { - my $header = HTTP::Header.new(:$strict, |%fields); +multi method new(Bool $strict = False, *%fields) is default { + my $header = HTTP::Header.new($strict, |%fields); self.bless(:$header, :$strict); } @@ -250,7 +250,8 @@ method !parse-header-strict($header) { $!header.parse($header, :strict); } -method parse($raw_message, Bool :$strict = $!strict) { +method parse($raw_message, Bool :$strict is copy) { + $strict ||= $!strict; my $rest = self!parse-first($raw_message); my ($header, $content) = $rest.split($DELIM, 2); if $strict { @@ -258,12 +259,13 @@ method parse($raw_message, Bool :$strict = $!strict) { self!parse-content-strict($content) if $content; } else { self!parse-header($header); - $!content = $content; + $!content = join "\n", grep so *, $content.split: $CRLF; } self } -method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict = $!strict) { +method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict is copy) { + $strict ||= $!strict; $eol = $CRLF if $strict; my constant $max_size = 300; diff --git a/lib/HTTP/Request.rakumod b/lib/HTTP/Request.rakumod index 183e8b5..f347cc6 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -25,7 +25,7 @@ my $HRC_DEBUG = %*ENV.Bool; proto method new(|) {*} -multi method new(Bool :$bin, Bool :$strict, *%args) { +multi method new(Bool $strict = False, Bool :$bin, *%args) { if %args { my ($method, $url, $file, %fields, $uri); @@ -39,17 +39,15 @@ multi method new(Bool :$bin, Bool :$strict, *%args) { } } - my $header = HTTP::Header.new(:$strict, |%fields); - self.new($method // 'GET', $uri, $header, :$bin, :$strict); + my $header = HTTP::Header.new($strict, |%fields); + self.new($method // 'GET', $uri, $header, $strict, :$bin); } else { - self.bless: :$strict; + self.bless: :$strict, :$bin; } } -multi method new(Bool :$strict) { self.bless: :$strict } - -multi method new(RequestMethod $method, URI $uri, HTTP::Header $header, Bool :$bin, Bool :$strict) { +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 || '/'; @@ -268,13 +266,15 @@ method make-boundary(int $size=10) { } -method Str (:$debug, Bool :$bin, Bool :$strict = $!strict) { +method Str (:$debug, Bool :$bin, Bool :$strict is copy) { + $strict ||= $!strict; $.file = '/' ~ $.file unless $.file.starts-with: '/'; my $s = "$.method $.file $.protocol"; $s ~ $CRLF ~ callwith $CRLF, :$debug, :$bin, :$strict; } -method parse($raw_request, Bool :$strict = $!strict) { +method parse($raw_request, Bool :$strict is copy) { + $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 0973cfb..40f8887 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -19,7 +19,7 @@ submethod BUILD(:$!code) { proto method new(|) {*} # This candidate makes it easier to test weird responses -multi method new(Blob:D $header-chunk, Bool :$strict) { +multi method new(Blob:D $header-chunk, Bool $strict = False) { # See https://tools.ietf.org/html/rfc7230#section-3.2.4 my ($rl, $header); if $strict { @@ -39,8 +39,12 @@ multi method new(Blob:D $header-chunk, Bool :$strict) { $response } -multi method new(Int:D $code = 200, Bool :$strict, *%fields) { - my $header = HTTP::Header.new(:$strict, |%fields); +multi method new(Int:D $code = 200, *%fields) { + 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); } @@ -106,7 +110,8 @@ method next-request(--> HTTP::Request:D) { $new-request } -method Str(:$debug, Bool :$strict = $!strict) { +method Str(:$debug, Bool :$strict is copy) { + $strict ||= $!strict; my $s = $.protocol ~ " " ~ $!status-line; $s ~ $CRLF ~ callwith $CRLF, :$debug, :$strict; } diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index fe4a4ac..345c550 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -100,7 +100,8 @@ method auth(Str $login, Str $password) { proto method get(|) {*} -multi method get(URI $uri is copy, Bool :$bin, Bool :$strict = $!strict, *%header ) { +multi method get(URI $uri is copy, Bool :$bin, Bool :$strict is copy, *%header ) { + $strict ||= $!strict; my $request = HTTP::Request.new(GET => $uri, :$strict, |%header); self.request($request, :$bin, :$strict) } @@ -111,20 +112,21 @@ multi method get(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { proto method post(|) {*} -multi method post(URI $uri is copy, %form , Bool :$bin, Bool :$strict = $!strict, *%header) { +multi method post(URI $uri is copy, %form , Bool :$bin, Bool :$strict is copy, *%header) { + $strict ||= $!strict; my $request = HTTP::Request.new(POST => $uri, :$strict, |%header); $request.add-form-data(%form); self.request($request, :$bin, :$strict) } -# should :$bin also be passed along? multi method post(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) { - self.post(URI.new(_clear-url($uri)), %form, :$strict, |%header) + self.post(URI.new(_clear-url($uri)), %form, :$bin, :$strict, |%header) } proto method put(|) {*} -multi method put(URI $uri is copy, %form , Bool :$bin, Bool :$strict = $!strict, *%header) { +multi method put(URI $uri is copy, %form , Bool :$bin, Bool :$strict is copy, *%header) { + $strict ||= $!strict; my $request = HTTP::Request.new(PUT => $uri, :$strict, |%header); $request.add-form-data(%form); self.request($request, :$bin, :$strict) @@ -136,7 +138,8 @@ multi method put(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) proto method delete(|) {*} -multi method delete(URI $uri is copy, Bool :$bin, Bool :$strict = $!strict, *%header ) { +multi method delete(URI $uri is copy, Bool :$bin, Bool :$strict is copy, *%header ) { + $strict ||= $!strict; my $request = HTTP::Request.new(DELETE => $uri, :$strict, |%header); self.request($request, :$bin, :$strict) } @@ -145,7 +148,8 @@ multi method delete(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { self.delete(URI.new(_clear-url($uri)), :$bin, :$strict, |%header) } -method request(HTTP::Request $request, Bool :$bin, Bool :$strict = $!strict --> HTTP::Response:D) { +method request(HTTP::Request $request, Bool :$bin, Bool :$strict is copy --> HTTP::Response:D) { + $strict ||= $!strict; my HTTP::Response $response; # add cookies to the request @@ -265,7 +269,8 @@ method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { $content } -method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool :$strict = $!strict --> HTTP::Response:D) { +method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool :$strict is copy --> HTTP::Response:D) { + $strict ||= $!strict; my Blob[uint8] $first-chunk = Blob[uint8].new; my $msg-body-pos; diff --git a/t/011-headers-strict.rakutest b/t/011-headers-strict.rakutest index 27ccf5f..0ea5086 100644 --- a/t/011-headers-strict.rakutest +++ b/t/011-headers-strict.rakutest @@ -5,9 +5,10 @@ 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"); +my $h = HTTP::Header.new($STRICT, a => "A", b => "B"); is ~$h.field('b'), 'B', 'new'; @@ -48,12 +49,12 @@ ok not $h.field('a'), 'remove-field 1/1'; $h.clear; ok not $h.field('b'), 'clear 1/1'; -$h = HTTP::Header.new(:strict, One => "one", Two => "two"); +$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; +$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"; @@ -87,7 +88,7 @@ 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; + 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'; diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index 856d3ab..44b2b8b 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -5,11 +5,12 @@ 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']); +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'; @@ -56,7 +57,7 @@ is $m.content, '', 'clear 2/2'; ## parse a more complex example # new -my $m2 = HTTP::Message.new: :strict; +my $m2 = HTTP::Message.new: $STRICT; # parse $to_parse = "HTTP/1.1 200 OK\r\n" @@ -92,10 +93,10 @@ 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"; + 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"; ################################################################################ @@ -112,7 +113,7 @@ subtest { '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; + 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'; @@ -155,7 +156,7 @@ subtest { ~ "Content-Length: 3\r\n" ~ "\r\n" ~ "a\nb"; - my HTTP::Response:D $m2 = HTTP::Response.new(:strict).parse($to_parse, :strict); + 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'; @@ -177,7 +178,7 @@ subtest { '0', '' ; - my HTTP::Response:D $m2 = HTTP::Response.new(:strict).parse($to_parse, :strict); + 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'; diff --git a/t/042-request-issue-226.rakutest b/t/042-request-issue-226.rakutest index f99c123..fb7bc8b 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -6,6 +6,7 @@ use HTTP::UserAgent; plan 27; my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; ############################################################################### @@ -14,7 +15,7 @@ my $file = '/cat/f.h?q=1&q=2'; my $host = 'testsite.ext'; # new -my $r1 = HTTP::Request.new(POST => $url, :strict, test_field => 'this_is_field'); +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'; @@ -65,7 +66,7 @@ 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"; + 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'; @@ -73,7 +74,7 @@ subtest { subtest { subtest { - my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/'), :strict); + 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'; @@ -81,7 +82,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with positional Hash'; subtest { - my $req = HTTP::Request.new(POST => URI.new('http://127.0.0.1/'), :strict); + 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'; @@ -89,7 +90,7 @@ subtest { is $req.content.decode, 'foo=b%26r%F0%9F%90%AB'; }, 'add-form-data with slurpy hash'; subtest { - my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', X-Foo => 'Bar', :strict); + 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'; @@ -99,18 +100,18 @@ subtest { }, 'content by array'; subtest { # need to set the host up front so it compares with the data nicely - my $req = HTTP::Request.new(POST => 'http://127.0.0.1/', Host => '127.0.0.1', :strict, content-type => 'multipart/form-data; boundary=XxYyZ'); + 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(POST => 'http://127.0.0.1/', :strict); + 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(POST => 'http://127.0.0.1/', :strict); + 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)'; @@ -131,7 +132,7 @@ my Str:D $expected = join $CRLF, ; # FIXME : does not test: trailer, chunk extension, binary my HTTP::Request $r = - HTTP::Request.new: POST => $url, :strict; + HTTP::Request.new: $STRICT, POST => $url; $r.add-content: "- four\n- five"; is $r.Str(:strict), $expected, 'build non-chunked post'; diff --git a/t/051-response-issue-226.rakutest b/t/051-response-issue-226.rakutest index ce1ceab..400d864 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -5,11 +5,12 @@ 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'); +my $r = HTTP::Response.new(200, $STRICT, a => 'a'); is $r.field('a'), 'a', 'new'; @@ -36,7 +37,7 @@ 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(:strict).parse($res, :strict); +$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'; @@ -44,7 +45,7 @@ is $r.protocol, 'HTTP/1.1', 'parse - protocol 4/4'; # has-content -$r = HTTP::Response.new(204, :strict); +$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"; @@ -53,30 +54,30 @@ 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"; +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"; +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 = 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) }, X::HTTP::NoResponse, "create with an empty buf"; + 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); + $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; + 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'; @@ -85,7 +86,7 @@ subtest { subtest { plan 4; - my $r = HTTP::Response.new: :strict; + my $r = HTTP::Response.new: 200, $STRICT; my Str:D $expected = join $CRLF, 'HTTP/1.1 200 OK', # status line 'Content-Length: 7', # header diff --git a/t/081-ua-strict-interop.rakutest b/t/081-ua-strict-interop.rakutest index 31b1130..dbdf311 100644 --- a/t/081-ua-strict-interop.rakutest +++ b/t/081-ua-strict-interop.rakutest @@ -7,6 +7,7 @@ use Test::Util::ServerPort; use TestServer; my constant $CRLF = "\x[0D]\x[0A]"; +my constant $STRICT = True; plan 4; @@ -20,7 +21,7 @@ say 'using port ', $port; subtest { plan 2; - my $uas = HTTP::UserAgent.new: :strict; + 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'; @@ -29,7 +30,7 @@ subtest { subtest { plan 4; - my $ual = HTTP::UserAgent.new: :!strict; + 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'; @@ -46,7 +47,7 @@ subtest { subtest { plan 4; - my $uas = HTTP::UserAgent.new: :strict; + 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'; @@ -63,7 +64,7 @@ subtest { subtest { plan 2; - my $uas = HTTP::UserAgent.new: :strict; + my $uas = HTTP::UserAgent.new: $STRICT; my $rs = $uas.delete: "http://localhost:$port/DELETE"; my ( $eol, $lok ) = $rs.content.split: "\x0d"; is $eol, 'F', 'no extra eol'; From d3a56b31d405c8da92d92389abe9d544f85a60f4 Mon Sep 17 00:00:00 2001 From: ZacharyMarlow Date: Thu, 19 Feb 2026 07:48:36 -0800 Subject: [PATCH 28/28] final sig changes --- lib/HTTP/Header.rakumod | 7 +++- lib/HTTP/Message.rakumod | 15 ++++--- lib/HTTP/Request.rakumod | 6 +-- lib/HTTP/Response.rakumod | 13 +++--- lib/HTTP/UserAgent.rakumod | 67 +++++++++++++++++-------------- t/011-headers-strict.rakutest | 12 +++--- t/021-message-issue-226.rakutest | 22 +++++----- t/042-request-issue-226.rakutest | 6 +-- t/051-response-issue-226.rakutest | 4 +- t/081-ua-strict-interop.rakutest | 17 ++------ t/081-ua-strict.rakutest | 26 ++++++------ t/lib/TestServer.rakumod | 5 ++- 12 files changed, 103 insertions(+), 97 deletions(-) diff --git a/lib/HTTP/Header.rakumod b/lib/HTTP/Header.rakumod index 37070b2..e1f7180 100755 --- a/lib/HTTP/Header.rakumod +++ b/lib/HTTP/Header.rakumod @@ -208,13 +208,16 @@ method clear() { } # get header as string -method Str($eol is copy = "\n", Bool :$strict is copy) { +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, Bool :$strict is copy) { +method parse($raw, Bool $strict is copy = False) { $strict ||= $!strict; if $strict { my $*OBJ = self; diff --git a/lib/HTTP/Message.rakumod b/lib/HTTP/Message.rakumod index 41e0ad8..7acb32b 100644 --- a/lib/HTTP/Message.rakumod +++ b/lib/HTTP/Message.rakumod @@ -209,7 +209,7 @@ method !parse-content-strict ( $content ) { # pop zero-length Str that occurs after last chunk # what to do if this doesn't happen? @lines.pop if @lines %2; - @lines = grep *, + @lines = grep so *, @lines.map: -> $d, $s { $d ~~ /^<[0..9]>/ ?? $s !! Str } ; @@ -247,15 +247,15 @@ method !parse-header($header) { } method !parse-header-strict($header) { - $!header.parse($header, :strict); + $!header.parse($header, $STRICT); } -method parse($raw_message, Bool :$strict is copy) { +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); + $!header.parse($header, $STRICT); self!parse-content-strict($content) if $content; } else { self!parse-header($header); @@ -264,14 +264,14 @@ method parse($raw_message, Bool :$strict is copy) { self } -method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict is copy) { +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; 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); + my $s = $.header.Str($eol, $strict); $s ~= $eol if $!content and not $strict; # The :bin will be passed from the H::UA @@ -296,5 +296,8 @@ method Str($eol is copy = "\n", :$debug, Bool :$bin, Bool :$strict is copy) { $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 f347cc6..09938d7 100644 --- a/lib/HTTP/Request.rakumod +++ b/lib/HTTP/Request.rakumod @@ -266,14 +266,14 @@ method make-boundary(int $size=10) { } -method Str (:$debug, Bool :$bin, Bool :$strict is copy) { +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, :$strict; + $s ~ $CRLF ~ callwith $CRLF, $strict, :$debug, :$bin; } -method parse($raw_request, Bool :$strict is copy) { +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 40f8887..57efd6f 100644 --- a/lib/HTTP/Response.rakumod +++ b/lib/HTTP/Response.rakumod @@ -30,10 +30,10 @@ multi method new(Blob:D $header-chunk, Bool $strict = False) { X::HTTP::NoResponse.new.throw unless $rl; my $code = (try $rl.split(' ')[1].Int) // 500; - my $response = self.new($code, :$strict); + my $response = self.new($code, $strict); with $header { .=subst: /"\r"?"\n"$$/, '' unless $strict; - $response.header.parse: $header, :$strict; + $response.header.parse: $header, $strict; } $response @@ -78,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; @@ -96,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; @@ -110,10 +111,10 @@ method next-request(--> HTTP::Request:D) { $new-request } -method Str(:$debug, Bool :$strict is copy) { +method Str(Bool $strict is copy = False, :$debug) { $strict ||= $!strict; my $s = $.protocol ~ " " ~ $!status-line; - $s ~ $CRLF ~ callwith $CRLF, :$debug, :$strict; + $s ~ $CRLF ~ callwith $CRLF, $strict, :$debug; } # vim: expandtab shiftwidth=4 diff --git a/lib/HTTP/UserAgent.rakumod b/lib/HTTP/UserAgent.rakumod index 345c550..f624488 100644 --- a/lib/HTTP/UserAgent.rakumod +++ b/lib/HTTP/UserAgent.rakumod @@ -13,18 +13,19 @@ 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, Bool :$strict = $request.strict) { + 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, :$strict)); + self.print($request.Str($strict, :bin)); self.write($request.content); } elsif $strict { - self.print: $request.Str: :strict; + self.print: $request.Str: $STRICT; } else { self.print($request.Str ~ "\r\n"); @@ -93,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; @@ -100,55 +105,55 @@ method auth(Str $login, Str $password) { proto method get(|) {*} -multi method get(URI $uri is copy, Bool :$bin, Bool :$strict is copy, *%header ) { +multi method get(URI $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { $strict ||= $!strict; - my $request = HTTP::Request.new(GET => $uri, :$strict, |%header); - self.request($request, :$bin, :$strict) + my $request = HTTP::Request.new($strict, GET => $uri, |%header); + self.request($request, $strict, :$bin) } -multi method get(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { - self.get(URI.new(_clear-url($uri)), :$bin, :$strict, |%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, Bool :$strict is copy, *%header) { +multi method post(URI $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header) { $strict ||= $!strict; - my $request = HTTP::Request.new(POST => $uri, :$strict, |%header); + my $request = HTTP::Request.new($strict, POST => $uri, |%header); $request.add-form-data(%form); - self.request($request, :$bin, :$strict) + self.request($request, $strict, :$bin) } -multi method post(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) { - self.post(URI.new(_clear-url($uri)), %form, :$bin, :$strict, |%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, Bool :$strict is copy, *%header) { +multi method put(URI $uri is copy, %form, Bool $strict is copy = False, Bool :$bin, *%header) { $strict ||= $!strict; - my $request = HTTP::Request.new(PUT => $uri, :$strict, |%header); + my $request = HTTP::Request.new($strict, PUT => $uri, |%header); $request.add-form-data(%form); - self.request($request, :$bin, :$strict) + self.request($request, $strict, :$bin) } -multi method put(Str $uri is copy, %form, Bool :$bin, Bool :$strict, *%header ) { - self.put(URI.new(_clear-url($uri)), %form, :$strict, |%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, Bool :$strict is copy, *%header ) { +multi method delete(URI $uri is copy, Bool $strict is copy = False, Bool :$bin, *%header ) { $strict ||= $!strict; - my $request = HTTP::Request.new(DELETE => $uri, :$strict, |%header); - self.request($request, :$bin, :$strict) + my $request = HTTP::Request.new($strict, DELETE => $uri, |%header); + self.request($request, $strict, :$bin) } -multi method delete(Str $uri is copy, Bool :$bin, Bool :$strict, *%header ) { - self.delete(URI.new(_clear-url($uri)), :$bin, :$strict, |%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, Bool :$strict is copy --> HTTP::Response:D) { +method request(HTTP::Request $request, Bool $strict is copy = False, Bool :$bin --> HTTP::Response:D) { $strict ||= $!strict; my HTTP::Response $response; @@ -160,11 +165,11 @@ method request(HTTP::Request $request, Bool :$bin, Bool :$strict is copy --> HTT # if auth has been provided add it to the request self.setup-auth($request); - $.debug-handle.say("==>>Send\n" ~ $request.Str(:debug, :$strict)) 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, :$strict) { - $response = self.get-response($request, $conn, :$bin, :$strict); + if $conn.send-request($request, $strict) { + $response = self.get-response($request, $conn, $strict, :$bin); } $conn.close; @@ -180,8 +185,8 @@ method request(HTTP::Request $request, Bool :$bin, Bool :$strict is copy --> HTT if $.max-redirects < $.redirects-in-a-row { X::HTTP::Response.new(:rc('Max redirects exceeded'), :response($response)).throw; } - my $new-request = $response.next-request(:$strict); - return self.request($new-request, :$strict); + my $new-request = $response.next-request($strict); + return self.request($new-request, $strict); } else { $!redirects-in-a-row = 0; @@ -269,7 +274,7 @@ method get-chunked-content(Connection $conn, Blob $content is rw --> Blob:D) { $content } -method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool :$strict is copy --> 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; @@ -308,7 +313,7 @@ method get-response(HTTP::Request $request, Connection $conn, Bool :$bin, Bool : } - my HTTP::Response $response = HTTP::Response.new($header-chunk, :$strict); + 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 index 0ea5086..a40e2fa 100644 --- a/t/011-headers-strict.rakutest +++ b/t/011-headers-strict.rakutest @@ -38,8 +38,8 @@ 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'; +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'); @@ -56,15 +56,15 @@ 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"; +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"; +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"; +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 { @@ -89,7 +89,7 @@ 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); + $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'; diff --git a/t/021-message-issue-226.rakutest b/t/021-message-issue-226.rakutest index 44b2b8b..dbf2ce0 100644 --- a/t/021-message-issue-226.rakutest +++ b/t/021-message-issue-226.rakutest @@ -40,7 +40,7 @@ nok $m.field('a'), 'remove-field 1/1'; # 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); +$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'; @@ -48,11 +48,11 @@ 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'; +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.Str($STRICT), $CRLF, 'clear 1/2 - body-less messages require final CRLF'; is $m.content, '', 'clear 2/2'; ## parse a more complex example @@ -80,7 +80,7 @@ $to_parse = "HTTP/1.1 200 OK\r\n" ~ "# Last updated Sat May 31 16:39:01 2014 (UTC)\n" ~ "# \n" ~ "# Explanation of the syntax:\n"; -$m2.parse($to_parse, :strict); +$m2.parse($to_parse, $STRICT); # quotes generally not considered part of the content. please see # RFC 9110, section 5.5, second-to-last paragraph @@ -113,7 +113,7 @@ subtest { '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; + 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'; @@ -131,7 +131,7 @@ subtest { '- four' # chunk data ; - is $m.Str(:strict), $expected, 'Str'; + is $m.Str($STRICT), $expected, 'Str'; # add-content $m.add-content: "\n- five"; @@ -144,7 +144,7 @@ subtest { '', # end of header "- four\n- five", # content ; # FIXME : does not test: trailer, chunk extension, binary - is $m.Str(:strict), $expected, 'non-chunked Str'; + is $m.Str($STRICT), $expected, 'non-chunked Str'; }, 'chunked request'; @@ -156,12 +156,12 @@ subtest { ~ "Content-Length: 3\r\n" ~ "\r\n" ~ "a\nb"; - my HTTP::Response:D $m2 = HTTP::Response.new(200, $STRICT).parse($to_parse, :strict); + 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'; + is $m2.Str($STRICT), $to_parse, 'non-chunked Str'; }, 'parse non-chunked response'; @@ -178,7 +178,7 @@ subtest { '0', '' ; - my HTTP::Response:D $m2 = HTTP::Response.new(200, $STRICT).parse($to_parse, :strict); + 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'; @@ -191,7 +191,7 @@ subtest { "a\nb", # chunk data ; - is $m2.Str(:strict), $expected, 'Str'; + 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 index fb7bc8b..0a3f15e 100644 --- a/t/042-request-issue-226.rakutest +++ b/t/042-request-issue-226.rakutest @@ -55,14 +55,14 @@ 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); +$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'; +is $r1.Str($STRICT), $exp, 'parse 6/6'; subtest { my $r; @@ -134,6 +134,6 @@ my Str:D $expected = join $CRLF, 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'; +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 index 400d864..8ae84d5 100644 --- a/t/051-response-issue-226.rakutest +++ b/t/051-response-issue-226.rakutest @@ -37,7 +37,7 @@ 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); +$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'; @@ -99,7 +99,7 @@ subtest { ok $r.is-text, 'is text'; nok $r.is-binary, 'not binary'; is $r.content, 'content', 'content'; - is $r.Str(:strict), $expected, 'Str'; + 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 index dbdf311..4d598df 100644 --- a/t/081-ua-strict-interop.rakutest +++ b/t/081-ua-strict-interop.rakutest @@ -9,7 +9,7 @@ use TestServer; my constant $CRLF = "\x[0D]\x[0A]"; my constant $STRICT = True; -plan 4; +plan 3; my $port = get-unused-port; @@ -35,11 +35,11 @@ subtest { 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; + 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; + 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'; @@ -52,7 +52,7 @@ subtest { my ( $eol, $lok ) = $rs.content.split: "\x0d"; is $eol, 'F', 'no extra eol'; is $lok, 'T', 'length matches'; - my $rq = HTTP::Request.new: :!strict; + my $rq = HTTP::Request.new: not $STRICT; $rq.set-method: 'POST'; $rq.uri: "http://localhost:$port/uastrictmsglenient"; $rq.add-content: 'hello=world'; @@ -62,15 +62,6 @@ subtest { is $lok, 'T', 'UA:strict with Message:!strict - length matches'; }, 'UA:strict is still strict with Message:!strict'; -subtest { - plan 2; - my $uas = HTTP::UserAgent.new: $STRICT; - my $rs = $uas.delete: "http://localhost:$port/DELETE"; - my ( $eol, $lok ) = $rs.content.split: "\x0d"; - is $eol, 'F', 'no extra eol'; - is $lok, 'T', 'length matches'; -}, 'UA:strict delete'; - $done-promise.keep: 'shutdown'; # UA:strict with Message:!strict diff --git a/t/081-ua-strict.rakutest b/t/081-ua-strict.rakutest index 5480f55..17dc0a1 100644 --- a/t/081-ua-strict.rakutest +++ b/t/081-ua-strict.rakutest @@ -6,32 +6,34 @@ use URI; plan 11; +my constant $STRICT = True; + # new -my $ua = HTTP::UserAgent.new: :strict; +my $ua = HTTP::UserAgent.new: $STRICT; nok $ua.useragent, 'new 1/3'; -$ua = HTTP::UserAgent.new: useragent => 'test', :strict; +$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; +$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'; + 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); + 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'; + lives-ok { HTTP::UserAgent.new($STRICT).get('http://www.baidu.com', $STRICT) }, 'Lived through gb2312 encoding'; # chunked encoding. @@ -52,9 +54,9 @@ if %*ENV { subtest { my $uri = 'http://eu.httpbin.org/post?foo=42&bar=x'; my %data = :72foo, :bar<♵>; - my $ua = HTTP::UserAgent.new: :strict; + my $ua = HTTP::UserAgent.new: $STRICT; my $res; - lives-ok { $res = $ua.post(URI.new($uri), %data, :strict, X-Foo => "foodle") }, "new make post"; + lives-ok { $res = $ua.post(URI.new($uri), %data, $STRICT, X-Foo => "foodle") }, "new make post"; my $ret-data; if $have-json { @@ -69,9 +71,9 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent.new: :strict; + my $ua = HTTP::UserAgent.new: $STRICT; my $res; - lives-ok { $res = $ua.post(URI.new($uri), %data, :strict, X-Foo => "foodle") }, "make post"; + lives-ok { $res = $ua.post(URI.new($uri), %data, $STRICT, X-Foo => "foodle") }, "make post"; my $ret-data; if $have-json { @@ -86,9 +88,9 @@ if %*ENV { } }, "with URI object"; subtest { - my $ua = HTTP::UserAgent.new: :strict; + my $ua = HTTP::UserAgent.new: $STRICT; my $res; - lives-ok { $res = $ua.post($uri, %data, :strict, X-Foo => "foodle") }, "make post"; + 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"; diff --git a/t/lib/TestServer.rakumod b/t/lib/TestServer.rakumod index 70cb2a6..b15f3eb 100644 --- a/t/lib/TestServer.rakumod +++ b/t/lib/TestServer.rakumod @@ -64,6 +64,7 @@ module TestServer { } use HTTP::Request; + my constant $STRICT = True; sub test-full-message ( Promise $done-promise, Int :$port --> Promise:D ) is export { start { react { @@ -72,8 +73,8 @@ module TestServer { } 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 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';