Commit | Line | Data |
3fea05b9 |
1 | package LWP::Protocol::https10; |
2 | |
3 | use strict; |
4 | |
5 | # Figure out which SSL implementation to use |
6 | use vars qw($SSL_CLASS); |
7 | if ($Net::SSL::VERSION) { |
8 | $SSL_CLASS = "Net::SSL"; |
9 | } |
10 | elsif ($IO::Socket::SSL::VERSION) { |
11 | $SSL_CLASS = "IO::Socket::SSL"; # it was already loaded |
12 | } |
13 | else { |
14 | eval { require Net::SSL; }; # from Crypt-SSLeay |
15 | if ($@) { |
16 | require IO::Socket::SSL; |
17 | $SSL_CLASS = "IO::Socket::SSL"; |
18 | } |
19 | else { |
20 | $SSL_CLASS = "Net::SSL"; |
21 | } |
22 | } |
23 | |
24 | |
25 | use vars qw(@ISA); |
26 | |
27 | require LWP::Protocol::http10; |
28 | @ISA=qw(LWP::Protocol::http10); |
29 | |
30 | sub _new_socket |
31 | { |
32 | my($self, $host, $port, $timeout) = @_; |
33 | local($^W) = 0; # IO::Socket::INET can be noisy |
34 | my $sock = $SSL_CLASS->new(PeerAddr => $host, |
35 | PeerPort => $port, |
36 | Proto => 'tcp', |
37 | Timeout => $timeout, |
38 | ); |
39 | unless ($sock) { |
40 | # IO::Socket::INET leaves additional error messages in $@ |
41 | $@ =~ s/^.*?: //; |
42 | die "Can't connect to $host:$port ($@)"; |
43 | } |
44 | $sock; |
45 | } |
46 | |
47 | sub _check_sock |
48 | { |
49 | my($self, $req, $sock) = @_; |
50 | my $check = $req->header("If-SSL-Cert-Subject"); |
51 | if (defined $check) { |
52 | my $cert = $sock->get_peer_certificate || |
53 | die "Missing SSL certificate"; |
54 | my $subject = $cert->subject_name; |
55 | die "Bad SSL certificate subject: '$subject' !~ /$check/" |
56 | unless $subject =~ /$check/; |
57 | $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on |
58 | } |
59 | } |
60 | |
61 | sub _get_sock_info |
62 | { |
63 | my $self = shift; |
64 | $self->SUPER::_get_sock_info(@_); |
65 | my($res, $sock) = @_; |
66 | $res->header("Client-SSL-Cipher" => $sock->get_cipher); |
67 | my $cert = $sock->get_peer_certificate; |
68 | if ($cert) { |
69 | $res->header("Client-SSL-Cert-Subject" => $cert->subject_name); |
70 | $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name); |
71 | } |
72 | $res->header("Client-SSL-Warning" => "Peer certificate not verified"); |
73 | } |
74 | |
75 | 1; |