Bio/DB/GenericWebAgent.pm

   1 # $Id$
   2 #
   3 # BioPerl module for Bio::DB::GenericWebAgent
   4 #
   5 # Cared for by Chris Fields <cjfields at uiuc dot edu>
   6 #
   7 # Copyright Chris Fields
   8 #
   9 # You may distribute this module under the same terms as perl itself
  10 #
  11 # POD documentation - main docs before the code
  12 #
  13 # Interfaces with new GenericWebAgent interface
  14
  15 =head1 NAME
  16
  17 Bio::DB::GenericWebAgent - helper base class for parameter-based remote server
  18 access and response retrieval.
  19
  20 =head1 SYNOPSIS
  21
  22   # DO NOT USE DIRECTLY
  23
  24   See Bio::DB::EUtilities for an example implementation
  25
  26 =head1 DESCRIPTION
  27
  28 WARNING: Please do B<NOT> spam the web servers with multiple requests.
  29
  30 Bio::DB::GenericWebAgent is a generic wrapper around a web agent
  31 (LWP::UserAgent), an object which can retain, format, and build parameters for
  32 the user agent (Bio::ParameterBaseI), and a BioPerl class parser that processes
  33 response content received by the user agent. The Bio::ParameterBaseI object
  34 should be state-aware, e.g. know when changes occur to parameters, so that
  35 identical requests are not repeatedly sent to the server (this base class takes
  36 this into consideration).
  37
  38 =head1 FEEDBACK
  39
  40 =head2 Mailing Lists
  41
  42 User feedback is an integral part of the
  43 evolution of this and other Bioperl modules. Send
  44 your comments and suggestions preferably to one
  45 of the Bioperl mailing lists. Your participation
  46 is much appreciated.
  47
  48   bioperl-l@lists.open-bio.org               - General discussion
  49   http://www.bioperl.org/wiki/Mailing_lists  - About the mailing lists
  50
  51 =head2 Reporting Bugs
  52
  53 Report bugs to the Bioperl bug tracking system to
  54 help us keep track the bugs and their resolution.
  55 Bug reports can be submitted via the web.
  56
  57   http://bugzilla.open-bio.org/
  58
  59 =head1 AUTHOR
  60
  61 Email cjfields at uiuc dot edu
  62
  63 =head1 APPENDIX
  64
  65 The rest of the documentation details each of the
  66 object methods. Internal methods are usually
  67 preceded with a _
  68
  69 =cut
  70
  71 # Let the code begin...
  72
  73 package Bio::DB::GenericWebAgent;
  74 use strict;
  75 use warnings;
  76 use base qw(Bio::Root::Root);
  77 use LWP::UserAgent;
  78
  79 my $LAST_INVOCATION_TIME = 0;
  80
  81 =head2 new
  82
  83  Title   : new
  84  Usage   : Bio::DB::GenericWebAgent->new(@args);
  85  Function: Create new Bio::DB::GenericWebAgent instance.
  86  Returns :
  87  Args    : None specific to this base class.  Inheriting classes will
  88            likely set specific parameters in their constructor;
  89            Bio::DB::GenericWebAgent is primarily a test bed.
  90
  91 =cut
  92
  93 sub new {
  94     my ($class, @args) = @_;
  95     my $self = $class->SUPER::new(@args);
  96     $self->ua(LWP::UserAgent->new(env_proxy => 1,
  97             agent => ref($self)));
  98     $self->delay($self->delay_policy);
  99     return $self;
 100 }
 101
 102 =head1 GenericWebAgent methods
 103
 104 =head2 parameter_base
 105
 106  Title   : parameter_base
 107  Usage   : $dbi->parameter_base($pobj);
 108  Function: Get/Set Bio::ParameterBaseI.
 109  Returns : Bio::ParameterBaseI object
 110  Args    : Bio::ParameterBaseI object
 111
 112 =cut
 113
 114 # this will likely be overridden in subclasses
 115
 116 sub parameter_base {
 117     my ($self, $pobj) = @_;
 118     if ($pobj) {
 119         $self->throw('Not a Bio::ParameterBaseI')
 120             if !$pobj->isa('Bio::ParameterBaseI');
 121         $self->{'_parameter_base'} = $pobj;
 122     }
 123     return $self->{'_parameter_base'};
 124 }
 125
 126 =head2 ua
 127
 128  Title   : ua
 129  Usage   : $dbi->ua;
 130  Function: Get/Set LWP::UserAgent.
 131  Returns : LWP::UserAgent
 132  Args    : LWP::UserAgent
 133
 134 =cut
 135
 136 sub ua {
 137         my ($self, $ua) = @_;
 138         if( defined $ua && $ua->isa("LWP::UserAgent") ) {
 139                 $self->{'_ua'} = $ua;
 140         }
 141         return $self->{'_ua'};
 142 }
 143
 144 =head2 get_Response
 145
 146  Title   : get_Response
 147  Usage   : $agent->get_Response;
 148  Function: Get the HTTP::Response object by passing it an HTTP::Request (generated from
 149            Bio::ParameterBaseI implementation).
 150  Returns : HTTP::Response object or data if callback is used
 151  Args    : (optional)
 152
 153            -cache_response - flag to cache HTTP::Response object;
 154                              Default is 1 (TRUE, caching ON)
 155
 156            These are passed on to LWP::UserAgent::request() if stipulated
 157
 158            -cb     - use a LWP::UserAgent-compliant callback
 159            -file   - dumps the response to a file (handy for large responses)
 160                      Note: can't use file and callback at the same time
 161            -read_size_hint - bytes of content to read in at a time to pass to callback
 162  Note    : Caching and parameter checking are set
 163
 164 =cut
 165
 166 # TODO deal with small state-related bug where file
 167
 168 sub get_Response {
 169     my ($self, @args) = @_;
 170     my ($cache, $file, $cb, $size) = $self->_rearrange([qw(CACHE_RESPONSE FILE CB READ_SIZE_HINT)],@args);
 171     $self->throw("Can't have both callback and file") if $file && $cb;
 172     # make -file accept more perl-like write-append type data.
 173     $file =~ s{^>}{} if $file;
 174     my @opts = grep {defined $_} ($file || $cb, $size);
 175     $cache = (defined $cache && $cache == 0) ? 0 : 1;
 176     my $pobj = $self->parameter_base;
 177     if ($pobj->parameters_changed ||
 178         !$cache  ||
 179         !$self->{_response_cache} ||
 180         !$self->{_response_cache}->content) {
 181         my $ua = $self->ua;
 182         $self->_sleep; # institute delay policy
 183         $self->throw('No parameter object set; cannot form a suitable remote request') unless $pobj;
 184         my $request = $pobj->to_request;
 185         if ($self->authentication) {
 186             $request->proxy_authorization_basic($self->authentication)
 187         }
 188         $self->debug("Request is: \n",$request->as_string);
 189         # I'm relying on the useragent to throw the proper errors here
 190         my $response = $ua->request($request, @opts);
 191         if ($response->is_error) {
 192             $self->throw("Response Error\n".$response->message);
 193         }
 194         return $self->{_response_cache} = $response;
 195     } else {
 196         $self->debug("Returning cached HTTP::Response object\n");
 197         if ($file) {
 198             $self->_dump_request_content($file);
 199             # size isn't passed here, as the content is completely retrieved above
 200         } elsif ($cb) {
 201             $cb && ref($cb) eq 'CODE' && $cb->($self->{_response_cache}->content);
 202         }
 203         return $self->{_response_cache};
 204     }
 205 }
 206
 207 =head2 get_Parser
 208
 209  Title   : get_Parser
 210  Usage   : $agent->get_Parser;
 211  Function: Return HTTP::Response content (file, fh, object) attached to defined parser
 212  Returns : None
 213  Args    : None
 214  Note    : Abstract method; defined by implementation
 215
 216 =cut
 217
 218 sub get_Parser {
 219     shift->throw_not_implemented;
 220 }
 221
 222 =head2 delay
 223
 224  Title   : delay
 225  Usage   : $secs = $self->delay($secs)
 226  Function: get/set number of seconds to delay between fetches
 227  Returns : number of seconds to delay
 228  Args    : new value
 229
 230 NOTE: the default is to use the value specified by delay_policy().
 231 This can be overridden by calling this method.
 232
 233 =cut
 234
 235 sub delay {
 236    my $self = shift;
 237    return $self->{'_delay'} = shift if @_;
 238    return $self->{'_delay'};
 239 }
 240
 241 =head2 delay_policy
 242
 243  Title   : delay_policy
 244  Usage   : $secs = $self->delay_policy
 245  Function: return number of seconds to delay between calls to remote db
 246  Returns : number of seconds to delay
 247  Args    : none
 248
 249 NOTE: The default delay policy is 3s.  Override in subclasses to
 250 implement delays.  The timer has only second resolution, so the delay
 251 will actually be +/- 1s.
 252
 253 =cut
 254
 255 sub delay_policy {
 256    my $self = shift;
 257    return 3;
 258 }
 259
 260 =head2 _sleep
 261
 262  Title   : _sleep
 263  Usage   : $self->_sleep
 264  Function: sleep for a number of seconds indicated by the delay policy
 265  Returns : none
 266  Args    : none
 267
 268 NOTE: This method keeps track of the last time it was called and only
 269 imposes a sleep if it was called more recently than the delay_policy()
 270 allows.
 271
 272 =cut
 273
 274 sub _sleep {
 275    my $self = shift;
 276    my $last_invocation = $LAST_INVOCATION_TIME;
 277    if (time - $LAST_INVOCATION_TIME < $self->delay) {
 278       my $delay = $self->delay - (time - $LAST_INVOCATION_TIME);
 279       $self->debug("sleeping for $delay seconds\n");
 280       sleep $delay;
 281    }
 282    $LAST_INVOCATION_TIME = time;
 283 }
 284
 285 =head1 LWP::UserAgent related methods
 286
 287 =head2 proxy
 288
 289  Title   : proxy
 290  Usage   : $httpproxy = $db->proxy('http')  or
 291            $db->proxy(['http','ftp'], 'http://myproxy' )
 292  Function: Get/Set a proxy for use of proxy
 293  Returns : a string indicating the proxy
 294  Args    : $protocol : an array ref of the protocol(s) to set/get
 295            $proxyurl : url of the proxy to use for the specified protocol
 296            $username : username (if proxy requires authentication)
 297            $password : password (if proxy requires authentication)
 298
 299 =cut
 300
 301 sub proxy {
 302     my ($self,$protocol,$proxy,$username,$password) = @_;
 303     return if ( !defined $protocol || !defined $proxy );
 304     $self->authentication($username, $password)
 305     if ($username && $password);
 306     return $self->ua->proxy($protocol,$proxy);
 307 }
 308
 309 =head2 authentication
 310
 311  Title   : authentication
 312  Usage   : $db->authentication($user,$pass)
 313  Function: Get/Set authentication credentials
 314  Returns : Array of user/pass
 315  Args    : Array or user/pass
 316
 317 =cut
 318
 319 sub authentication{
 320    my ($self,$u,$p) = @_;
 321    if( defined $u && defined $p ) {
 322        $self->{'_authentication'} = [ $u,$p];
 323    }
 324    $self->{'_authentication'} && return @{$self->{'_authentication'}};
 325 }
 326
 327 # private method to dump any cached request data content into a passed filename
 328
 329 sub _dump_request_content {
 330     my ($self, $file) = @_;
 331     return unless defined $self->{_response_cache};
 332     $self->throw("Must pass file name") unless $file;
 333     require Bio::Root::IO;
 334     my $out = Bio::Root::IO->new(-file => ">$file");
 335     $out->_print($self->{_response_cache}->content);
 336     $out->flush();
 337     $out->close;
 338 }
 339
 340 1;