├── .gitignore ├── .travis.yml ├── META6.json ├── README ├── lib └── HTTP │ ├── Client.pm6 │ └── Client │ ├── Request.pm6 │ └── Response.pm6 └── t ├── 01-get.t ├── 02-post.t └── 03-post-multipart.t /.gitignore: -------------------------------------------------------------------------------- 1 | blib/ 2 | Makefile 3 | *.swp 4 | .precomp -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: 2 | - minimal 3 | 4 | services: 5 | - docker 6 | 7 | install: 8 | - docker pull jjmerelo/perl6-test-openssl 9 | - docker images 10 | 11 | script: docker run -t -v $TRAVIS_BUILD_DIR:/test jjmerelo/perl6-test-openssl 12 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "name" : "HTTP::Client", 3 | "version" : "0.0.3", 4 | "description" : "A flexible HTTP Client library", 5 | "authors" : ["Timothy Totten"], 6 | "license" : "Artistic-2.0", 7 | "depends" : [ "MIME::Base64", "HTTP::Status", "IO::Socket::SSL" ], 8 | "provides" : { 9 | "HTTP::Client" : "lib/HTTP/Client.pm6", 10 | "HTTP::Client::Request" : "lib/HTTP/Client/Request.pm6", 11 | "HTTP::Client::Response" : "lib/HTTP/Client/Response.pm6" 12 | }, 13 | "source-url" : "git://github.com/supernovus/perl6-http-client.git" 14 | } 15 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | HTTP::Client -- Perl 6 library for building HTTP Clients 2 | ------------------------------------------------------------------------------- 3 | 4 | NOTE 1: This library is way overdue for a rewrite. See the '2.0' branch for 5 | what I was working on the last time I looked at this (it's been a few 6 | years...) 7 | 8 | NOTE 2: As I don't think I'll be able to work on it for quite some time, 9 | and there are certain pieces of functionality which are completely 10 | broken in the current version of this library, such as chunked encoding, 11 | and anything involving binary file transfers, 12 | please consider using HTTP::UserAgent or Net::HTTP instead. 13 | 14 | ------------------------------------------------------------------------------- 15 | 16 | Inspired by LWP and HTTP::Client from Perl 5, and LWP::Simple 17 | from Perl 6, this is a simple class for building HTTP clients 18 | using Perl 6. 19 | 20 | It's not based on any of those when it comes to API, but instead 21 | offers a flexible syntax that's easy to use, and easy to extend. 22 | 23 | It currently only supports HTTP itself. HTTP+SSL (HTTPS) support 24 | is planned for a future version. 25 | 26 | = Usage = 27 | 28 | A simple GET request, without an intermetiary Request object: 29 | 30 | my $client = HTTP::Client.new; 31 | my $response = $client.get('http://example.com/web/service'); 32 | if ($response.success) { 33 | say $response.content; 34 | } 35 | 36 | A more advanced POST application/x-www-form-urlencoded request: 37 | 38 | my $client = HTTP::Client.new; 39 | my $request = $client.post; ## Note we are not setting the URI/URL. 40 | $request.url('http://example.com/web/service'); 41 | ## The following line creates Request variables called query and mode. 42 | ## You could also do $request.set-content('query=libwww-perl&mode=dist'); 43 | ## But I think letting the library build your content for you, is nicer. 44 | $request.add-field(:query, :mode); 45 | my $response = $request.run; ## or $client.do-request($request); 46 | ... 47 | 48 | A more advanced POST multipart/form-data request: 49 | 50 | my $client = HTTP::Client.new; 51 | my $request = $client.post(:multipart); 52 | $request.url('http://example.com/web/service'); 53 | $request.add-field(:id(37271)); 54 | $request.add-file( 55 | :name("upload"), :filename("file.txt"), 56 | :type("text/plain"), :content("hello world...") 57 | ); 58 | my $response = $request.run; 59 | 60 | = Notes = 61 | 62 | As seen above, there is no need to build HTTP::Client::Request objects 63 | manually. Just use the appropriate method (get, post, head, put, delete) 64 | or use $client.make-request($method); for methods that don't have methods 65 | in HTTP::Client (TRACE, OPTIONS, CONNECT, PATCH, DEBUG, etc.) 66 | 67 | As it's name states, this library is specifically for HTTP Clients. 68 | If you want something for building HTTP Servers, see HTTP::Easy. 69 | If you want something for Request/Reponse objects for your Web Application, 70 | see WWW::App. Full disclosure: I wrote both of those libraries too. 71 | 72 | Also, there are some weird issues with the IO::Socket::INET library in 73 | the current Rakudo master, which are affecting connecting to outside servers. 74 | So the tests in the t/ folder currently depend on the HTTP::Easy library, 75 | and in particular, the examples/test.p6 script from HTTP::Easy to be running 76 | before you run the tests. 77 | 78 | = Requirements = 79 | 80 | * Rakudo Perl 6 81 | * HTTP::Status 82 | * MIME::Base64 83 | 84 | It should also require: 85 | 86 | * URI 87 | 88 | But at the current time, that module is not compiling under "master" which 89 | the rest of this is focused on, so for the time being, I'm using a very 90 | limited inline URI grammar instead. 91 | 92 | = Author = 93 | 94 | Timothy Totten 95 | 96 | = License = 97 | 98 | Artistic License 2.0 99 | -------------------------------------------------------------------------------- /lib/HTTP/Client.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class HTTP::Client; 4 | 5 | our $VERSION = '0.2'; ## The version of HTTP::Client. 6 | 7 | ## We offer a default user/agent. 8 | has $.user-agent is rw = "perl6-HTTP::Client/$VERSION"; # Perl6/$*PERL"; 9 | has $.http-version is rw = '1.1'; ## Supported HTTP version. 10 | 11 | ## This is the main class. It handles the magic. 12 | 13 | use HTTP::Client::Request; 14 | use HTTP::Client::Response; 15 | use IO::Socket::SSL; 16 | 17 | ## Make a request object, and return it. 18 | method make-request(Str $method, Str $url?, :%query, :%data, :@files, :$multipart) { 19 | my $request = HTTP::Client::Request.new(:$method, :client(self)); 20 | if ($multipart) { 21 | $request.multipart; 22 | } 23 | if (@files) { 24 | $request.multipart; ## We need multipart for file uploads. 25 | for @files -> $filespec { 26 | if $filespec !~~ Hash { next; } ## Skip it. 27 | $request.add-file(|$filespec); ## Flatten it. 28 | } 29 | } 30 | if (%data) { 31 | $request.add-field(|%data); 32 | } 33 | if (%query) { 34 | $request.add-query(|%query); 35 | } 36 | if ($url) { 37 | $request.url($url); 38 | } 39 | return $request; 40 | } 41 | 42 | ## A request that doesn't require data: GET, HEAD, DELETE 43 | method simple-request ($method, $url?, :%query, :$follow) { 44 | if ($url) { 45 | my $req = self.make-request($method, $url, :%query); 46 | return self.do-request($req, :$follow); 47 | } 48 | self.make-request($method); ## Return an empty request, with no options. 49 | } 50 | 51 | ## A request that requires data: POST, PUT 52 | method data-request 53 | ($method, $url?, :%query, :%data, :%files, :$multipart, :$follow) { 54 | if ($url) { 55 | my $req = self.make-request($method, $url, :%query, :%data, :%files, :$multipart); 56 | return self.do-request($req, :$follow); 57 | } 58 | self.make-request($method, :$multipart); ## Only multipart option is used. 59 | } 60 | 61 | ## GET request 62 | method get ($url?, :%query, :$follow) { 63 | return self.simple-request('GET', $url, :%query, :$follow); 64 | } 65 | 66 | ## HEAD request 67 | method head ($url?, :%query, :$follow) { 68 | return self.simple-request('HEAD', $url, :%query, :$follow); 69 | } 70 | 71 | ## DELETE request 72 | method delete ($url?, :%query, :$follow) { 73 | return self.simple-request('DELETE', $url, :%query, :$follow); 74 | } 75 | 76 | ## POST request 77 | method post ($url?, :%query, :%data, :%files, :$multipart, :$follow) { 78 | return self.data-request( 79 | 'POST', $url, :%query, :%data, :%files, :$multipart, :$follow 80 | ); 81 | } 82 | 83 | ## PUT request 84 | method put ($url?, :%query, :%data, :%files, :$multipart, :$follow) { 85 | return self.data-request( 86 | 'PUT', $url, :%query, :%data, :%files, :$multipart, :$follow 87 | ); 88 | } 89 | 90 | ## Do the request 91 | method do-request (HTTP::Client::Request $request, :$follow=0) { 92 | if ($request.protocol ne 'http' | 'https') { 93 | die "Unsupported protocol, '{$request.protocol}'."; 94 | } 95 | 96 | my \if-https = $request.protocol eq 'https'; 97 | 98 | my $host = $request.host; 99 | my $port = if-https ?? 443 !! 80; 100 | if $request.port { $port = $request.port; } 101 | 102 | # $*ERR.say: "Connecting to '$host' on '$port'"; 103 | 104 | my $sock = if-https ?? IO::Socket::SSL.new(:$host, :$port) !! IO::Socket::INET.new(:$host, :$port); 105 | $sock.print(~$request); 106 | my $resp; 107 | my $chunk; 108 | repeat { 109 | $chunk = $sock.recv(); 110 | $resp ~= $chunk; 111 | } while $chunk; 112 | $sock.close(); 113 | 114 | my $response = HTTP::Client::Response.new($resp, self); 115 | if $follow && $response.redirect { 116 | my $newurl = $response.header('Location'); 117 | if ! $newurl { 118 | die "Tried to follow a redirect that provided no URL."; 119 | } 120 | $request.url($newurl); 121 | return self.do-request($request, :follow($follow-1)); 122 | } 123 | return $response; 124 | } 125 | 126 | -------------------------------------------------------------------------------- /lib/HTTP/Client/Request.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class HTTP::Client::Request; 4 | 5 | ## This is the request class. It represents a request to an HTTP server. 6 | 7 | use MIME::Base64; 8 | 9 | #### Private constants 10 | constant MULTIPART = 'multipart/form-data'; 11 | constant URLENCODED = 'application/x-www-form-urlencoded'; 12 | constant $CRLF = "\x0D\x0A"; 13 | 14 | #### Immutable public members. 15 | has $.method; ## The HTTP Method for the request. 16 | has $.client; ## Our parent HTTP::Client object. 17 | 18 | #### Private members. 19 | has $!proto; ## The protocol we will be connecting to. 20 | has $!host; ## The host we are going to connect to. 21 | has $!port; ## The port we are going to connect to. 22 | has $!path; ## The path we are going to get. 23 | has $!user; ## Username, if needed, for Authentication. 24 | has $!pass; ## Password, if needed, for Authentication. 25 | has $!auth; ## Auth type, can be Basic or Digest. 26 | has $!type = URLENCODED; ## Default to urlencoded forms. 27 | has $!query = ''; ## Part to add after the URL. 28 | has $!data = ''; ## The data body for POST/PUT. 29 | has @!headers; ## Extra headers in Pair format, for sending. 30 | has $!boundary; ## A unique boundary, set on first use. 31 | 32 | #### Grammars 33 | 34 | ## A grammar representing a URL, as per our usage anyway. 35 | ## This is temporary until the URI library is working under "master" 36 | ## then we'll move to using that instead, as it is far more complete. 37 | grammar URL { 38 | regex TOP { 39 | ^ 40 | 41 | '://' 42 | ['@']? 43 | 44 | [':']? 45 | 46 | $ 47 | } 48 | token proto { \w+ } 49 | token host { [\w|'.'|'-']+ } 50 | token port { \d+ } 51 | token user { \w+ } ## That's right, simplest usernames only. 52 | token pass { [\w|'-'|'+'|'%']+ } ## Fairly simple passwords only too. 53 | token auth { ':' } ## This assumes Basic Auth. 54 | regex path { .* } 55 | } 56 | 57 | #### Public Methods 58 | 59 | ## Encode a username and password into Base64 for Basic Auth. 60 | method base64encode ($user, $pass) { 61 | my $mime = MIME::Base64.new(); 62 | my $encoded = $mime.encode_base64($user~':'~$pass); 63 | return $encoded; 64 | } 65 | 66 | ## Parse a URL into host, port and path. 67 | method url ($url) { 68 | my $match = URL.parse($url); 69 | if ($match) { 70 | $!proto = ~$match; 71 | $!host = ~$match; 72 | if ($match) { 73 | my $port = ~$match; 74 | # $*ERR.say: "port is "~$port.perl; 75 | $!port = +$port; 76 | # $*ERR.say: "Setting port to $!port"; 77 | } 78 | if (~$match) { 79 | $!path = ~$match; 80 | } else { 81 | $!path = '/'; 82 | } 83 | if ($match) { 84 | ## The only auth we support via URL is Basic. 85 | $!auth = 'Basic'; 86 | $!user = $match; 87 | $!pass = $match; 88 | } 89 | } 90 | } 91 | 92 | ## Get the protocol 93 | method protocol { 94 | return $!proto; 95 | } 96 | 97 | ## Get the hostname 98 | method host { 99 | return $!host; 100 | } 101 | 102 | ## Get the custom port. 103 | ## If this is not set, the library requesting it should use 104 | ## whatever is the default port for the protocol. 105 | method port { 106 | return $!port; 107 | } 108 | 109 | ## Get the path. If this is not set, you should use '/' or whatever 110 | ## makes sense in your application. 111 | method path { 112 | return $!path; 113 | } 114 | 115 | ## Use multipart POST/PUT. 116 | method multipart { 117 | $!type = MULTIPART; 118 | } 119 | 120 | ## Use urlencoded POST/PUT. 121 | method urlencoded { 122 | $!type = URLENCODED; 123 | } 124 | 125 | ## Use some custom type. May be useful for some web services. 126 | method set-type ($type) { 127 | $!type = $type; 128 | } 129 | 130 | ## Build a query (query string, or urlencoded form data.) 131 | method build-query ($query is rw, %queries) { 132 | for %queries.kv -> $name, $value { 133 | if $query { 134 | $query ~= '&'; 135 | } 136 | my $val; ## Storage for the value, in case of array. 137 | if $value ~~ Array { 138 | $val = $value.join('&'~$name~'='); ## It looks evil, but it works. 139 | } 140 | else { 141 | $val = $value; 142 | } 143 | $query ~= "$name=$val"; 144 | } 145 | } 146 | 147 | ## Add query fields. 148 | method add-query (*%queries) { 149 | self.build-query($!query, %queries); 150 | } 151 | 152 | ## Generate something fairly random. 153 | method !randomstr { 154 | my $num = time * 1000.rand.Int; 155 | for 1..6.rand.Int+2 { 156 | my $ran = 1000000.rand.Int; 157 | if ($ran % 2) == 0 { 158 | $num += $ran; 159 | } 160 | else { 161 | $num -= $ran; 162 | } 163 | } 164 | my $str = $num.base(36); 165 | if 2.rand.Int { 166 | $str.=lc; 167 | } 168 | return $str; 169 | } 170 | 171 | ## Get the boundary (generate it if needed.) 172 | method boundary { 173 | if $!boundary { return $!boundary; } 174 | $!boundary = (for 1..4 { self!randomstr }).join; 175 | return $!boundary; 176 | } 177 | 178 | ## Add data fields. 179 | method add-field (*%queries) { 180 | ## First off, this only works on POST and PUT. 181 | if $.method ne 'POST' | 'PUT' { 182 | return self.add-query(|%queries); 183 | } 184 | if $!type eq URLENCODED { 185 | self.build-query($!data, %queries); 186 | } 187 | elsif $!type eq MULTIPART { 188 | for %queries.kv -> $name, $value { 189 | if ($value ~~ Array) { 190 | for @($value) -> $subval { 191 | self.add-part($subval, :$name); 192 | } 193 | } 194 | else { 195 | self.add-part($value, :$name); 196 | } 197 | } 198 | } 199 | } 200 | 201 | ## Make a multipart section. 202 | method make-part ( 203 | $boundary, $value, :$type, :$binary, :$disp='form-data', *%conf 204 | ) { 205 | my $part = "--$boundary$CRLF"; 206 | $part ~= "Content-Disposition: $disp"; 207 | for %conf.kv -> $key, $val { 208 | $part ~= "; $key=\"$val\""; 209 | } 210 | $part ~= $CRLF; ## End of disposition header. 211 | if $type { 212 | $part ~= "Content-Type: $type$CRLF"; 213 | } 214 | if $binary { 215 | $part ~= "Content-Transfer-Encoding: binary$CRLF"; 216 | } 217 | $part ~= $CRLF; ## End of headers. 218 | $part ~= $value ~ $CRLF; 219 | return $part; 220 | } 221 | 222 | ## Add a multipart section to our data. 223 | method add-part ($value, :$type, :$binary, :$disp='form-data', *%conf) { 224 | if $!type ne MULTIPART { return; } ## We only work on multipart. 225 | $!data ~= self.make-part($.boundary, $value, :$type, :$binary, :$disp, |%conf); 226 | } 227 | 228 | ## Add a file upload 229 | method add-file (:$name!, :$filename!, :$content!, :$type, :$binary) { 230 | self.add-part($content, :$type, :$binary, :$name, :$filename); 231 | } 232 | 233 | ## Set the data directly (may be useful for some web services.) 234 | method set-content ($content) { 235 | $!data = $content; 236 | } 237 | 238 | ## Add an extra header 239 | method add-header (Pair $pair) { 240 | @!headers.push: $pair; 241 | } 242 | 243 | ## See if a given header exists 244 | method has-header ($name) { 245 | for @!headers -> $header { 246 | if $header.key eq $name { return True; } 247 | } 248 | return False; 249 | } 250 | 251 | ## The method that actually builds the Request 252 | ## that will be sent to the HTTP Server. 253 | method Str { 254 | my $version = $.client.http-version; 255 | my $output = "$.method $!path HTTP/$version$CRLF"; 256 | self.add-header('Connection'=>'close'); 257 | if ! self.has-header('User-Agent') { 258 | my $useragent = $.client.user-agent; 259 | self.add-header('User-Agent'=>$useragent); 260 | } 261 | if $!port { 262 | self.add-header('Host'=>$!host~':'~$!port); 263 | } 264 | else { 265 | self.add-header('Host'=>$!host); 266 | } 267 | if ! self.has-header('Accept') { 268 | ## The following is a hideous workaround for a bug in vim 269 | ## which breaks the perl6 plugin. It is there for my editing sanity 270 | ## only, and does not affect the end result. 271 | my $star = '*'; 272 | self.add-header('Accept'=>"$star/$star"); 273 | } 274 | if $.method eq 'POST' | 'PUT' { 275 | self.add-header('Content-Type'=>$!type); 276 | } 277 | if $!auth { 278 | if $!auth eq 'Basic' { ## Only one we're supporting right now. 279 | my $authstring = self.base64encode($!user, $!pass); 280 | self.add-header('Authorization'=>"Basic $authstring"); 281 | } 282 | } 283 | if $!data { 284 | if $!type eq MULTIPART { 285 | ## End our default boundary. 286 | $!data ~= "--{$!boundary}--$CRLF"; 287 | } 288 | my $length = $!data.chars; 289 | self.add-header('Content-Length'=>$length); 290 | } 291 | ## Okay, add the headers. 292 | for @!headers -> $header { 293 | $output ~= "{$header.key}: {$header.value}$CRLF"; 294 | } 295 | if $!data { 296 | $output ~= $CRLF; ## Add a blank line, notifying the end of headers. 297 | $output ~= $!data; ## Add the data. 298 | } 299 | $output ~= $CRLF; 300 | return $output; 301 | } 302 | 303 | ## Execute the request. This is actually just a convenience 304 | ## wrapper for do-request() in the HTTP::Client class. 305 | method run (:$follow) { 306 | $.client.do-request(self, :$follow); 307 | } 308 | 309 | -------------------------------------------------------------------------------- /lib/HTTP/Client/Response.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | unit class HTTP::Client::Response; 4 | 5 | ## This is the response class. It represents a response from an HTTP server. 6 | 7 | use HTTP::Status; 8 | 9 | ## Private constants 10 | constant $CRLF = "\x0D\x0A"; 11 | 12 | ## Public members. 13 | has $.client; ## Our parent HTTP::Client object. 14 | has $.status; ## The HTTP status code (numeric only.) 15 | has $.message; ## The text HTTP status message. 16 | has $.protocol; ## HTTP proto/version returned by server. 17 | 18 | ## Private members 19 | has @!headers; ## The server response headers. An Array of Pairs. 20 | ## Use $response.headers() or $response.header() 21 | ## to get the headers. 22 | has @!content; ## The body of the message from the server. 23 | ## Use $response.contents() for the array, or 24 | ## $response.content() for a string. 25 | 26 | ## We override new, and expect the response from the server 27 | ## to be passed in, as well as a copy of our HTTP::Client object. 28 | method new ($server_response, $client) { 29 | my @content = $server_response.split($CRLF); 30 | my $status_line = @content.shift; 31 | my ($protocol, $status, $message) = $status_line.split(/\s/); 32 | if ! $message { 33 | $message = get_http_status_msg($status); 34 | } 35 | my @headers; 36 | while @content { 37 | my $line = @content.shift; 38 | last if $line eq ''; ## End of headers. 39 | my ($name, $value) = $line.split(': '); 40 | my $header = $name => $value; 41 | @headers.push: $header; 42 | } 43 | # $*ERR.say: "Contents after: "~@content.perl; 44 | # $*ERR.say: "Headers after: "~@headers.perl; 45 | self.bless( 46 | :$client, :$status, :$message, :$protocol ##, 47 | # :headers(@headers), :content(@content) ## Bug? These aren't set. 48 | )!initialize(@headers, @content); 49 | } 50 | 51 | ## The initialize method is a hack, due to private members not being set. 52 | ## in the bless method. 53 | method !initialize ($headers, $content) { 54 | @!headers := @($headers); 55 | @!content := @($content); 56 | return self; 57 | } 58 | 59 | multi method headers () { 60 | return @!headers; 61 | } 62 | 63 | multi method headers ($wanted) { 64 | my @matched; 65 | my $raw = False; 66 | if $wanted ~~ Regex { $raw = True; } 67 | for @!headers -> $header { 68 | if $header.key ~~ $wanted { 69 | if $raw { 70 | @matched.push: $header; 71 | } 72 | else { 73 | @matched.push: $header.value; 74 | } 75 | } 76 | } 77 | return @matched; 78 | } 79 | 80 | method header ($wanted) { 81 | my $raw = False; 82 | if $wanted ~~ Regex { $raw = True; } 83 | for @!headers -> $header { 84 | if $header.key ~~ $wanted { 85 | if $raw { 86 | return $header; 87 | } 88 | else { 89 | return $header.value; 90 | } 91 | } 92 | } 93 | return; ## Sorry, we didn't find anything. 94 | } 95 | 96 | ## de-chunking algorithm stolen shamelessly from LWP::Simple 97 | method dechunk (@contents) { 98 | my $transfer = self.header('Transfer-Encoding'); 99 | if ! $transfer || $transfer !~~ /:i chunked/ { 100 | ## dechunking only to be done if Transfer-Encoding says so. 101 | return @contents; 102 | } 103 | my @con = (); 104 | while @contents { 105 | # Chunk start: length as hex word 106 | my $length = @contents.shift; 107 | 108 | ## Chunk length is hex and could contain extensions. 109 | ## See RFC2616, 3.6.1 -- e.g. '5f32; xxx=...' 110 | if $length ~~ /^ \w+ / { 111 | $length = :16($length); 112 | } 113 | else { 114 | last; 115 | } 116 | if $length == 0 { 117 | last; 118 | } 119 | 120 | ## Continue reading for '$length' bytes 121 | while $length > 0 && @contents { 122 | my $line = @contents.shift; 123 | @con.push($line); 124 | $length -= $line.chars; #.bytes, not .chars 125 | } 126 | } 127 | return @con; 128 | } 129 | 130 | method contents (Bool :$dechunk=True) { 131 | # $*ERR.say: "contents -- "~@!content.perl; 132 | if $dechunk { 133 | return self.dechunk(@!content); 134 | } 135 | return @!content; 136 | } 137 | 138 | method content (Bool :$dechunk=True) { 139 | return self.contents(:$dechunk).join($CRLF); 140 | } 141 | 142 | method success (:$loose) { 143 | if $loose { 144 | if $.status ~~ /^2/ { 145 | return True; 146 | } 147 | } 148 | else { 149 | if $.status ~~ /^200$/ { 150 | return True; 151 | } 152 | } 153 | return False; 154 | } 155 | 156 | method redirect (:$loose, :$url) { 157 | if $loose { 158 | if $.status ~~ /^3/ { 159 | if $url { 160 | return self.header('Location'); 161 | } 162 | return True; 163 | } 164 | } 165 | else { 166 | if $.status ~~ /30 <[12]>/ { 167 | if $url { 168 | return self.header('Location'); 169 | } 170 | return True; 171 | } 172 | } 173 | return False; 174 | } 175 | -------------------------------------------------------------------------------- /t/01-get.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use HTTP::Client; 3 | use Test; 4 | 5 | plan 6; 6 | 7 | my $http = HTTP::Client.new; 8 | my $res = $http.get('https://raku.org/'); 9 | #my $res = $http.get('http://127.0.0.1:8080/test.txt'); 10 | #$*ERR.say: "~Status: "~$res.status; 11 | #$*ERR.say: "~Message: "~$res.message; 12 | #$*ERR.say: "~Proto: "~$res.protocol; 13 | ok $res, "Constructed result object from direct get() call."; 14 | ok $res.success, "Result was successful."; 15 | my $content = $res.content; 16 | #$*ERR.say: "~Content: $content"; 17 | #$*ERR.say: "~Headers: "~$res.headers.perl; 18 | ok $content, "Content was returned."; 19 | ok $content ~~ /Perl/, "Content was correct."; 20 | ok $content ~~ /\<\/html\>/, "Got entire content"; 21 | ok $res.header('Content-Type') ~~ /^text\/html/, "Correct content type."; 22 | 23 | -------------------------------------------------------------------------------- /t/02-post.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use HTTP::Client; 3 | use Test; 4 | 5 | plan 5; 6 | 7 | my $http = HTTP::Client.new; 8 | my $req = $http.post; 9 | $req.url('http://eu.httpbin.org/post'); 10 | $req.add-field(:query, :mode); 11 | my $res = $req.run; 12 | ok $res, "Constructed result object from direct get() call."; 13 | ok $res.success, "Result was successful."; 14 | my $content = $res.content; 15 | say $content; 16 | ok $content, "Content was returned."; 17 | ok $content ~~ /"http-client"/, "Content was correct."; 18 | ok $res.header('Content-Type') ~~ /^application\/json/, "Correct content type."; 19 | 20 | -------------------------------------------------------------------------------- /t/03-post-multipart.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use HTTP::Client; 3 | use Test; 4 | 5 | plan 5; 6 | 7 | my $http = HTTP::Client.new; 8 | #my $res = $htto.get('http://huri.net/test.txt'); 9 | my $req = $http.post(:multipart); 10 | #$req.url('http://127.0.0.1:8080/test.txt'); 11 | $req.url('https://eu.httpbin.org/post'); 12 | $req.add-field(:id<1984>); 13 | $req.add-file( 14 | :name("upload"), :filename("test.txt"), 15 | :type("text/plain"), :content("Hello world.\nThis is a test.\n") 16 | ); 17 | my $res = $req.run; 18 | #$*ERR.say: "~Status: "~$res.status; 19 | #$*ERR.say: "~Message: "~$res.message; 20 | #$*ERR.say: "~Proto: "~$res.protocol; 21 | ok $res, "Constructed result object from direct get() call."; 22 | ok $res.success, "Result was successful."; 23 | my $content = $res.content; 24 | #$*ERR.say: "~Content: $content"; 25 | #$*ERR.say: "~Headers: "~$res.headers.perl; 26 | ok $content, "Content was returned."; 27 | 28 | ok $content ~~ /Client/, "Content was correct."; 29 | ok $res.header('Content-Type') ~~ /^application/, "Correct content type."; 30 | 31 | --------------------------------------------------------------------------------