Bio/DB/GenericWebAgent.pm

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