Show
Ignore:
Timestamp:
07/20/08 18:43:42 (4 months ago)
Author:
mart
Message:

Rework the discovery bits so that they all go through the same code path for HTTP, and implement a caching layer that actually works for both OpenID and Yadis.

URI::Fetch isn't really suitable since it doesn't cache enough information for our purposes. Hopefully at some point URI::Fetch can be improved so that we can use it, but for now this works.

Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • branches/openid2/perl/Net-OpenID-Consumer/lib/Net/OpenID/Yadis.pm

    r136 r138  
    1515 
    1616use constant { 
    17     YR_HEAD => 0, 
    1817    YR_GET => 1, 
    1918    YR_XRDS => 2, 
    …… 
    2120 
    2221use fields ( 
    23             'cache',           # the Cache object sent to URI::Fetch 
    24             '_ua',             # Custom LWP::UserAgent instance to use 
    2522            'last_errcode',    # last error code we got 
    2623            'last_errtext',    # last error code we got 
    2724            'debug',           # debug flag or codeblock 
     25            'consumer',        # consumer object 
    2826            'identity_url',    # URL to be identified 
    2927            'xrd_url',         # URL of XRD file 
    …… 
    3634    my %opts = @_; 
    3735 
    38     $self->ua              ( delete $opts{ua}              ); 
    39     $self->cache           ( delete $opts{cache}           ); 
     36    $self->consumer(delete($opts{consumer})); 
    4037 
    4138    $self->{debug} = delete $opts{debug}; 
    …… 
    4643} 
    4744 
    48 sub cache   { &_getset; } 
     45sub consumer { &_getset; } 
     46 
    4947sub identity_url { &_getset; } 
    5048sub xrd_url { &_getset; } 
    5149sub xrd_objects { _pack_array(&_getset); } 
    52 sub _ua { &_getset; } 
    5350sub _getset { 
    5451    my $self = shift; 
    …… 
    112109} 
    113110 
    114 sub ua { 
    115     my $self = shift; 
    116     my $ua = shift if @_; 
    117     Carp::croak("Too many parameters") if @_; 
    118  
    119     if (($ua) || (!$self->{_ua})) { 
    120         $self->{_ua} = Net::OpenID::Yadis::UA->new($ua); 
    121     } 
    122  
    123     $self->{_ua}->{'ua'}; 
    124 } 
    125  
    126111sub _get_contents { 
    127112    my $self = shift; 
    128  
    129113    my  ($url, $final_url_ref, $content_ref, $headers_ref) = @_; 
    130     $final_url_ref ||= do { my $dummy; \$dummy; }; 
    131  
    132     my $ures = URI::Fetch->fetch($url, 
    133                                  UserAgent        => $self->_ua, 
    134                                  Cache            => $self->_ua->force_head ? undef : $self->cache, 
    135                                  ContentAlterHook =>  sub {my $htmlref = shift;$$htmlref =~ s/<body\b.*//is;}, 
    136                                  ) 
    137         or return $self->_fail("url_fetch_error", "Error fetching URL: " . URI::Fetch->errstr); 
    138  
    139     if ($ures->status == URI::Fetch::URI_GONE()) { 
    140         return $self->_fail("url_gone"); 
    141     } 
    142  
    143     my $res = $ures->http_response; 
    144  
    145     $$final_url_ref = $res->request->uri->as_string; 
    146     $res->headers->scan(sub{$headers_ref->{lc($_[0])} ||= $_[1];}); 
    147     $$content_ref = $ures->content; 
    148  
    149     return 1; 
     114 
     115    my $alter_hook = sub { 
     116        my $htmlref = shift; 
     117        $$htmlref =~ s/<body\b.*//is; 
     118    }; 
     119 
     120    my $res = Net::OpenID::URIFetch->fetch($url, $self->consumer, $alter_hook); 
     121 
     122    if ($res) { 
     123        $$final_url_ref = $res->final_uri; 
     124        my $headers = $res->headers; 
     125        foreach my $k (keys %$headers) { 
     126            $headers_ref->{$k} ||= $headers->{$k}; 
     127        } 
     128        $$content_ref = $res->content; 
     129        return 1; 
     130    } 
     131    else { 
     132        return undef; 
     133    } 
    150134} 
    151135 
    …… 
    153137    my $self = shift; 
    154138    my $url = shift or return $self->_fail("empty_url"); 
    155     my $count = shift || YR_HEAD;                              # $count = YR_HEAD:HEAD request YR_GET:GET request YR_XRDS:XRDS request 
     139    my $count = shift || YR_GET; 
    156140    Carp::croak("Too many parameters") if @_; 
    157141 
    …… 
    164148    my %headers; 
    165149 
    166     $self->_ua->force_head(1) if ($count == YR_HEAD); 
    167  
    168150    my $xrd; 
    169151    $self->_get_contents($url, \$final_url, \$xrd, \%headers) or return; 
    …… 
    173155    my $doc_url; 
    174156    if (($doc_url = $headers{'x-yadis-location'} || $headers{'x-xrds-location'}) && ($count < YR_XRDS)) { 
    175         return $self->discover($doc_url,YR_XRDS); 
    176     } elsif ($headers{'content-type'} eq 'application/xrds+xml') { 
    177         return $self->discover($final_url,YR_XRDS) if ((!$xrd) && ($count == YR_HEAD)); 
     157        return $self->discover($doc_url, YR_XRDS); 
     158    } 
     159    elsif ($headers{'content-type'} eq 'application/xrds+xml') { 
    178160        $self->xrd_url($final_url); 
    179161        return $self->parse_xrd($xrd); 
    180162    } 
    181  
    182     return $count == YR_HEAD ? $self->discover($final_url,YR_GET) : $self->_fail($count == YR_GET ? "no_yadis_document" :"too_many_hops"); 
     163    else { 
     164        return $self->_fail($count == YR_GET ? "no_yadis_document" : "too_many_hops"); 
     165    } 
    183166} 
    184167 
    …… 
    225208    my $code_ref; 
    226209    my $protocol = undef; 
    227      
     210 
    228211    Carp::croak("You haven't called the discover method yet") unless $self->xrd_objects; 
    229212 
    …… 
    258241} 
    259242 
    260 package Net::OpenID::Yadis::UA; 
    261  
    262 # This module is decolation module to LWP::UserAgent. 
    263 # This add application/xrds+xml HTTP header and GET method to request object used in URI::Fetch. 
    264  
    265 use strict; 
    266 use warnings; 
    267 use LWP::UserAgent; 
    268 use vars qw($AUTOLOAD $lwpclass); 
    269  
    270 BEGIN { 
    271     eval "use LWPx::ParanoidAgent;"; 
    272     $lwpclass = $@ ? "LWP::UserAgent" : "LWPx::ParanoidAgent"; 
    273 } 
    274  
    275 sub new { 
    276     my $class = shift; 
    277     my $ua = shift; 
    278     unless ($ua) { 
    279         $ua = $lwpclass->new; 
    280         $ua->timeout(10); 
    281     } 
    282     bless {ua => $ua,force_head => 0},$class; 
    283 } 
    284  
    285 sub request { 
    286     my $self = shift; 
    287     my $req = shift; 
    288     $req->header('Accept' => 'application/xrds+xml'); 
    289     $req->method($self->force_head ? "HEAD" : "GET"); 
    290     $self->force_head(0); 
    291     $self->{'ua'}->request($req); 
    292 } 
    293  
    294 sub force_head { 
    295     $_[0]->{'force_head'} = $_[1] if defined($_[1]); 
    296     $_[0]->{'force_head'}; 
    297 } 
    298  
    299 sub AUTOLOAD { 
    300     my $self = shift; 
    301     return if $AUTOLOAD =~ /::DESTROY$/; 
    302     $AUTOLOAD =~ s/.*:://; 
    303     $self->{'ua'}->$AUTOLOAD(@_); 
    304 } 
    305  
    3062431; 
    307244__END__ 
    …… 
    316253   
    317254  my $disc = Net::OpenID::Yadis->new( 
    318                                          ua => $ua,       # LWP::UserAgent (or similar) object 
    319                                          cache => $cache  # Cache object 
    320                                      ); 
     255      consumer => $consumer, # Net::OpenID::Consumer object 
     256  ); 
    321257 
    322258  my $xrd = $disc->discover("http://id.example.com/") or Carp::croak($disc->err); 
    …… 
    351287but was forked and simplified for inclusion in the core OpenID Consumer package. 
    352288 
     289This simplified version is tailored for the needs of Net::OpenID::Consumer; for other 
     290uses, L<Net::Yadis::Discovery> is probably a better choice. 
     291 
    353292=head1 CONSTRUCTOR 
    354293 
    …… 
    359298my $disc = Net::OpenID::Yadis->new([ %opts ]); 
    360299 
    361 You can set the C<ua> and C<cache> in the constructor.  See the corresponding  
    362 method descriptions below. 
     300You can set the C<consumer> in the constructor.  See the corresponding  
     301method description below. 
    363302 
    364303=back 
    …… 
    370309=over 4 
    371310 
    372 =item C<YR_HEAD> 
    373  
    374 If you set this value to option argument of discover method, module check Yadis  
    375 URL start from HTTP HEAD request. 
    376  
    377311=item C<YR_GET> 
    378312 
    379 If you set this, module check Yadis URL start from HTTP GET request. 
     313If you set this, module check Yadis URL start from HTTP GET request. This is the default. 
    380314 
    381315=item C<YR_XRDS> 
    382316 
    383 If you set this, this module consider Yadis URL as Yadis Resource Descriptor  
    384 URL. 
    385 If not so, error returns. 
     317If you set this, this module consider Yadis URL as Yadis Resource Descriptor URL. 
     318If not so, an error is returned. 
    386319 
    387320=back 
    …… 
    391324=over 4 
    392325 
    393 =item $disc->B<ua>($user_agent) 
    394  
    395 =item $disc->B<ua> 
    396  
    397 Getter/setter for the LWP::UserAgent (or subclass) instance which will 
    398 be used when web donwloads are needed.  It's highly recommended that 
    399 you use LWPx::ParanoidAgent, or at least read its documentation so 
    400 you're aware of why you should care. 
    401  
    402 =item $disc->B<cache>($cache) 
    403  
    404 =item $disc->B<cache> 
    405  
    406 Getter/setter for the optional (but recommended!) cache instance you 
    407 want to use for storing fetched parts of pages. 
    408  
    409 The $cache object can be anything that has a -E<gt>get($key) and 
    410 -E<gt>set($key,$value) methods.  See L<URI::Fetch> for more 
    411 information.  This cache object is just passed to L<URI::Fetch> 
    412 directly. 
     326=item $disc->B<consumer>($consumer) 
     327 
     328=item $disc->B<consumer> 
     329 
     330Get or set the Net::OpenID::Consumer object that this object is associated with. 
    413331 
    414332=item $disc->B<discover>($url,[$request_method]) 
    …… 
    525443L<Net::OpenID::Yadis::Service> 
    526444 
     445L<Net::OpenID::Consumer> 
     446 
    527447=head1 AUTHORS 
    528448