home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / ssl / SSL.pm < prev    next >
Encoding:
Perl POD Document  |  2004-03-20  |  10.7 KB  |  436 lines
  1. package Net::SSL;
  2.  
  3. use strict;
  4. use vars qw(@ISA $VERSION $NEW_ARGS);
  5.  
  6. use MIME::Base64;
  7. use Socket;
  8. use Carp;
  9.  
  10. require IO::Socket;
  11. @ISA=qw(IO::Socket::INET);
  12. my %REAL; # private to this package only
  13. my $DEFAULT_VERSION = '23';
  14. my $CRLF = "\015\012";
  15.  
  16. require Crypt::SSLeay;
  17. $VERSION = '2.77';
  18.  
  19. sub _default_context
  20. {
  21.     require Crypt::SSLeay::MainContext;
  22.     Crypt::SSLeay::MainContext::main_ctx(@_);
  23. }
  24.  
  25. sub new {
  26.     my($class, %arg) = @_;
  27.     local $NEW_ARGS = \%arg;
  28.     $class->SUPER::new(%arg);
  29. }
  30.  
  31. sub DESTROY {
  32.     my $self = shift;
  33.     delete $REAL{$self};
  34.     local $@;
  35.     eval { $self->SUPER::DESTROY; };
  36. }
  37.  
  38. sub configure
  39. {
  40.     my($self, $arg) = @_;
  41.     my $ssl_version = delete $arg->{SSL_Version} ||
  42.       $ENV{HTTPS_VERSION} || $DEFAULT_VERSION;
  43.     my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0;
  44.  
  45.     my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version);
  46.  
  47.     *$self->{'ssl_ctx'} = $ctx;
  48.     *$self->{'ssl_version'} = $ssl_version;
  49.     *$self->{'ssl_debug'} = $ssl_debug;
  50.     *$self->{'ssl_arg'} = $arg;
  51.     *$self->{'ssl_peer_addr'} = $arg->{PeerAddr};
  52.     *$self->{'ssl_peer_port'} = $arg->{PeerPort};
  53.     *$self->{'ssl_new_arg'} = $NEW_ARGS;
  54.     *$self->{'ssl_peer_verify'} = 0;
  55.  
  56.     ## Crypt::SSLeay must also aware the SSL Proxy before calling
  57.     ## $socket->configure($args). Because the $sock->configure() will
  58.     ## die when failed to resolve the destination server IP address,
  59.     ## whatever the SSL proxy is used or not!
  60.     ## - dqbai, 2003-05-10
  61.     if (my $proxy = $self->proxy) {
  62.     my ($host, $port) = split(':',$proxy);
  63.     $port || die("no port given for proxy server $proxy");
  64.     $arg->{PeerAddr} = $host;
  65.     $arg->{PeerPort} = $port;
  66.     }
  67.  
  68.     $self->SUPER::configure($arg);
  69. }
  70.  
  71. # override to make sure there is really a timeout
  72. sub timeout {
  73.     shift->SUPER::timeout || 60;
  74. }
  75.  
  76. sub connect {
  77.     my $self = shift;
  78.  
  79.     # configure certs on connect() time, so we can throw an undef
  80.     # and have LWP understand the error
  81.     eval { $self->configure_certs(); };
  82.     if($@) {
  83.     $@ = "configure certs failed: $@, $!";
  84.     $self->die_with_error($@);
  85.     }
  86.  
  87.     # finished, update set_verify status
  88.     if(my $rv = *$self->{'ssl_ctx'}->set_verify()) {
  89.     *$self->{'ssl_peer_verify'} = $rv;
  90.     }
  91.  
  92.     if ($self->proxy) {
  93.     # don't die() in connect, just return undef and set $@
  94.     my $proxy_connect = eval { $self->proxy_connect_helper(@_); };
  95.     if(! $proxy_connect || $@) {
  96.         $@ = "proxy connect failed: $@; $!";
  97.         die $@;
  98.     }
  99.     } else {
  100.     *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_);    
  101.     if(!$self->SUPER::connect(@_)) {
  102.         # better to die than return here
  103.         $@ = "Connect failed: $@; $!";
  104.         die $@;
  105.     }
  106.     }
  107.  
  108. #    print "ssl_version ".*$self->{ssl_version}."\n";
  109.     my $debug = *$self->{'ssl_debug'} || 0;
  110.     my $ssl = Crypt::SSLeay::Conn->new(*$self->{'ssl_ctx'}, $debug, $self);
  111.     my $arg = *$self->{ssl_arg};
  112.     my $new_arg = *$self->{ssl_new_arg};
  113.     $arg->{SSL_Debug} = $debug;
  114.  
  115.     eval {
  116.     local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") };
  117.     # timeout / 2 because we have 3 possible connects here
  118.     alarm_ok() && alarm($self->timeout / 2);
  119.  
  120.     my $rv;
  121.     {
  122.         local $SIG{PIPE} = \¨
  123.         $rv = eval { $ssl->connect; };
  124.     }
  125.     if ($rv <= 0) {
  126.         alarm_ok() && alarm(0);
  127.         $ssl = undef;
  128.         my %args = (%$new_arg, %$arg);
  129.         if(*$self->{ssl_version} == 23) {
  130.         $args{SSL_Version} = 3;
  131.         # the new connect might itself be overridden with a REAL SSL
  132.         my $new_ssl = Net::SSL->new(%args);
  133.         $REAL{$self} = $REAL{$new_ssl} || $new_ssl;
  134.         return $REAL{$self};
  135.         } elsif(*$self->{ssl_version} == 3) {
  136.         # $self->die_with_error("SSL negotiation failed");
  137.         $args{SSL_Version} = 2;
  138.         my $new_ssl = Net::SSL->new(%args);
  139.         $REAL{$self} = $new_ssl;
  140.         return $new_ssl;
  141.         } else {
  142.         # don't die, but do set $@, and return undef
  143.         eval { $self->die_with_error("SSL negotiation failed") };
  144.         $@ = "$@; $!";
  145.         die $@;
  146.         }
  147.     }
  148.     alarm_ok() && alarm(0);
  149.     };
  150.  
  151.     # odd error in eval {} block, maybe alarm outside the evals
  152.     if($@) {
  153.     $! = "$@; $!";
  154.     die $@;
  155.     }
  156.  
  157.     # successful SSL connection gets stored
  158.     *$self->{'ssl_ssl'} = $ssl;
  159.     $self;
  160. }
  161.  
  162. sub accept
  163. {
  164.     die "NYI";
  165. }
  166.  
  167. # Delegate these calls to the Crypt::SSLeay::Conn object
  168. sub get_peer_certificate { 
  169.     my $self = shift;
  170.     $self = $REAL{$self} || $self;
  171.     *$self->{'ssl_ssl'}->get_peer_certificate(@_);
  172. }
  173.  
  174. sub get_peer_verify {
  175.     my $self = shift;
  176.     $self = $REAL{$self} || $self;
  177.     *$self->{'ssl_peer_verify'};
  178. }
  179.  
  180. sub get_shared_ciphers   { 
  181.     my $self = shift;
  182.     $self = $REAL{$self} || $self;
  183.     *$self->{'ssl_ssl'}->get_shared_ciphers(@_);
  184. }
  185. sub get_cipher           { 
  186.     my $self = shift;
  187.     $self = $REAL{$self} || $self;
  188.     *$self->{'ssl_ssl'}->get_cipher(@_);
  189. }
  190.  
  191. #sub get_peer_certificate { *{shift()}->{'ssl_ssl'}->get_peer_certificate(@_) }
  192. #sub get_shared_ciphers   { *{shift()}->{'ssl_ssl'}->get_shared_ciphers(@_) }
  193. #sub get_cipher           { *{shift()}->{'ssl_ssl'}->get_cipher(@_) }
  194.  
  195. sub ssl_context
  196. {
  197.     my $self = shift;
  198.     $self = $REAL{$self} || $self;
  199.     *$self->{'ssl_ctx'};
  200. }
  201.  
  202. sub die_with_error
  203. {
  204.     my $self=shift;
  205.     my $reason=shift;
  206.  
  207.     my $errs='';
  208.     while(my $err=Crypt::SSLeay::Err::get_error_string()) {
  209.        $errs.=" | " if $errs ne '';
  210.        $errs.=$err;
  211.     }
  212.     die "$reason: $errs";
  213. }
  214.  
  215. sub alarm_ok() {
  216.     $^O ne 'MSWin32';
  217. }
  218.  
  219. sub read
  220. {
  221.     my $self = shift;
  222.     $self = $REAL{$self} || $self;
  223.  
  224.     local $SIG{__DIE__} = \&Carp::confess;
  225.     local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") };
  226.  
  227.     alarm_ok() && alarm($self->timeout);
  228.     my $n=*$self->{'ssl_ssl'}->read(@_);
  229.     $self->die_with_error("read failed") if !defined $n;
  230.     alarm_ok() && alarm(0);
  231.  
  232.     $n;
  233. }
  234.  
  235. sub write
  236. {
  237.     my $self = shift;
  238.     $self = $REAL{$self} || $self;
  239.     my $n=*$self->{'ssl_ssl'}->write(@_);
  240.     $self->die_with_error("write failed") if !defined $n;
  241.     $n;
  242. }
  243.  
  244. *sysread  = \&read;
  245. *syswrite = \&write;
  246.  
  247. sub print
  248. {
  249.     my $self = shift;
  250.     $self = $REAL{$self} || $self;
  251.     # should we care about $, and $\??
  252.     # I think it is too expensive...
  253.     $self->write(join("", @_));
  254. }
  255.  
  256. sub printf
  257. {
  258.     my $self = shift;
  259.     $self = $REAL{$self} || $self;
  260.     my $fmt  = shift;
  261.     $self->write(sprintf($fmt, @_));
  262. }
  263.  
  264.  
  265. sub getchunk
  266. {
  267.     my $self = shift;
  268.     $self = $REAL{$self} || $self;
  269.     my $buf = '';  # warnings
  270.     my $n = $self->read($buf, 32*1024);
  271.     return unless defined $n;
  272.     $buf;
  273. }
  274.  
  275. # In order to implement these we will need to add a buffer in $self.
  276. # Is it worth it?
  277. sub getc     { shift->_unimpl("getc");     }
  278. sub ungetc   { shift->_unimpl("ungetc");   }
  279.  
  280. #sub getline  { shift->_unimpl("getline");  }
  281.  
  282. # This is really inefficient, but we only use it for reading the proxy response
  283. # so that does not really matter.
  284. sub getline {
  285.     my $self = shift;
  286.     $self = $REAL{$self} || $self;
  287.     my $val="";
  288.     my $buf;
  289.     do {
  290.     $self->SUPER::recv($buf, 1);
  291.     $val = $val . $buf;
  292.     } until ($buf eq "\n");
  293.  
  294.     $val;
  295. }
  296.  
  297.  
  298. sub getlines { shift->_unimpl("getlines"); }
  299.  
  300. # XXX: no way to disable <$sock>??  (tied handle perhaps?)
  301.  
  302. sub _unimpl
  303. {
  304.     my($self, $meth) = @_;
  305.     die "$meth not implemented for Net::SSL sockets";
  306. }
  307.  
  308. sub get_lwp_object {
  309.     my $self = shift;
  310.  
  311.     my $lwp_object;
  312.     my $i = 0;
  313.     while(1) {
  314.     package DB;
  315.     my @stack = caller($i++);
  316.     last unless @stack;
  317.     my @stack_args = @DB::args;
  318.     my $stack_object = $stack_args[0] || next;
  319.     ref($stack_object) || next;
  320.     if($stack_object->isa('LWP::UserAgent')) {
  321.         $lwp_object = $stack_object;
  322.         last;
  323.     }
  324.     }
  325.  
  326.     $lwp_object;
  327. }
  328.  
  329. sub proxy_connect_helper {
  330.     my $self = shift;
  331.  
  332.     my $proxy = $self->proxy;
  333.     my ($host, $port) = split(':',$proxy);
  334.     my $conn_ok = 0;
  335.     my $need_auth = 0;
  336.     my $auth_basic = 0;
  337.     my $realm = "";
  338.     my $length = 0;
  339.     my $line = "<noline>";
  340.     my $lwp_object = $self->get_lwp_object;
  341.  
  342.     my $iaddr = gethostbyname($host);
  343.     $iaddr || die("can't resolve proxy server name: $host, $!");
  344.     $port || die("no port given for proxy server $proxy");
  345.     
  346.     $self->SUPER::connect($port, $iaddr)
  347.       || die("proxy connect to $host:$port failed: $!");
  348.     
  349.     my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr});
  350.     $peer_port || die("no peer port given");
  351.     $peer_addr || die("no peer addr given");
  352.  
  353.     my $connect_string;
  354.     if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) {
  355.     my $user = $ENV{"HTTPS_PROXY_USERNAME"};
  356.     my $pass = $ENV{"HTTPS_PROXY_PASSWORD"};
  357.  
  358.     my $credentials = encode_base64("$user:$pass", "");
  359.     $connect_string = join($CRLF, 
  360.                    "CONNECT $peer_addr:$peer_port HTTP/1.0",
  361.                    "Proxy-authorization: Basic $credentials"
  362.                   );
  363.     }else{
  364.     $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0";
  365.     }
  366.     $connect_string .= $CRLF;
  367.     if($lwp_object && $lwp_object->agent) {
  368.     $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF;
  369.     }
  370.     $connect_string .= $CRLF;
  371.  
  372.     $self->SUPER::send($connect_string);
  373.     my $header;
  374.     my $n = $self->SUPER::sysread($header, 8192);
  375.     if($header =~ /HTTP\/\d+\.\d+\s+200\s+/is) {
  376.     $conn_ok = 1;
  377.     }
  378.  
  379.     unless ($conn_ok) {
  380.         die("PROXY ERROR HEADER, could be non-SSL URL:\n$header");
  381.     }
  382.  
  383.     $conn_ok;
  384. }
  385.  
  386. # code adapted from LWP::UserAgent, with $ua->env_proxy API
  387. sub proxy {
  388.     # don't iterate through %ENV for speed
  389.     my $proxy_server;
  390.     for ('HTTPS_PROXY', 'https_proxy') {
  391.     $proxy_server = $ENV{$_};
  392.     last if $proxy_server;
  393.     }
  394.     return unless $proxy_server;
  395.  
  396.     $proxy_server =~ s|^https?://||i;
  397.     
  398.     $proxy_server;
  399. }
  400.  
  401. sub configure_certs {
  402.     my $self = shift;
  403.     my $ctx = *$self->{ssl_ctx};
  404.  
  405.     my $count = 0;
  406.     for ('HTTPS_PKCS12_FILE', 'HTTPS_CERT_FILE', 'HTTPS_KEY_FILE') {
  407.     my $file = $ENV{$_};
  408.     if($file) {
  409.         (-e $file) or die("$file file does not exist: $!");
  410.         $count++;
  411.         if (/PKCS12/) {
  412.         $count++;
  413.         $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || die("failed to load $file: $!");
  414.         last;
  415.         } elsif (/CERT/) {
  416.         $ctx->use_certificate_file($file ,1) || die("failed to load $file: $!");
  417.         } elsif (/KEY/) {
  418.         $ctx->use_PrivateKey_file($file, 1) || die("failed to load $file: $!");
  419.         } else {
  420.         die("setting $_ not supported");
  421.         }
  422.     }
  423.     }
  424.  
  425.     # if both configs are set, then verify them
  426.     if (($count == 2)) {
  427.     if (! $ctx->check_private_key) {
  428.         die("Private key and certificate do not match");
  429.     }
  430.     }
  431.     
  432.     $count; # number of successful cert loads/checks
  433. }
  434.  
  435. 1;
  436.