[Rt-commit] [svn] r856 - in RT-Client: . lib/RT
autrijus at pallas.eruditorum.org
autrijus at pallas.eruditorum.org
Fri May 7 20:24:56 EDT 2004
Author: autrijus
Date: Fri May 7 20:24:56 2004
New Revision: 856
Modified:
RT-Client/ (props changed)
RT-Client/lib/RT/Client.pm
Log:
----------------------------------------------------------------------
r4541 at not: autrijus | 2004-05-08T00:11:53.261405Z
* Switch to the much more robust, redirect-friendly LWP Authen framework.
----------------------------------------------------------------------
Modified: RT-Client/lib/RT/Client.pm
==============================================================================
--- RT-Client/lib/RT/Client.pm (original)
+++ RT-Client/lib/RT/Client.pm Fri May 7 20:24:56 2004
@@ -55,9 +55,8 @@
=head1 DESCRIPTION
This module implements a client API for RT, based on the Atom API.
-
-The dependency on L<XML::Atom> is coincidential and may one day be
-dropped in favor of a lighter-weight framework.
+Please refer to L<http://sfork.org/NoAuth/spec.html> for the server-side
+specification.
=cut
@@ -108,28 +107,9 @@
$self->server($args{Server}) if defined $args{Server};
$self->path($args{Path}) if defined $args{Path};
- return $self;
-}
-
-sub password {
- my $self = shift;
-
- my $realm = $self->realm;
- my $username = $self->username;
-
- if (@_) {
- $self->SUPER::password(@_);
- defined $realm or return;
- defined $username or return;
- }
- elsif (!defined $realm) {
- die 'Must set $self->server before retrieving $self->password';
- }
- elsif (!defined $username) {
- die 'Must set $self->username before retrieving $self->password';
- }
+ $self->{ua} = LWP::UserAgent::AtomClient->new($self);
- return md5_hex(join(':', $username, $realm, md5_hex($self->{password})));
+ return $self;
}
sub path {
@@ -138,12 +118,6 @@
return $self->{path} || '/Atom/0.3';
}
-sub realm {
- my $self = shift;
- $self->{realm} = shift if @_;
- return $self->{realm};
-}
-
sub current_user {
my $self = shift;
$self->{current_user} = shift if @_;
@@ -158,10 +132,7 @@
sub server {
my $self = shift;
- if (@_) {
- $self->{server} = shift;
- $self->realm($self->server_realm);
- }
+ $self->{server} = shift if @_;
return $self->{server};
}
@@ -170,21 +141,6 @@
return join('/', $self->server . $self->path, @_ ? @_ : '');
}
-sub server_realm {
- my $self = shift;
- my $req = HTTP::Request->new(HEAD => $self->server_uri);
- $self->munge_request($req);
-
- my $res = $self->{ua}->request($req);
-
- my $wsse = $res->header('WWW-Authenticate')
- or die "Bad RT server";
- $wsse =~ /\bWSSE (?=.*\bprofile="UsernameToken").*?\brealm="(.*?)"/
- or die "Bad WWW-Authenticate: $wsse";
-
- return $1;
-}
-
sub munge_request {
my ($self, $req) = @_;
$req->header(
@@ -196,36 +152,16 @@
$req->header(
'Accept-Charset' => $self->encoding,
);
- return $req unless $self->realm;
- return $self->SUPER::munge_request($req);
+ return $req;
}
sub munge_response {
my ($self, $res) = @_;
+
$self->current_user($res->header( 'X-RT-CurrentUser' ));
return $self->SUPER::munge_response($res);
}
-# The algorithm here is pure lazy loading - nothing gets retrived for sure
-# until the first autoload is called upon that object.
-#
-# Whenever AUTOLOAD is called with something that is not found in the {links}
-# table, a representation of the object is fetched and all links put into
-# {links} as the proper type of sub-object.
-#
-# The discovery process: Get each <link>, and look at the 'title' attribute:
-#
-# Prefixed with '_': skipped.
-# Prefixed with '!': an action for this object. store in {actions}.
-# Otherwise: A link. store in {links}.
-#
-# The 'href' attribute is the link to be stored. The 'rel' attribute determines
-# the type of the link:
-#
-# "service.feed": a Container.
-# "service.edit": an Object.
-# "service.post": an action supported by the object that shares the same 'title'.
-#
# For example, the main page has following links:
#
# Groups-feed http://localhost/Atom/0.3/RT-Groups
@@ -259,9 +195,102 @@
my ($self, $links) = @_;
}
+package LWP::UserAgent::AtomClient;
+
+use strict;
+our @ISA = 'LWP::UserAgent';
+require Digest::MD5;
+require LWP::UserAgent;
+
+my %ClientOf;
+
+sub new {
+ my ($class, $client) = @_;
+ my $ua = $client->{ua};
+ my $new_ua = bless($ua, $class);
+ $ClientOf{$new_ua} = $client;
+ return $new_ua;
+}
+
+sub get_basic_credentials {
+ my ($self, $realm, $url, $proxy) = @_;
+ my $client = $ClientOf{$self} or die "Cannot find $self";
+ return $client->username, Digest::MD5::md5_hex(
+ join(':',
+ $client->username,
+ $realm,
+ Digest::MD5::md5_hex($client->password)
+ )
+ );
+}
+
+sub DESTROY {
+ my $self = shift;
+ delete $ClientOf{$self};
+}
+
+package LWP::Authen::Wsse;
+use strict;
+
+require Digest::MD5;
+require Digest::SHA1;
+require MIME::Base64;
+
+sub authenticate {
+ my($class, $ua, $proxy, $auth_param, $response,
+ $request, $arg, $size) = @_;
+
+ my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
+ $request->url, $proxy);
+ return $response unless defined $user and defined $pass;
+
+ my $nonce = $class->make_nonce;
+ my $nonce_enc = MIME::Base64::encode_base64($nonce, '');
+ my $now = DateTime->now->iso8601 . 'Z';
+ my $digest = MIME::Base64::encode_base64(
+ Digest::SHA1::sha1($nonce . $now . ($pass || '')), ''
+ );
+
+ my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
+ my $wsse_value = sprintf(
+ qq(UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"),
+ $user || '',
+ $digest,
+ $nonce_enc,
+ $now,
+ );
+
+ my $referral = $request->clone;
+
+ # Need to check this isn't a repeated fail!
+ my $r = $response;
+ while ($r) {
+ my $wsse = $r->request->header('X-WSSE');
+ if ($wsse && $wsse eq $wsse_value) {
+ # here we know this failed before
+ $response->header("Client-Warning" =>
+ "Credentials for '$user' failed before");
+ return $response;
+ }
+ $r = $r->previous;
+ }
+
+ $referral->header($auth_header, 'WSSE profile="UsernameToken"');
+ $referral->header('X-WSSE' => $wsse_value);
+
+ # we shouldn't really do this, but...
+ $referral->{digest_user_pass} = [$user, $pass];
+
+ return $ua->request($referral, $arg, $size, $response);
+}
+
+sub make_nonce {
+ my $app = shift;
+ Digest::SHA1::sha1(Digest::SHA1::sha1(time() . {} . rand() . $$));
+}
1;
-# my $rt = RT::Client->new('http://root:password@localhost/');
-# print $rt->search('Queues')->as_xml;
+my $rt = RT::Client->new('http://root:password@localhost/');
+print $rt->search('Queues');#->as_xml;
More information about the Rt-commit
mailing list