Commit | Line | Data |
3fea05b9 |
1 | package LWP::Protocol::https; |
2 | |
3 | use strict; |
4 | |
5 | use vars qw(@ISA); |
6 | require LWP::Protocol::http; |
7 | @ISA = qw(LWP::Protocol::http); |
8 | |
9 | sub socket_type |
10 | { |
11 | return "https"; |
12 | } |
13 | |
14 | sub _check_sock |
15 | { |
16 | my($self, $req, $sock) = @_; |
17 | my $check = $req->header("If-SSL-Cert-Subject"); |
18 | if (defined $check) { |
19 | my $cert = $sock->get_peer_certificate || |
20 | die "Missing SSL certificate"; |
21 | my $subject = $cert->subject_name; |
22 | die "Bad SSL certificate subject: '$subject' !~ /$check/" |
23 | unless $subject =~ /$check/; |
24 | $req->remove_header("If-SSL-Cert-Subject"); # don't pass it on |
25 | } |
26 | } |
27 | |
28 | sub _get_sock_info |
29 | { |
30 | my $self = shift; |
31 | $self->SUPER::_get_sock_info(@_); |
32 | my($res, $sock) = @_; |
33 | $res->header("Client-SSL-Cipher" => $sock->get_cipher); |
34 | my $cert = $sock->get_peer_certificate; |
35 | if ($cert) { |
36 | $res->header("Client-SSL-Cert-Subject" => $cert->subject_name); |
37 | $res->header("Client-SSL-Cert-Issuer" => $cert->issuer_name); |
38 | } |
39 | if(! eval { $sock->get_peer_verify }) { |
40 | $res->header("Client-SSL-Warning" => "Peer certificate not verified"); |
41 | } |
42 | } |
43 | |
44 | #----------------------------------------------------------- |
45 | package LWP::Protocol::https::Socket; |
46 | |
47 | use vars qw(@ISA); |
48 | require Net::HTTPS; |
49 | @ISA = qw(Net::HTTPS LWP::Protocol::http::SocketMethods); |
50 | |
51 | 1; |