#===========================================================================

package Sitescooper::UserAgent;
use LWP::UserAgent;
use LWP;

use strict;

use vars qw(
	@PasswdMask @ISA $CanHandleCookieRedirects
	$SLASH
);

use Sitescooper::PasswordAsker;

BEGIN {
  @ISA = qw(LWP::UserAgent);

  @PasswdMask =
  	unpack ("c*", "Ish0ulDReallY#BeDoING|05th1S>wiTh".
			"5omEThInG+STr0NgeR1kNoW}iKNOw!~");
}

# ---------------------------------------------------------------------------

sub new {
  my($class, $scoop) = @_;
  my $self = new LWP::UserAgent();

  $SLASH = $Sitescooper::Main::SLASH;

  $self->{scoop} = $scoop;
  $self->{cred_asker} = undef;
  $self->{env_proxy_user} = undef;
  $self->{env_proxy_pass} = undef;

  $self->{outed_already_set_warn} = { };
  $self->{last_redir} = undef;
  $self->{last_auth_realm} = undef;
  $self->{faked_redirect} = 0;

  $self = bless $self, $class;
  $self;
}

# ---------------------------------------------------------------------------

sub env_proxy_auth {
  my ($self) = @_;

  $self->{env_proxy_user} = $ENV{HTTP_proxy_user};
  $self->{env_proxy_pass} = $ENV{HTTP_proxy_pass};
}

sub set_proxy_auth {
  my ($self, $user, $pass) = @_;

  $self->{env_proxy_user} = $user;
  $self->{env_proxy_pass} = $pass;
}

sub add_proxy_auth_to_request {
  my ($self, $req) = @_;

  if (defined $self->{env_proxy_user} && defined $self->{env_proxy_pass}) {
    $req->proxy_authorization_basic($self->{env_proxy_user},
				 $self->{env_proxy_pass});
  }
}

# ---------------------------------------------------------------------------

sub set_password_asker {
  my ($self, $asker) = @_;

  $self->{cred_asker} = $asker;
}

# ---------------------------------------------------------------------------

sub get_basic_credentials {
  my ($self, $realm, $uri, $proxy) = @_;

  $self->{last_auth_realm} = $realm;

  if (defined $self->{site_logins}->{$realm} &&
    	defined $self->{site_passes}->{$realm})
  {
    if (!defined $self->{outed_already_set_warn}->{$realm}) {
      $self->{scoop}->verbose ("(using already-set password for $uri $realm)");
      $self->{outed_already_set_warn}->{$realm} = 1;
    }

  } elsif (defined $self->{cred_asker}) {
    my ($user, $pass) = $self->{cred_asker}->ask_user_for_credentials
    					($realm, $uri, $proxy);
    $self->set_credential($realm, $user, $pass);

  } else {
    return (undef, undef);
  }

  ($self->{site_logins}->{$realm}, $self->{site_passes}->{$realm});
}

# ---------------------------------------------------------------------------

sub set_credential {
  my ($self, $realm, $user, $pass) = @_;

  $self->{site_logins}->{$realm} = $user;
  $self->{site_passes}->{$realm} = $pass;
}

# ---------------------------------------------------------------------------

sub clear_credential {
  my ($self, $realm) = @_;

  delete $self->{site_logins}->{$realm};
  delete $self->{site_passes}->{$realm};
}

# ---------------------------------------------------------------------------

sub get_credentials_quietly {
  my ($self, $realm) = @_;

  ($self->{site_logins}->{$realm}, $self->{site_passes}->{$realm});
}

# ---------------------------------------------------------------------------

sub get_last_auth_realm {
  my ($self) = @_;

  $self->{last_auth_realm};
}

# ---------------------------------------------------------------------------

sub clear_last_auth_realm {
  my ($self) = @_;

  $self->{last_auth_realm} = undef;
}

# ---------------------------------------------------------------------------

