diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm | 51 |
1 files changed, 51 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm new file mode 100644 index 00000000000..367c8f793d8 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/https.pm @@ -0,0 +1,51 @@ +package LWP::Protocol::https; + +use strict; + +use vars qw(@ISA); +require LWP::Protocol::http; +@ISA = qw(LWP::Protocol::http); + +sub socket_type +{ + return "https"; +} + +sub _check_sock +{ + my($self, $req, $sock) = @_; + my $check = $req->header("If-SSL-Cert-Subject"); + if (defined $check) { + my $cert = $sock->get_peer_certificate || + die "Missing SSL certificate"; + my $subject = $cert->subject_name; + die "Bad SSL certificate subject: '$subject' !~ /$check/" + unless $subject =~ /$check/; + $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on + } +} + +sub _get_sock_info +{ + my $self = shift; + $self->SUPER::_get_sock_info(@_); + my($res, $sock) = @_; + $res->header("Client-SSL-Cipher" => $sock->get_cipher); + my $cert = $sock->get_peer_certificate; + if ($cert) { + $res->header("Client-SSL-Cert-Subject" => $cert->subject_name); + $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name); + } + if(! eval { $sock->get_peer_verify }) { + $res->header("Client-SSL-Warning" => "Peer certificate not verified"); + } +} + +#----------------------------------------------------------- +package LWP::Protocol::https::Socket; + +use vars qw(@ISA); +require Net::HTTPS; +@ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods); + +1; |