root/trunk/extlib/Net/OpenID/URIFetch.pm @ 3531

#!/usr/bin/perl

=head1 NAME

Net::OpenID::URIFetch - fetch and cache content from HTTP URLs

=head1 DESCRIPTION

This is roughly based on Ben Trott's URI::Fetch module, but
URI::Fetch doesn't cache enough headers that Yadis can be implemented
with it, so this is a lame copy altered to allow Yadis support.

Hopefully one day URI::Fetch can be modified to do what we need and
this can go away.

This module is tailored to the needs of Net::OpenID::Consumer and probably
isn't much use outside of it. See URI::Fetch for a more general module.

=cut

package Net::OpenID::URIFetch;

use HTTP::Request;
use HTTP::Status;
use strict;
use warnings;
use Carp;

our $HAS_ZLIB;
BEGIN {
    $HAS_ZLIB = eval "use Compress::Zlib (); 1;";
}

use constant URI_OK                => 200;
use constant URI_MOVED_PERMANENTLY => 301;
use constant URI_NOT_MODIFIED      => 304;
use constant URI_GONE              => 410;

sub fetch {
    my ($class, $uri, $consumer, $content_hook) = @_;

    if ($uri eq 'x-xrds-location') {
        Carp::confess("Buh?");
    }

    my $ua = $consumer->ua;
    my $cache = $consumer->cache;
    my $ref;

    # By prefixing the cache key, we can ensure we won't
    # get left-over cache items from older versions of Consumer
    # that used URI::Fetch.
    my $cache_key = 'URIFetch:'.$uri;

    if ($cache) {
        if (my $blob = $cache->get($cache_key)) {
            $ref = Storable::thaw($blob);
        }
    }

    # We just serve anything from the last 60 seconds right out of the cache,
    # thus avoiding doing several requests to the same URL when we do
    # Yadis, then HTML discovery.
    # TODO: Make this tunable?
    if ($ref && $ref->{CacheTime} > (time() - 60)) {
        $consumer->_debug("Cache HIT for $uri");
        return Net::OpenID::URIFetch::Response->new(
            status => 200,
            content => $ref->{Content},
            headers => $ref->{Headers},
            final_uri => $ref->{FinalURI},
        );
    }
    else {
        $consumer->_debug("Cache MISS for $uri");
    }

    my $req = HTTP::Request->new(GET => $uri);
    if ($HAS_ZLIB) {
        $req->header('Accept-Encoding', 'gzip');
    }
    if ($ref) {
        if (my $etag = ($ref->{Headers}->{etag})) {
            $req->header('If-None-Match', $etag);
        }
        if (my $ts = ($ref->{Headers}->{'last-modified'})) {
            $req->if_modified_since($ts);
        }
    }

    my $res = $ua->request($req);

    # There are only a few headers that OpenID/Yadis care about
    my @useful_headers = qw(last-modified etag content-type x-yadis-location x-xrds-location);

    my %response_fields;

    if ($res->code == HTTP::Status::RC_NOT_MODIFIED()) {
        $consumer->_debug("Server says it's not modified. Serving from cache.");
        return Net::OpenID::URIFetch::Response->new(
            status => 200,
            content => $ref->{Content},
            headers => $ref->{Headers},
            final_uri => $ref->{FinalURI},
        );
    }
    else {
        my $content = $res->content;
        my $final_uri = $res->request->uri->as_string();
        my $final_cache_key = "URIFetch:".$final_uri;

        if ($res->content_encoding && $res->content_encoding eq 'gzip') {
            $content = Compress::Zlib::memGunzip($content);
        }

        if ($content_hook) {
            $content_hook->(\$content);
        }

        my $headers = {};
        foreach my $k (@useful_headers) {
            $headers->{$k} = $res->header($k);
        }

        my $ret = Net::OpenID::URIFetch::Response->new(
            status => $res->code,
            content => $content,
            headers => $headers,
            final_uri => $final_uri,
        );

        if ($cache && $res->code == 200) {
            my $cache_data = {
                Headers => $ret->headers,
                Content => $ret->content,
                CacheTime => time(),
                FinalURI => $final_uri,
            };
            my $cache_blob = Storable::freeze($cache_data);
            $cache->set($final_cache_key, $cache_blob);
            $cache->set($cache_key, $cache_blob);
        }

        return $ret;
    }

}

package Net::OpenID::URIFetch::Response;

sub new {
    my ($class, %opts) = @_;

    my $self = {};
    $self->{final_uri} = delete($opts{final_uri});
    $self->{status} = delete($opts{status});
    $self->{content} = delete($opts{content});
    $self->{headers} = delete($opts{headers});

    return bless $self, $class;
}

sub final_uri {
    return $_[0]->{final_uri};
}

sub status {
    return $_[0]->{status};
}

sub content {
    return $_[0]->{content};
}

sub headers {
    return $_[0]->{headers};
}

sub header {
    return $_[0]->{headers}{lc($_[1])};
}

1;