sub load_logins {
  my ($self) = @_;
  if (defined %{$self->{site_logins}}) { return %{$self->{site_logins}}; }

  $self->{site_logins} = { };
  $self->{site_passes} = { };

  open (IN, '<'.$self->{scoop}->{cf}->{tmpdir}.$SLASH.'site_logins')
  		or return undef;

  #$self->{site_logins}->{'tst'} = $self->{site_passes}->{'tst'} = "jmason"; &save_logins;

  while (<IN>) {
    s/[\r\n]+$//g;
    my ($ver, $user, $pass, $realm) = split (/###/);
    if (defined $realm && $ver+0 == 0) {
      $self->{site_logins}->{$realm} = $user;

      my @mask = @PasswdMask;
      my @input = split (' ', $pass);
      my $pass_open = '';
      my $i = 0;

      foreach $_ (@input) {
	my $ch = (($_ ^ $mask[$i++ % $#mask]) ^ 0xaa);
	last if ($ch == 0);
	$pass_open .= sprintf ("%c", $ch);
      }

      $self->{site_passes}->{$realm} = $pass_open;
    }
  }
  close IN;

  #print "[", $self->{site_logins}->{'tst'}, "][", $self->{site_passes}->{'tst'}, "]\n"; exit;
}

# ---------------------------------------------------------------------------

sub save_logins {
  my ($self) = @_;
  if (!defined %{$self->{site_logins}}) { return; }
  my $towrite = '';

  my $realm;
  foreach $realm (sort keys %{$self->{site_logins}}) {
    next unless (defined $self->{site_passes}->{$realm} &&
    		defined $self->{site_logins}->{$realm});

    my @mask = @PasswdMask;
    my @input = (unpack ("c*", $self->{site_passes}->{$realm}));
    my $pass_disguised = '';
    my $i = 0;

    foreach $_ (@input) {
      $pass_disguised .= (($_ ^ 0xaa) ^ $mask[$i++ % $#mask]) . " ";
    }
    while ($i < int(($#input / 16) + 1) * 16) {
      $pass_disguised .= ((0 ^ 0xaa) ^ $mask[$i++ % $#mask]) . " ";
    }
    chop $pass_disguised;

    $towrite .= "0###". $self->{site_logins}->{$realm}.
    		"###". $pass_disguised.
    		"###". $realm. "\n";
  }

  # again, all at once to minimise contention
  open (OUT, '> '.$self->{scoop}->{cf}->{tmpdir}.$SLASH.'site_logins') or
  	(warn ("failed to write to site_logins file!\n"), return);
  print OUT $towrite;
  close OUT or warn ("failed to write to site_logins file!\n");
}

# ---------------------------------------------------------------------------

sub redirect_ok {
  my ($self, $req) = @_;

  $self->{scoop}->dbg2 ("useragent: redirected to: ".$req->uri->as_string);
  $self->note_redirect ($req->uri->as_string);
}

# ---------------------------------------------------------------------------

sub note_redirect {
  my ($self, $uri) = @_;
  $self->{last_redir} = $uri;
}

# ---------------------------------------------------------------------------

sub clear_redirect {
  my ($self) = @_;
  $self->{last_redir} = undef;
}

# ---------------------------------------------------------------------------

sub get_last_redirect {
  my ($self) = @_;
  $self->{last_redir};
}

# ---------------------------------------------------------------------------

sub redirect_occurred {
  my ($self) = @_;
  (defined $self->{last_redir});
}

# ---------------------------------------------------------------------------

# this is an API for a version of LWP::UserAgent::request that can handle
# setting cookies in a cookie-jar if the cookies are set in a redirect.
# However this implementation does not always do this, as it caused compat
# problems with other versions of LWP.  This one now proxies for 2
# real implementations, one for recent LWPs, one for older ones.
# Yuck.
#
sub request_handle_cookie_redirects {
  if (!defined $CanHandleCookieRedirects) {
    if (LWP::Version() >= 5.47) {
      $CanHandleCookieRedirects = 1;
    } else {
      warn "Warning: the installed version of LWP cannot do cookie redirects.\n".
        "Upgrade to a later version from cpan.perl.org if you run into problems.\n";
      $CanHandleCookieRedirects = 0;
    }
  }

  if ($CanHandleCookieRedirects) {
    return new_lwp_request_handle_cookie_redirects(@_);
  } else {
    return old_lwp_request_no_cookie_redirects(@_);
  }
}

# this version cannot handle cookies set in redirects, but is needed
# for older versions of LWP.
#
sub old_lwp_request_no_cookie_redirects {
  my($self, $cookie_jar, $request, $arg, $size) = @_;

  my $response;
  my $redirtest = $self->{scoop}->{func_test_redirect}{$request->uri()};

  if (defined $redirtest) {
    $self->{scoop}->dbg ("faking redirect to $redirtest");
    $self->{faked_redirect} = 1;	# avoid HTTP::Cookies bug

    my $base = $request->uri();
    my $url = new URI ($redirtest, $base);
    $url = $url->abs($base);

    $request->url ($url);
    $self->redirect_ok ($request);
  }

  $response = $self->request($request, $arg, $size);
  return $response;
}

# this is a version of LWP::UserAgent::request that can handle setting
# cookies in a cookie-jar if the cookies are set in a redirect.
#
sub new_lwp_request_handle_cookie_redirects {
  my($self, $cookie_jar, $request, $arg, $size, $previous) = @_;

  my $response;
  my $redirtest = $self->{scoop}->{func_test_redirect}->{$request->uri()};

  if (defined $redirtest) {
    $self->{scoop}->dbg ("faking redirect to $redirtest");
    my %hdrs = ();
    $hdrs{"Location"} = $redirtest;
    my $hdr = new HTTP::Headers; $hdr->header (%hdrs);
    $response = new HTTP::Response (302, "Moved Temporarily", $hdr, "moved");
    $response->request ($request);
    $self->{faked_redirect} = 1;	# avoid HTTP::Cookies bug

  } else {
    $response = $self->simple_request($request, $arg, $size);
  }

  my $code = $response->code;
  $response->previous($previous) if defined $previous;

  if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
    $code == &HTTP::Status::RC_MOVED_TEMPORARILY) {

    # Make a copy of the request and initialize it with the new URI
    my $referral = $request->clone;

    # And then we update the URL based on the Location:-header.
    my $referral_uri = $response->header('Location');

    {
      # Some servers erroneously return a relative URL for redirects,
      # so make it absolute if it not already is.
      local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
      my $base = $response->base;
      $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
		      ->abs($base);
    }

    $referral->url($referral_uri);

    return $response unless $self->redirect_ok($referral);

    # Check for loop in the redirects
    my $count = 0;
    my $r = $response;
    while ($r) {
      if (++$count > 13 ||
	$r->request->url->as_string eq $referral_uri->as_string) {
	$response->header("Client-Warning" =>
			  "Redirect loop detected");
	return $response;
      }
      $r = $r->previous;
    }

    # and now the magic! extract the cookies set in the redirect,
    # store them in the cookie jar for later use, and also add them
    # to the referral.
    #
    $cookie_jar->extract_cookies($response);

    if ($self->{faked_redirect}) {
      # HTTP::Cookies bug: file redirects cause a bad call to URI::port()
      # which doesn't exist for file: URIs. This crashes badly. So
      # protect with an eval when testing. Don't use the eval normally
      # as it'll slow down the normal case.
      eval '$cookie_jar->add_cookie_header($referral); ';
    } else {
      $cookie_jar->add_cookie_header($referral);
    }

    return $self->request_handle_cookie_redirects ($cookie_jar,
			$referral, $arg, $size, $response);
  }
  return $response;
}

# ---------------------------------------------------------------------------

1;
