# -*- perl -*-
# $Id: RobotUA.pm,v 1.12 2004/02/10 15:19:19 langhein Exp $
# derived from: RobotUA.pm,v 1.18 2000/04/09 11:21:11 gisle Exp $


package LWP::Parallel::RobotUA;

use LWP::Parallel::UserAgent qw(:CALLBACK);
require LWP::RobotUA;
@ISA = qw(LWP::Parallel::UserAgent LWP::RobotUA Exporter);
$VERSION = sprintf("%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/);

@EXPORT = qw(); 
# callback commands
@EXPORT_OK = @LWP::Parallel::UserAgent::EXPORT_OK;
%EXPORT_TAGS = %LWP::Parallel::UserAgent::EXPORT_TAGS;

use LWP::Debug ();
require HTTP::Request;
require HTTP::Response;
use HTTP::Date qw(time2str);
use Carp();

use strict;

=head1 NAME

LWP::Parallel::RobotUA - A class for Parallel Web Robots

=head1 SYNOPSIS

  require LWP::Parallel::RobotUA;
  $ua = new LWP::Parallel::RobotUA 'my-robot/0.1', 'me@foo.com';
  $ua->delay(0.5);  # in minutes!
  ...
  # just use it just like a normal LWP::Parallel::UserAgent
  $ua->register ($request, \&callback, 4096); # or
  $ua->wait ( $timeout ); 

=head1 DESCRIPTION

This class implements a user agent that is suitable for robot
applications.  Robots should be nice to the servers they visit.  They
should consult the F</robots.txt> file to ensure that they are welcomed
and they should not make requests too frequently.

But, before you consider writing a robot take a look at
<URL:http://info.webcrawler.com/mak/projects/robots/robots.html>.

When you use a I<LWP::Parallel::RobotUA> as your user agent, then you do not
really have to think about these things yourself.  Just send requests
as you do when you are using a normal I<LWP::Parallel::UserAgent> and this
special agent will make sure you are nice.

=head1 METHODS

The LWP::Parallel::RobotUA is a sub-class of LWP::Parallel::UserAgent
and LWP::RobotUA and implements a mix of their methods.

In addition to LWP::Parallel::UserAgent, these methods are provided:

=cut

=head2 $ua = LWP::Parallel::RobotUA->new($agent_name, $from, [$rules])

Your robot's name and the mail address of the human responsible for
the robot (i.e. you) are required by the constructor.

Optionally it allows you to specify the I<WWW::RobotRules> object to
use. (See L<WWW::RobotRules::AnyDBM_File> for persistent caching of
robot rules in a local file)

=cut

#' fix emacs syntax parser

sub new {
    my($class,$name,$from,$rules) = @_;

    Carp::croak('LWP::Parallel::RobotUA name required') unless $name;
    Carp::croak('LWP::Parallel::RobotUA from address required') unless $from;

    my $self = new LWP::Parallel::UserAgent;
    $self = bless $self, $class;

    $self->{'delay'}     = 1;   # minutes again (used to be seconds)!!
    $self->{'use_sleep'} = 1;
    $self->{'agent'} = $name;
    $self->{'from'}  = $from;
    # current netloc's we're checking:
    $self->{'checking'} = {};

    if ($rules) {
	$rules->agent($name);
	 $self->{'rules'} = $rules;
    } else {
	$self->{'rules'} = new WWW::RobotRules $name;
    }

    $self;
}

=head2 $ua->delay([$minutes])

Set/Get the minimum delay between requests to the same server.  The
default is 1 minute.

Note: Previous versions of LWP Parallel-Robot used I<Seconds> instead of 
      I<Minutes>! This is now compatible with LWP Robot.

=cut

# reuse LWP::RobotUA::delay here (just needed to clarify usage)

=head2 $ua->host_wait($netloc)

Returns the number of seconds you must wait before you can make a new
request to this server. This method keeps track of all of the robots
connection, and enforces the delay constraint specified via the delay
method above for each server individually.

Note: Although it says 'host', it really means 'netloc/server',
i.e. it differentiates between individual servers running on different
ports, even though they might be on the same machine ('host'). This
function is mostly used internally, where RobotUA calls it to find out
when to send the next request to a certain server.

=cut

sub host_wait
{
    my($self, $netloc) = @_;
    return undef unless defined $netloc;
    my $last = $self->{'rules'}->last_visit($netloc);
    if ($last) {
	my $wait = int($self->{'delay'} * 60 - (time - $last));
	$wait = 0 if $wait < 0;
	return $wait;
    }
    return 0;
}

=head2 $ua->as_string

Returns a string that describes the state of the UA.
Mainly useful for debugging.

=cut

sub as_string
{
    my $self = shift;
    my @s;
    push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
    push(@s, "    Minimum delay: " . int($self->{'delay'}) . " minutes");
    push(@s, "    Rules = $self->{'rules'}");
    join("\n", @s, '');
}


#
# private methods (reimplementations of LWP::Parallel::UserAgent methods)
#

# this method now first checks the robot rules. It will try to
# download the robots.txt file before proceeding with any more
# requests to an unvisited site.
# It will also observe the delay specified in our ->delay method
sub _make_connections_in_order {
    my $self = shift;
    LWP::Debug::trace('()');

    my($failed_connections, $remember_failures, $ordpend_connections, $rules) =
      @{$self}{qw(failed_connections remember_failures 
		  ordpend_connections rules)};

    my ($entry, @queue, %busy);
    # get first entry from pending connections
    while ( $entry = shift @$ordpend_connections ) {

	my $request = $entry->request;
	my $netloc  = eval { local $SIG{__DIE__}; $request->url->host_port; };

        if ( $remember_failures and $failed_connections->{$netloc} ) {
	    my $response = $entry->response;
	    $response->code (&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
	    $response->message ("Server unavailable");
	    # simulate immediate response from server
	    $self->on_failure ($entry->request, $response, $entry);
	    next;
	  }

	push (@queue, $entry), next  if $busy{$netloc};

	# Do we try to access a new server?
	my $allowed = $rules->allowed($request->url);
	# PS: pending Robots.txt requests are always allowed! (hopefully)

	if ($allowed < 0) {
	  LWP::Debug::debug("Host not visited before, or robots.".
			    "txt expired: ($allowed) ".$request->url);
	    my $checking = $self->_checking_robots_txt ($netloc);
	    # let's see if we're already busy checkin' this host
	    if ( $checking > 0 ) {
	      LWP::Debug::debug("Already busy checking here. Request queued");
		push (@queue, $entry);
	    } elsif ( $checking < 0 ) {
		# We already checked here. Seems the robots.txt
		# expired afterall. Pretend we're allowed
	      LWP::Debug::debug("Checked this host before. robots.txt".
				" expired. Assuming access ok");
		$allowed = 1; 
	    } else { 
		# fetch "robots.txt"
		my $robot_url = $request->url->clone;
		$robot_url->path("robots.txt");
		$robot_url->query(undef);
	      LWP::Debug::debug("Requesting $robot_url");

		# make access to robot.txt legal since this might become
		# a recursive call (in case we lack bandwith to connect
		# immediately) 
		$rules->parse($robot_url, ""); 

		my $robot_req = new HTTP::Request 'GET', $robot_url;
		my $response = HTTP::Response->new(0, '<empty response>'); 
		$response->request($robot_req);

		my $robot_entry = new LWP::Parallel::UserAgent::Entry { 
		    request  	=> $robot_req, 
		    response 	=> $response, 
		    size	=> 8192, 
		    redirect_ok => 0,
		    arg 	=> sub {
			# callback function (closure)
			my ($content, $robot_res, $protocol) = @_;
                        my $netloc = eval { local $SIG{__DIE__}; 
                                            $request->url->host_port; };
			# unset flag - we're done checking
			$self->_checking_robots_txt ($netloc, -1);
		        $rules->visit($netloc);

			my $fresh_until = $robot_res->fresh_until;
			if ($robot_res->is_success) {
		          my $c = $robot_res->content;
	                  if ($robot_res->content_type =~ m,^text/, && 
			      $c =~ /Disallow/) {
			    LWP::Debug::debug("Parsing robot rules for ". 
			  		      $netloc);
		            $rules->parse($robot_url, $c, $fresh_until);
	                  }
	                  else {
		            LWP::Debug::debug("Ignoring robots.txt for ".
				              $netloc);
		            $rules->parse($robot_url, "", $fresh_until);
	                  }
			} else {
			  LWP::Debug::debug("No robots.txt file found at " . 
					    $netloc);
			    $rules->parse($robot_url, "", $fresh_until);
			}
		    },
		};
		# immediately try to connect (if bandwith available)
		push (@queue, $robot_entry), $busy{$netloc}++  
		    unless  $self->_check_bandwith($robot_entry);
		# mark this host as being checked
		$self->_checking_robots_txt ($netloc, 1);
		# don't forget to queue the entry that triggered this request
		push (@queue, $entry);
	    }
	} 

	unless ($allowed) {
	    # we're not allowed to connect to this host
	    my $res = new HTTP::Response
		&HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt';
	    $entry->response($res);
	    # silently drop entry here from ordpend_connections
	} elsif ($allowed > 0) {
	    # check robot-wait information to see if we have to wait
	    my $wait = $self->host_wait($netloc);
	    
	    # if so, push on @queue queue
	    if ($wait) {
	      LWP::Debug::trace("Must wait $wait more seconds (sleep is ".
	        ($self->{'use_sleep'} ? 'on' : 'off') . ")");
	      if ($self->{'use_sleep'}) {
	        # well, we don't really use sleep, but lets emulate
		# the standard LWP behavior as closely as possible...
		push (@queue, $entry);
		
		# now we also have to raise a red flag for all
		# remaining entries at this particular
		# host. Otherwise we might block the first x
		# requests to this server, but have finally waited
		# long enough when the x+1 request comes off the
		# queue, and then we would connect to the x+1
		# request before any of the first x requests
		# (which is not what we want!)
		$busy{$netloc}++;
              } else {
	        LWP::Debug::debug("'use_sleep' disabled, generating response");
	        my $res = new HTTP::Response
	          &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down';
	        $res->header('Retry-After', time2str(time + $wait));
	        $entry->response($res);
	      }
	    } else { # check bandwith
		unless ( $self->_check_bandwith($entry) ) {
		    # if _check_bandwith returns a value, it means that
		    # no bandwith is available: push $entry on queue
		    push (@queue, $entry);
		    $busy{$netloc}++;
		} else {
		    $rules->visit($netloc);
		}
	    }
	}
    }
    # the un-connected entries form the new stack
    $self->{'ordpend_connections'} = \@queue;
}

# this method now first checks the robot rules. It will try to
# download the robots.txt file before proceeding with any more
# requests to an unvisited site.
# It will also observe the delay specified in our ->delay method
sub _make_connections_unordered {
    my $self = shift;
    LWP::Debug::trace('()');
		      
    my($pending_connections, $failed_connections, $remember_failures, $rules) =
      @{$self}{qw(pending_connections failed_connections 
		  remember_failures rules)};

    my ($entry, $queue, $netloc);

    my %delete;
    # check every host in sequence (use 'each' for better performance)
  SERVER:
    while (($netloc, $queue) = each %$pending_connections) {
	
        # since we shouldn't alter the hash itself while iterating through it
        # via 'each', we'll make a note here for each netloc that has an
        # empty queue, so that we can explicitly delete them afterwards:
        unless (@$queue) {
	  LWP::Debug::debug("Marking empty queue for '$netloc' for deletion");
	    $delete{$netloc}++;
	    next SERVER;
        }
	
        # check if we already tried to connect to this location, and failed
        if ( $remember_failures and $failed_connections->{$netloc} ) {
	  LWP::Debug::debug("Removing all ". scalar @$queue . 
			    " entries for unreachable host '$netloc'");
	    while ( $entry = shift @$queue ) {
		my $response = $entry->response;
		$response->code (&HTTP::Status::RC_INTERNAL_SERVER_ERROR);
		$response->message ("Server unavailable");
		# simulate immediate response from server
		$self->on_failure ($entry->request, $response, $entry);
	    }
	    # make sure we delete this netloc-entry later
	  LWP::Debug::debug("Marking empty queue for '$netloc' for deletion");
	    $delete{$netloc}++;
	    next SERVER;
        }
	
        # get first entry from pending connections at this host
        while ( $entry = shift @$queue ) {
	    my $request = $entry->request;
	    
	    # Do we try to access a new server?
	    my $allowed = $rules->allowed($request->url);
	    # PS: pending Robots.txt requests are always allowed! (hopefully)
	    
	    if ($allowed < 0) {
	      LWP::Debug::debug("Host not visited before, or robots.".
				"txt expired: ".$request->url);
		my $checking = $self->_checking_robots_txt 
		    ($request->url->host_port);
		# let's see if we're already busy checkin' this host
		if ( $checking > 0 ) {
		    # if so, don't register yet another robots.txt request!
		  LWP::Debug::debug("Already busy checking here. ".
				    "Request queued");
		    unshift (@$queue, $entry);
		    next SERVER;
		} elsif ( $checking < 0 ) {
		    # We already checked here. Seems the robots.txt
		    # expired afterall. Pretend we're allowed
		  LWP::Debug::debug("Checked this host before. ".
				    "robots.txt expired. Assuming access ok");
		    $allowed = 1; 
		} else { 
		    # queue the entry that triggered this request
		    unshift (@$queue, $entry);
		    # fetch "robots.txt" (i.e. create & issue robot request)
		    my $robot_url = $request->url->clone;
		    $robot_url->path("robots.txt");
		    $robot_url->query(undef);
		  LWP::Debug::debug("Requesting $robot_url");
		    
		    # make access to robot.txt legal since this might become
		    # a recursive call (in case we lack bandwith to connect
		    # immediately) 
		    $rules->parse($robot_url, ""); 
		    
		    my $robot_req = new HTTP::Request 'GET', $robot_url;
		    my $response = HTTP::Response->new(0, '<empty response>'); 
		    $response->request($robot_req);
		    
		    my $robot_entry = new LWP::Parallel::UserAgent::Entry { 
			request  	=> $robot_req, 
			response 	=> $response, 
			size	=> 8192, 
			redirect_ok => 0,
			arg 	=> sub {
			    # callback function (closure)
			    my ($content, $robot_res, $protocol) = @_;
                            my $netloc = eval { local $SIG{__DIE__}; 
                                                $request->url->host_port; };
			    # unset flag - we're done checking
			    $self->_checking_robots_txt ($netloc, -1);
		            $rules->visit($netloc);
			    
			    my $fresh_until = $robot_res->fresh_until;
			    if ($robot_res->is_success) {
			      my $c = $content; # thanks to Vlad Ciubotariu
	                      if ($robot_res->content_type =~ m,^text/, && 
			          $c =~ /Disallow/) {
			        LWP::Debug::debug("Parsing robot rules for ". 
				  		  $netloc);
		                $rules->parse($robot_url, $c, $fresh_until);
	                      }
	                      else {
		                LWP::Debug::debug("Ignoring robots.txt for ".
				                  $netloc);
		                $rules->parse($robot_url, "", $fresh_until);
	                      }
			    } else {
			      LWP::Debug::debug("No robots.txt file found at ".
						$netloc);
				$rules->parse($robot_url, "", $fresh_until);
			    }
			},
		    };
		    # mark this host as being checked
		    $self->_checking_robots_txt ($request->url->host_port, 1);
		    # immediately try to connect (if bandwith available)
		    unless ( $self->_check_bandwith($robot_entry) ) {
			unshift (@$queue, $robot_entry);
		    }
		    # we can move to the next server either way, since
		    # we'll have to wait for the results of the
		    # robot.txt request anyways
		    next SERVER;
		}
	    } 
	    
	    unless ($allowed) {
		# we're not allowed to connect to this host
		my $res = new HTTP::Response
		    &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt';
		$entry->response($res);
		# silently drop entry here from pending_connections
	    } elsif ($allowed > 0) {
		my $netloc = eval { local $SIG{__DIE__}; 
                                    $request->url->host_port; }; # LWP 5.60
		
		# check robot-wait information to see if we have to wait
		my $wait = $self->host_wait($netloc);
		
		# if so, push on @$queue queue
		if ($wait) {
	          LWP::Debug::trace("Must wait $wait more seconds (sleep is ".
	            ($self->{'use_sleep'} ? 'on' : 'off') . ")");
	          if ($self->{'use_sleep'}) {
		    unshift (@$queue, $entry);
		    next SERVER;
		  } else {
                    LWP::Debug::debug("'use_sleep' disabled");
	            my $res = new HTTP::Response
	             &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down';
	            $res->header('Retry-After', time2str(time + $wait));
	            $entry->response($res);
	          }
		} else { # check bandwith
		    unless ( $self->_check_bandwith($entry) ) {
			# if _check_bandwith returns undef, it means that
			# no bandwith is available: push $entry on queue
		      LWP::Debug::debug("Not enough bandwidth for ".
					"request to $netloc");
			unshift (@$queue, $entry);
			next SERVER;
		    } else {
			# make sure we update the time of our last
			# visit to this site properly
			$rules->visit($netloc);
		    }
		}
	    }
	  LWP::Debug::debug("Queue for $netloc contains ". 
			    scalar @$queue . " pending connections");
	    $delete{$netloc}++ unless scalar @$queue;
	}
    }
    # clean up: (we do this outside of the loop since we're not
    # suppose to alter an associative array (hash) while iterating
    # through it using 'each')
    foreach (keys %delete) { 
      LWP::Debug::debug("Deleting queue for '$_'");
	delete $self->{'pending_connections'}->{$_} 
    }
}


# request-slots available at host (checks for robots lock)
sub _req_available { 
    my ( $self, $url ) = @_;
    # check if blocked
    if ( $self->_checking_robots_txt($url->host_port) ) {
	return 0;
    } else {
	# else use superclass method
	$self->SUPER::_req_available($url);
    }
};


#
# new private methods
#

# sets/get robot lock for given host.
sub _checking_robots_txt {
    my ($self, $netloc, $lock) = @_;
    local $^W = 0; # prevent warnings here;

    $self->{'checking'}->{$netloc} = 0
      unless defined ($self->{'checking'}->{$netloc});

    if (defined $lock) {
	$self->{'checking'}->{$netloc} = $lock;
    } else {
	$self->{'checking'}->{$netloc};
    }
}

=head1 SEE ALSO

L<LWP::Parallel::UserAgent>, L<LWP::RobotUA>, L<WWW::RobotRules>

=head1 COPYRIGHT

Copyright 1997-2004 Marc Langheinrich E<lt>marclang@cpan.org>

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;