view release on metacpan or  search on metacpan

lib/Metabrik/Client/Www.pm  view on Meta::CPAN

         password => [ qw(password) ],
         ignore_content => [ qw(0|1) ],
         user_agent => [ qw(user_agent) ],
         ssl_verify => [ qw(0|1) ],
         datadir => [ qw(datadir) ],
         timeout => [ qw(0|1) ],
         rtimeout => [ qw(timeout) ],
         add_headers => [ qw(http_headers_hash) ],
         do_javascript => [ qw(0|1) ],
         do_redirects => [ qw(0|1) ],
         src_ip => [ qw(ip_address) ],
         max_redirects => [ qw(count) ],
         client => [ qw(object) ],
         _last => [ qw(object|INTERNAL) ],
         _last_code => [ qw(code|INTERNAL) ],
      },
      attributes_default => {
         ssl_verify => 0,
         ignore_content => 0,
         timeout => 0,
         rtimeout => 10,
         add_headers => {},
         do_javascript => 0,
         do_redirects => 1,
         max_redirects => 10,
      },
      commands => {
         install => [ ], # Inherited
         create_user_agent => [ ],
         reset_user_agent => [ ],
         get => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         cat => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         post => [ qw(content_hash uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         patch => [ qw(content_hash uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         put => [ qw(content_hash uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         head => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         delete => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         options => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         code => [ ],
         content => [ ],
         get_content => [ qw(uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         post_content => [ qw(content_hash uri|OPTIONAL username|OPTIONAL password|OPTIONAL) ],
         save_content => [ qw(output) ],
         headers => [ ],
         get_response_headers => [ ],
         delete_request_header => [ qw(header) ],
         get_response_header => [ qw(header) ],
         set_request_header => [ qw(header value|value_list) ],
         forms => [ ],
         links => [ ],
         trace_redirect => [ qw(uri|OPTIONAL) ],
         screenshot => [ qw(uri output) ],
         eval_javascript => [ qw(js) ],
         info => [ qw(uri|OPTIONAL) ],
         mirror => [ qw(url|$url_list output|OPTIONAL datadir|OPTIONAL) ],
         parse => [ qw(html) ],
         get_last => [ ],
         get_last_code => [ ],
      },
      require_modules => {
         'IO::Socket::SSL' => [ ],
         'Progress::Any::Output' => [ ],
         'Progress::Any::Output::TermProgressBarColor' => [ ],
         'Data::Dumper' => [ ],
         'HTML::TreeBuilder' => [ ],
         'LWP::UserAgent' => [ ],
         'LWP::UserAgent::ProgressAny' => [ ],
         'HTTP::Request' => [ ],
         'HTTP::Request::Common' => [ ],
         'WWW::Mechanize' => [ ],
         'Mozilla::CA' => [ ],
         'HTML::Form' => [ ],
         'Metabrik::File::Write' => [ ],
         'Metabrik::System::File' => [ ],
         'Metabrik::Network::Address' => [ ],
      },
      need_packages => {
         freebsd => [ qw(p5-LWP-Protocol-https) ],
         ubuntu => [ qw(liblwp-protocol-https-perl) ],
         debian => [ qw(liblwp-protocol-https-perl) ],
         kali => [ qw(liblwp-protocol-https-perl) ],
      },
      optional_modules => {
         'WWW::Mechanize::PhantomJS' => [ ],
      },
      optional_binaries => {
         phantomjs => [ ],
      },
   };
}

sub create_user_agent {
   my $self = shift;
   my ($uri, $username, $password) = @_;

   $self->log->debug("create_user_agent: creating agent");

   $uri ||= $self->uri;

   # Use IO::Socket::SSL which supports timeouts among other things.
   $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS} = 'IO::Socket::SSL';

   my $ssl_verify = $self->ssl_verify
      ? IO::Socket::SSL::SSL_VERIFY_PEER()
      : IO::Socket::SSL::SSL_VERIFY_NONE();

   my %args = (
      stack_depth => 0,  # Default is infinite, and will eat-up whole memory.
                         # 0 means completely turn off the feature.
      autocheck => 0,  # Do not throw on error by checking HTTP code. Let us do it.
      timeout => $self->rtimeout,
      ssl_opts => {
         verify_hostname => $self->ssl_verify,
         SSL_verify_mode => $ssl_verify,
         SSL_ca_file => Mozilla::CA::SSL_ca_file(),
         # SNI support - defaults to PeerHost
         # SSL_hostname => 'hostname',
      },
   );

   my $mechanize = 'WWW::Mechanize';
   if ($self->do_javascript) {
      if ($self->brik_has_module('WWW::Mechanize::PhantomJS')
      &&  $self->brik_has_binary('phantomjs')) {
         $mechanize = 'WWW::Mechanize::PhantomJS';
      }
      else {
         return $self->log->error("create_user_agent: module [WWW::Mechanize::PhantomJS] not found, cannot do_javascript");
      }
   }
   if ((! $self->do_redirects) && $mechanize eq 'WWW::Mechanize::PhantomJS') {
      $self->log->warning("create_user_agent: module [WWW::Mechanize::PhantomJS] does ".
         "not support do_redirects, won't use it.");
   }
   elsif ($self->do_redirects) {
      $args{max_redirect} = $self->max_redirects;
   }
   else {  # Follow redirects not wanted
      $args{max_redirect} = 0;
   }

   my $src_ip = $self->src_ip;
   if (defined($src_ip)) {
      my $na = Metabrik::Network::Address->new_from_brik_init($self) or return;
      if (! $na->is_ip($src_ip)) {
         return $self->log->error("create_user_agent: src_ip [$src_ip] is invalid");
      }
      $args{local_address} = $src_ip;
   }

   my $mech = $mechanize->new(%args);
   if (! defined($mech)) {
      return $self->log->error("create_user_agent: unable to create WWW::Mechanize object");
   }

   if ($self->user_agent) {
      $mech->agent($self->user_agent);
   }
   else {
      # Some WWW::Mechanize::* modules can't do that
      if ($mech->can('agent_alias')) {
         $mech->agent_alias('Linux Mozilla');
      }
   }

lib/Metabrik/Client/Www.pm  view on Meta::CPAN

   my $add_headers = $self->add_headers;
   if (defined($add_headers)) {
      for my $k (keys %$add_headers) {
         my $v = $add_headers->{$k};
         if (ref($v) eq 'ARRAY') {
            my $this = join('; ', @$v);
            $client->add_header($k => $this);
         }
         else {
            $client->add_header($k => $v);
         }
      }
   }

   $self->log->verbose("$method: $uri");

   my $response;
   eval {
      if ($method ne 'get' && ref($client) eq 'WWW::Mechanize::PhantomJS') {
         return $self->log->error("$method: method not supported by WWW::Mechanize::PhantomJS");
      }
      if ($method eq 'post' || $method eq 'put') {
         $response = $client->$method($uri, Content => $data);
      }
      elsif ($method eq 'patch') {
         # https://stackoverflow.com/questions/23910962/how-to-send-a-http-patch-request-with-lwpuseragent
         my $req = HTTP::Request::Common::PATCH($uri, [ %$data ]);
         $response = $client->request($req);
      }
      elsif ($method eq 'options' || $method eq 'patch') {
         my $req = HTTP::Request->new($method, $uri, $add_headers);
         $response = $client->request($req);
      }
      else {
         $response = $client->$method($uri);
      }
   };
   if ($@) {
      chomp($@);
      if ($@ =~ /read timeout/i) {
         $self->timeout(1);
      }
      return $self->log->error("$method: unable to use method [$method] to uri [$uri]: $@");
   }

   $self->_last($response);

   my %r = ();
   $r{code} = $response->code;
   if (! $self->ignore_content) {
      if ($self->do_javascript) {
         # decoded_content method is available in WWW::Mechanize::PhantomJS
         # but is available in HTTP::Request response otherwise.
         $r{content} = $client->decoded_content;
      }
      else {
         $r{content} = $response->decoded_content;
      }
   }

   # Error messages seen from IO::Socket::SSL module.
   if ($r{content} =~ /^Can't connect to .+Connection timed out at /is) {
      $self->timeout(1);
      return $self->log->error("$method: $uri: connection timed out");
   }
   elsif ($r{content} =~ /^Can't connect to .+?\n\n(.+?) at /is) {
      return $self->log->error("$method: $uri: ".lcfirst($1));
   }
   elsif ($r{content} =~ /^Connect failed: connect: Interrupted system call/i) {
      return $self->log->error("$method: $uri: connection interrupted by syscall");
   }

   my $headers = $response->headers;
   $r{headers} = { map { $_ => $headers->{$_} } keys %$headers };
   delete $r{headers}->{'::std_case'};

   return \%r;
}

sub get {
   my $self = shift;
   my ($uri, $username, $password) = @_;

   return $self->_method($uri, $username, $password, 'get');
}

sub cat {
   my $self = shift;
   my ($uri, $username, $password) = @_;

   $self->_method($uri, $username, $password, 'get') or return;
   return $self->content;
}

sub post {
   my $self = shift;
   my ($href, $uri, $username, $password) = @_;

   $self->brik_help_run_undef_arg('post', $href) or return;

   return $self->_method($uri, $username, $password, 'post', $href);
}

sub put {
   my $self = shift;
   my ($href, $uri, $username, $password) = @_;

   $self->brik_help_run_undef_arg('put', $href) or return;

   return $self->_method($uri, $username, $password, 'put', $href);
}

sub patch {
   my $self = shift;
   my ($href, $uri, $username, $password) = @_;

   $self->brik_help_run_undef_arg('patch', $href) or return;

   return $self->_method($uri, $username, $password, 'patch', $href);
}