diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/HTTP')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm | 254 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm | 91 |
2 files changed, 345 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm new file mode 100644 index 00000000000..52de7fe237c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Client.pm @@ -0,0 +1,254 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: +package CPAN::HTTP::Client; +use strict; +use vars qw(@ISA); +use CPAN::HTTP::Credentials; +use HTTP::Tiny 0.005; + +$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9600"; + +# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa +# and parts of LWP by Gisle Aas + +sub new { + my $class = shift; + my %args = @_; + for my $k ( keys %args ) { + $args{$k} = '' unless defined $args{$k}; + } + $args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy}; + return bless \%args, $class; +} + +# This executes a request with redirection (up to 5) and returns the +# response structure generated by HTTP::Tiny +# +# If authentication fails, it will attempt to get new authentication +# information and repeat up to 5 times + +sub mirror { + my($self, $uri, $path) = @_; + + my $want_proxy = $self->_want_proxy($uri); + my $http = HTTP::Tiny->new( + $want_proxy ? (proxy => $self->{proxy}) : () + ); + + my ($response, %headers); + my $retries = 0; + while ( $retries++ < 5 ) { + $response = $http->mirror( $uri, $path, {headers => \%headers} ); + if ( $response->{status} eq '401' ) { + last unless $self->_get_auth_params( $response, 'non_proxy' ); + } + elsif ( $response->{status} eq '407' ) { + last unless $self->_get_auth_params( $response, 'proxy' ); + } + else { + last; # either success or failure + } + my %headers = ( + $self->_auth_headers( $uri, 'non_proxy' ), + ( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ), + ); + } + + return $response; +} + +sub _want_proxy { + my ($self, $uri) = @_; + return unless $self->{proxy}; + my($host) = $uri =~ m|://([^/:]+)|; + return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] }; +} + +# Generates the authentication headers for a given mode +# C<mode> is 'proxy' or 'non_proxy' +# C<_${mode}_type> is 'basic' or 'digest' +# C<_${mode}_params> will be the challenge parameters from the 401/407 headers +sub _auth_headers { + my ($self, $uri, $mode) = @_; + # Get names for our mode-specific attributes + my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/; + + # If _prepare_auth has not been called, we can't prepare headers + return unless $self->{$type_key}; + + # Get user credentials for mode + my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials"; + my ($user, $pass) = return CPAN::HTTP::Credentials->$cred_method; + + # Generate the header for the mode & type + my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization'; + my $value_method = "_" . $self->{$type_key} . "_auth"; + my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri); + + # If we didn't get a value, we didn't have the right modules available + return $value ? ( $header, $value ) : (); +} + +# Extract authentication parameters from headers, but clear any prior +# credentials if we failed (so we might prompt user for password again) +sub _get_auth_params { + my ($self, $response, $mode) = @_; + my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW'; + my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/; + if ( ! $response->{success} ) { # auth failed + my $method = "clear_${mode}_credentials"; + CPAN::HTTP::Credentials->$method; + delete $self->{$_} for $type_key, $param_key; + } + ($self->{$type_key}, $self->{$param_key}) = + $self->_get_challenge( $response, "${prefix}-Authenticate"); + return $self->{$type_key}; +} + +# Extract challenge type and parameters for a challenge list +sub _get_challenge { + my ($self, $response, $auth_header) = @_; + + my $auth_list = $response->{headers}(lc $auth_header); + return unless defined $auth_list; + $auth_list = [$auth_list] unless ref $auth_list; + + for my $challenge (@$auth_list) { + $challenge =~ tr/,/;/; # "," is used to separate auth-params!! + ($challenge) = $self->split_header_words($challenge); + my $scheme = shift(@$challenge); + shift(@$challenge); # no value + $challenge = { @$challenge }; # make rest into a hash + + unless ($scheme =~ /^(basic|digest)$/) { + next; # bad scheme + } + $scheme = $1; # untainted now + + return ($scheme, $challenge); + } + return; +} + +# Generate a basic authentication header value +sub _basic_auth { + my ($self, $user, $pass) = @_; + unless ( $CPAN::META->has_usable('MIME::Base64') ) { + $CPAN::Frontend->mywarn( + "MIME::Base64 is required for 'Basic' style authentication" + ); + return; + } + return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{}); +} + +# Generate a digest authentication header value +sub _digest_auth { + my ($self, $user, $pass, $auth_param, $uri) = @_; + unless ( $CPAN::META->has_usable('Digest::MD5') ) { + $CPAN::Frontend->mywarn( + "Digest::MD5 is required for 'Digest' style authentication" + ); + return; + } + + my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}}; + my $cnonce = sprintf "%8x", time; + + my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$}; + $path = "/" unless defined $path; + + my $md5 = Digest::MD5->new; + + my(@digest); + $md5->add(join(":", $user, $auth_param->{realm}, $pass)); + push(@digest, $md5->hexdigest); + $md5->reset; + + push(@digest, $auth_param->{nonce}); + + if ($auth_param->{qop}) { + push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop}); + } + + $md5->add(join(":", 'GET', $path)); + push(@digest, $md5->hexdigest); + $md5->reset; + + $md5->add(join(":", @digest)); + my($digest) = $md5->hexdigest; + $md5->reset; + + my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque); + @resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5"); + + if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) { + @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc); + } + + my(@order) = + qw(username realm qop algorithm uri nonce nc cnonce response opaque); + my @pairs; + for (@order) { + next unless defined $resp{$_}; + push(@pairs, "$_=" . qq("$resp{$_}")); + } + + my $auth_value = "Digest " . join(", ", @pairs); + return $auth_value; +} + +# split_header_words adapted from HTTP::Headers::Util +sub split_header_words { + my ($self, @words) = @_; + my @res = $self->_split_header_words(@words); + for my $arr (@res) { + for (my $i = @$arr - 2; $i >= 0; $i -= 2) { + $arr->[$i] = lc($arr->[$i]); + } + } + return @res; +} + +sub _split_header_words { + my($self, @val) = @_; + my @res; + for (@val) { + my @cur; + while (length) { + if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' + push(@cur, $1); + # a quoted value + if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { + my $val = $1; + $val =~ s/\\(.)/$1/g; + push(@cur, $val); + # some unquoted value + } + elsif (s/^\s*=\s*([^;,\s]*)//) { + my $val = $1; + $val =~ s/\s+$//; + push(@cur, $val); + # no value, a lone token + } + else { + push(@cur, undef); + } + } + elsif (s/^\s*,//) { + push(@res, [@cur]) if @cur; + @cur = (); + } + elsif (s/^\s*;// || s/^\s+//) { + # continue + } + else { + die "This should not happen: '$_'"; + } + } + push(@res, \@cur) if @cur; + } + @res; +} + +1; diff --git a/Master/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm new file mode 100644 index 00000000000..097c67d0ed7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/CPAN/HTTP/Credentials.pm @@ -0,0 +1,91 @@ +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: +package CPAN::HTTP::Credentials; +use strict; +use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD); + +$CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9600"; + +sub clear_credentials { + _clear_non_proxy_credentials(); + _clear_proxy_credentials(); +} + +sub clear_non_proxy_credentials { + undef $USER; + undef $PASSWORD; +} + +sub clear_proxy_credentials { + undef $PROXY_USER; + undef $PROXY_PASSWORD; +} + +sub get_proxy_credentials { + my $self = shift; + if ($PROXY_USER && $PROXY_PASSWORD) { + return ($PROXY_USER, $PROXY_PASSWORD); + } + if ( defined $CPAN::Config->{proxy_user} + && $CPAN::Config->{proxy_user} + ) { + $PROXY_USER = $CPAN::Config->{proxy_user}; + $PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || ""; + return ($PROXY_USER, $PROXY_PASSWORD); + } + my $username_prompt = "\nProxy authentication needed! + (Note: to permanently configure username and password run + o conf proxy_user your_username + o conf proxy_pass your_password + )\nUsername:"; + ($PROXY_USER, $PROXY_PASSWORD) = + _get_username_and_password_from_user($username_prompt); + return ($PROXY_USER,$PROXY_PASSWORD); +} + +sub get_non_proxy_credentials { + my $self = shift; + if ($USER && $PASSWORD) { + return ($USER, $PASSWORD); + } + if ( defined $CPAN::Config->{username} ) { + $USER = $CPAN::Config->{username}; + $PASSWORD = $CPAN::Config->{password} || ""; + return ($USER, $PASSWORD); + } + my $username_prompt = "\nAuthentication needed! + (Note: to permanently configure username and password run + o conf username your_username + o conf password your_password + )\nUsername:"; + + ($USER, $PASSWORD) = + _get_username_and_password_from_user($username_prompt); + return ($USER,$PASSWORD); +} + +sub _get_username_and_password_from_user { + my $username_message = shift; + my ($username,$password); + + ExtUtils::MakeMaker->import(qw(prompt)); + $username = prompt($username_message); + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("noecho"); + } + else { + $CPAN::Frontend->mywarn( + "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n" + ); + } + $password = prompt("Password:"); + + if ($CPAN::META->has_inst("Term::ReadKey")) { + Term::ReadKey::ReadMode("restore"); + } + $CPAN::Frontend->myprint("\n\n"); + return ($username,$password); +} + +1; + |