Permalink
Browse files

Basic functionality in place, now needs testing (and tests...)

  • Loading branch information...
1 parent 19735ca commit d780c1288b17f0cf996b361735c06992ee37a94f @supernovus committed Sep 30, 2011
Showing with 285 additions and 33 deletions.
  1. +7 −0 META.info
  2. +9 −2 README
  3. +51 −16 lib/HTTP/Client.pm6
  4. +66 −15 lib/HTTP/Client/Request.pm6
  5. +152 −0 lib/HTTP/Client/Response.pm6
View
@@ -0,0 +1,7 @@
+{
+ "name" : "HTTP::Client",
+ "version" : "*",
+ "description" : "A flexible HTTP Client library",
+ "depends" : [ "MIME::Base64" ],
+ "source-url" : "git://github.com/supernovus/perl6-http-client.git"
+}
View
11 README
@@ -30,7 +30,7 @@ A more advanced POST application/x-www-form-urlencoded request:
## You could also do $request.set-content('query=libwww-perl&mode=dist');
## But I think letting the library build your content for you, is nicer.
$request.add-field(:query<libwww-perl>, :mode<dist>);
- my $response = $request.run; ## or $client.request($request);
+ my $response = $request.run; ## or $client.do-request($request);
...
A more advanced POST multipart/form-data request:
@@ -60,9 +60,16 @@ see WWW::App. Full disclosure: I wrote both of those libraries too.
= Requirements =
* Rakudo Perl 6 <http://rakudo.org/>
-* URI <https://github.com/ihrd/uri/>
* MIME::Base64 <https://github.com/snarkyboojum/Perl6-MIME-Base64/>
+It should also require:
+
+* URI <https://github.com/ihrd/uri/>
+
+But at the current time, that module is not compiling under "nom" which
+the rest of this is focused on, so for the time being, I'm using a very
+limited inline URI grammar instead.
+
= Author =
Timothy Totten
View
@@ -2,8 +2,11 @@ use v6;
class HTTP::Client;
-has $.user-agent is rw = 'perl6-HTTP::Client/1.0'; ## UserAgent
-has $.http-version is rw = '1.1'; ## The HTTP version.
+our $VERSION = '0.2'; ## The version of HTTP::Client.
+
+## We offer a default user/agent.
+has $.user-agent is rw = "HTTP::Client/$VERSION Perl6/$*PERL<version>";
+has $.http-version is rw = '1.1'; ## Supported HTTP version.
## This is the main class. It handles the magic.
@@ -36,45 +39,77 @@ method make-request(Str $method, Str $url?, :%query, :%data, :@files, :$multipar
}
## A request that doesn't require data: GET, HEAD, DELETE
-method simple-request ($method, $url?, :%query) {
+method simple-request ($method, $url?, :%query, :$follow) {
if ($url) {
my $req = self.make-request($method, $url, :%query);
- return $req.run;
+ return self.do-request($req, :$follow);
}
self.make-request($method); ## Return an empty request, with no options.
}
## A request that requires data: POST, PUT
-method data-request ($method, $url?, :%query, :%data, :%files, :$multipart) {
+method data-request
+($method, $url?, :%query, :%data, :%files, :$multipart, :$follow) {
if ($url) {
my $req = self.make-request('POST', $url, :%query, :%data, :%files, :$multipart);
- return $req.run;
+ return self.do-request($req, :$follow);
}
self.make-request('POST', :$multipart); ## Only multipart option is used.
}
## GET request
-method get ($url?, :%query) {
- return self.simple-request('GET', $url, :%query);
+method get ($url?, :%query, :$follow) {
+ return self.simple-request('GET', $url, :%query, :$follow);
}
## HEAD request
-method head ($url?, :%query) {
- return self.simple-request('HEAD', $url, :%query);
+method head ($url?, :%query, :$follow) {
+ return self.simple-request('HEAD', $url, :%query, :$follow);
}
## DELETE request
-method delete ($url?, :%query) {
- return self.simple-request('DELETE', $url, :%query);
+method delete ($url?, :%query, :$follow) {
+ return self.simple-request('DELETE', $url, :%query, :$follow);
}
## POST request
-method post ($url?, :%query, :%data, :%files, :$multipart) {
- return self.data-request('POST', $url, :%query, :%data, :%files, :$multipart);
+method post ($url?, :%query, :%data, :%files, :$multipart, :$follow) {
+ return self.data-request(
+ 'POST', $url, :%query, :%data, :%files, :$multipart, :$follow
+ );
}
## PUT request
-method put ($url?, :%query, :%data, :%files, :$multipart) {
- return self.data-request('PUT', $url, :%query, :%data, :%files, :$multipart);
+method put ($url?, :%query, :%data, :%files, :$multipart, :$follow) {
+ return self.data-request(
+ 'PUT', $url, :%query, :%data, :%files, :$multipart, :$follow
+ );
+}
+
+## Do the request
+method do-request (HTTP::Client::Request $request, Int :$follow=0) {
+ if ($request.proto ne 'http') {
+ die "Unsupported protocol, '$request.proto'.";
+ }
+
+ my $host = $request.host;
+ my $port = 80;
+ if $request.port { $port = $request.port; }
+
+ my $sock = IO::Socket::INET.new(:$host, :$port);
+ $sock.send(~$request);
+ my $resp = $sock.recv();
+ $sock.close();
+
+ my $response = HTTP::Response.new($resp, self);
+ if $follow && $response.redirect {
+ my $newurl = $response.header('Location');
+ if ! $newurl {
+ die "Tried to follow a redirect that provided no URL.";
+ }
+ $request.url($newurl);
+ return self.do-request($request, :follow($follow-1));
+ }
+ return $response;
}
@@ -1,9 +1,11 @@
use v6;
-class HTTP::Client::Request
+class HTTP::Client::Request;
## This is the request class. It represents a request to an HTTP server.
+use MIME::Base64;
+
#### Private constants
constant MULTIPART = 'multipart/form-data';
constant URLENCODED = 'application/x-www-form-urlencoded';
@@ -18,6 +20,9 @@ has $!proto is rw; ## The protocol we will be connecting to.
has $!host is rw; ## The host we are going to connect to.
has $!port is rw; ## The port we are going to connect to.
has $!path is rw; ## The path we are going to get.
+has $!user is rw; ## Username, if needed, for Authentication.
+has $!pass is rw; ## Password, if needed, for Authentication.
+has $!auth is rw; ## Auth type, can be Basic or Digest.
has $!type is rw = URLENCODED; ## Default to urlencoded forms.
has $!query is rw = ''; ## Part to add after the URL.
has $!data is rw = ''; ## The data body for POST/PUT.
@@ -27,11 +32,14 @@ has $!boundary is rw; ## A unique boundary, set on first use.
#### Grammars
## A grammar representing a URL, as per our usage anyway.
+## This is temporary until the URI library is working under "nom"
+## then we'll move to using that instead, as it is far more complete.
grammar URL {
regex TOP {
^
<proto>
'://'
+ [<auth>'@']?
<host>
[':'<port>]?
<path>
@@ -40,11 +48,21 @@ grammar URL {
token proto { \w+ }
token host { [\w|'.'|'-']+ }
token port { \d+ }
+ token user { \w+ } ## That's right, simplest usernames only.
+ token pass { [\w|'-'|'+'|'%']+ } ## Fairly simple passwords only too.
+ token auth { <user> ':' <pass> } ## This assumes Basic Auth.
regex path { .* }
}
#### Public Methods
+## Encode a username and password into Base64 for Basic Auth.
+method base64encode ($user, $pass) {
+ my $mime = MIME::Base64.new();
+ my $encoded = $mime.encode_base64($user~':'~$pass);
+ return $encoded;
+}
+
## Parse a URL into host, port and path.
method url ($url) {
my $match = URL.parse($url);
@@ -57,6 +75,12 @@ method url ($url) {
if (~$match<path>) {
$!path = ~$match<path>;
}
+ if ($match<auth>) {
+ ## The only auth we support via URL is Basic.
+ $!auth = 'Basic';
+ $!user = $match<auth><user>;
+ $!pass = $match<auth><pass>;
+ }
}
}
@@ -132,7 +156,7 @@ method !randomstr {
$num -= $ran;
}
}
- $str = $num.base(36);
+ my $str = $num.base(36);
if 2.rand.Int {
$str.=lc;
}
@@ -219,34 +243,61 @@ method has-header ($name) {
return False;
}
-## The method that actually builds the Request.
-method request-text {
+## The method that actually builds the Request
+## that will be sent to the HTTP Server.
+method Str {
my $version = $.client.http-version;
my $output = "$.method $!path HTTP/$version$CRLF";
+ self.add-header('Connection'=>'close');
+ if ! self.has-header('User-Agent') {
+ my $useragent = $.client.user-agent;
+ self.add-header('User-Agent'=>$useragent);
+ }
if $!port {
- self.add-header('Host'=>"$!host:$port");
+ self.add-header('Host'=>$!host~':'~$!port);
}
else {
self.add-header('Host'=>$!host);
}
if ! self.has-header('Accept') {
- self.add-header('Accept'=>'*/*');
+ ## The following is a hideous workaround for a bug in vim
+ ## which breaks the perl6 plugin. It is there for my editing sanity
+ ## only, and does not affect the end result.
+ my $star = '*';
+ self.add-header('Accept'=>"$star/$star");
}
if $.method eq 'POST' | 'PUT' {
- $output ~= "Content-Type: $!type$CRLF";
+ self.add-header('Content-Type'=>$!type);
}
- for @!headers -> $header {
- if $header.key eq 'Content-Type' | 'Content-Length' { next; }
- $output ~= "{$header.key}: {$header.value}$CRLF";
+ if $!auth {
+ if $!auth eq 'Basic' { ## Only one we're supporting right now.
+ my $authstring = self.base64encode($!user, $!pass);
+ self.add-header('Authorization'=>"Basic $authstring");
+ }
}
- if ($.method eq 'POST' | 'PUT') && $!data {
+ if $!data {
if $!type eq MULTIPART {
+ ## End our default boundary.
$!data ~= "--{$!boundary}--$CRLF";
}
- my $length = $!data.chars;
- $output ~= "Content-Length: $length$CRLF";
- $output ~= $CRLF
- $output ~= $!data;
+ my $length = $!data.bytes;
+ self.add-header('Content-Length'=>$length);
+ }
+ ## Okay, add the headers.
+ for @!headers -> $header {
+ if $header.key eq 'Content-Type' | 'Content-Length' { next; }
+ $output ~= "{$header.key}: {$header.value}$CRLF";
+ }
+ if $!data {
+ $output ~= $CRLF; ## Add a blank line, notifying the end of headers.
+ $output ~= $!data; ## Add the data.
}
return $output;
}
+
+## Execute the request. This is actually just a convenience
+## wrapper for do-request() in the HTTP::Client class.
+method run (:$follow) {
+ $.client.do-request(self, :$follow);
+}
+
Oops, something went wrong.

0 comments on commit d780c12

Please sign in to comment.