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 / SSLeay.pm < prev    next >
Encoding:
Perl POD Document  |  2004-03-20  |  70.6 KB  |  2,019 lines

  1. # Net::SSLeay.pm - Perl module for using Eric Young's implementation of SSL
  2. #
  3. # Copyright (c) 1996-2002 Sampo Kellomaki <sampo@iki.fi>, All Rights Reserved.
  4. # Version 1.04, 31.3.1999
  5. # 30.7.1999, Tracking OpenSSL-0.9.3a changes, --Sampo
  6. # 31.7.1999, version 1.05 --Sampo
  7. # 7.4.2001,  fixed input error upon 0, OpenSSL-0.9.6a, version 1.06 --Sampo
  8. # 18.4.2001, added TLSv1 support by Stephen C. Koehler
  9. #            <koehler@securecomputing.com>, version 1.07, --Sampo
  10. # 25.4.2001, 64 bit fixes by Marko Asplund <aspa@kronodoc.fi> --Sampo
  11. # 17.4.2001, more error codes from aspa --Sampo
  12. # 25.9.2001, added heaps and piles of newer OpenSSL auxiliary functions --Sampo
  13. # 6.11.2001, got rid of $p_errs madness --Sampo
  14. # 9.11.2001, added EGD (entropy gathering daemon) reference info --Sampo
  15. # 7.12.2001, Added proxy support by Bruno De Wolf <bruno.dewolf@@pandora._be>
  16. # 6.1.2002,  cosmetic fix to socket options from Kwindla Hultman Kramer <kwindla@@allafrica_.com>
  17. # 25.3.2002, added post_https_cert and friends per patch from
  18. #            mock@@obscurity.ogr, --Sampo
  19. # 3.4.2002,  added `use bytes' from Marcus Taylor <marcus@@semantico_.com>
  20. #            This avoids unicode/utf8 (as may appear in some XML docs)
  21. #            from fooling the length comuptations. Dropped support for
  22. #            perl5.005_03 because I do not have opportunity to test it. --Sampo
  23. # 5.4.2002,  improved Unicode gotcha eliminator to support old perls --Sampo
  24. # 8.4.2002,  added a small line end fix from Petr Dousa (pdousa@@kerio_.com)
  25. # 17.5.2002, Added BIO_s_mem, BIO_new, BIO_free, BIO_write, BIO_read 
  26. #            BIO_eof, BIO_pending, BIO_wpending, RSA_generate_key, RSA_free
  27. #            --mikem@open._com.au
  28. # 10.8.2002, Added SSL_peek patch to ssl_read_until from 
  29. #            Peter Behroozi <peter@@fhpwireless_.com> --Sampo
  30. # 21.8.2002, Added SESSION_get_master_key, SSL_get_client_random, SSL_get_server_random
  31. #            --mikem@open.com_.au
  32. # 2.9.2002,  Added SSL_CTX_get_cert_store, X509_STORE_add_cert, X509_STORE_add_crl
  33. #            X509_STORE_set_flags, X509_load_cert_file, X509_load_crl_file
  34. #            X509_load_cert_crl_file, PEM_read_bio_X509_CRL,
  35. #            constants for X509_V_FLAG_* in order to support certificate revocation lists.
  36. #            --mikem@open.com_.au
  37. # 6.9.2002,  fixed X509_STORE_set_flags to X509_STORE_CTX_set_flags, --Sampo
  38. # 19.9.2002, applied patch from Tim Engler <tim@burntcouch_.com>
  39. # $Id: SSLeay.pm,v 1.18 2002/08/21 17:52:41 sampo Exp $
  40. #
  41. # The distribution and use of this module are subject to the conditions
  42. # listed in LICENSE file at the root of OpenSSL-0.9.6c
  43. # distribution (i.e. free, but mandatory attribution and NO WARRANTY).
  44.  
  45. package Net::SSLeay;
  46.  
  47. use strict;
  48. use Carp;
  49. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $CRLF);
  50. use Socket;
  51. use Errno;
  52.  
  53. require Exporter;
  54. require DynaLoader;
  55. use AutoLoader;
  56.  
  57. # 0=no warns, 1=only errors, 2=ciphers, 3=progress, 4=dump data
  58. $Net::SSLeay::trace = 0;  # Do not change here, use
  59.                           # $Net::SSLeay::trace = [1-4]  in caller
  60.  
  61. # 2 = insist on v2 SSL protocol
  62. # 3 = insist on v3 SSL
  63. # 10 = insist on TLSv1
  64. # 0 or undef = guess (v23)
  65. #
  66. $Net::SSLeay::ssl_version = 0;
  67.  
  68. #define to enable the "cat /proc/$$/stat" stuff
  69. $Net::SSLeay::linux_debug = 0;
  70.  
  71. # Number of seconds to sleep after sending message and before half
  72. # closing connection. Useful with antiquated broken servers.
  73. $Net::SSLeay::slowly = 0;  # don't change here, use 
  74.                            # Net::SSLeay::version=[2,3,0] in caller
  75.  
  76. # RANDOM NUMBER INITIALIZATION
  77. #
  78. # Edit to your taste. Using /dev/random would be more secure, but may
  79. # block if randomness is not available, thus the default is
  80. # /dev/urandom. $how_random determines how many bits of randomness to take
  81. # from the device. You should take enough (read SSLeay/doc/rand), but
  82. # beware that randomness is limited resource so you should not waste
  83. # it either or you may end up with randomness depletion (situation where
  84. # /dev/random would block and /dev/urandom starts to return predictable
  85. # numbers).
  86. #
  87. # N.B. /dev/urandom does not exit on all systems, such as Solaris. In that
  88. #      case you should get a third party package that emulates /dev/urandom
  89. #      (e.g. via named pipe) or supply a random number file. Some such
  90. #      packages are documented in Caveat section of the POD documentation.
  91.  
  92. $Net::SSLeay::random_device = '/dev/urandom';
  93. $Net::SSLeay::how_random = 512;
  94.  
  95. $VERSION = '1.21';
  96. @ISA = qw(Exporter DynaLoader);
  97. @EXPORT_OK = qw(
  98.     AT_MD5_WITH_RSA_ENCRYPTION
  99.     CB_ACCEPT_EXIT
  100.     CB_ACCEPT_LOOP
  101.     CB_CONNECT_EXIT
  102.     CB_CONNECT_LOOP
  103.     CK_DES_192_EDE3_CBC_WITH_MD5
  104.     CK_DES_192_EDE3_CBC_WITH_SHA
  105.     CK_DES_64_CBC_WITH_MD5
  106.     CK_DES_64_CBC_WITH_SHA
  107.     CK_DES_64_CFB64_WITH_MD5_1
  108.     CK_IDEA_128_CBC_WITH_MD5
  109.     CK_NULL
  110.     CK_NULL_WITH_MD5
  111.     CK_RC2_128_CBC_EXPORT40_WITH_MD5
  112.     CK_RC2_128_CBC_WITH_MD5
  113.     CK_RC4_128_EXPORT40_WITH_MD5
  114.     CK_RC4_128_WITH_MD5
  115.     CLIENT_VERSION
  116.     ERROR_NONE
  117.     ERROR_SSL
  118.     ERROR_SYSCALL
  119.     ERROR_WANT_CONNECT
  120.     ERROR_WANT_READ
  121.     ERROR_WANT_WRITE
  122.     ERROR_WANT_X509_LOOKUP
  123.     ERROR_ZERO_RETURN
  124.     CT_X509_CERTIFICATE
  125.     FILETYPE_ASN1
  126.     FILETYPE_PEM
  127.     F_CLIENT_CERTIFICATE
  128.     F_CLIENT_HELLO
  129.     F_CLIENT_MASTER_KEY
  130.     F_D2I_SSL_SESSION
  131.     F_GET_CLIENT_FINISHED
  132.     F_GET_CLIENT_HELLO
  133.     F_GET_CLIENT_MASTER_KEY
  134.     F_GET_SERVER_FINISHED
  135.     F_GET_SERVER_HELLO
  136.     F_GET_SERVER_VERIFY
  137.     F_I2D_SSL_SESSION
  138.     F_READ_N
  139.     F_REQUEST_CERTIFICATE
  140.     F_SERVER_HELLO
  141.     F_SSL_ACCEPT
  142.     F_SSL_CERT_NEW
  143.     F_SSL_CONNECT
  144.     F_SSL_ENC_DES_CBC_INIT
  145.     F_SSL_ENC_DES_CFB_INIT
  146.     F_SSL_ENC_DES_EDE3_CBC_INIT
  147.     F_SSL_ENC_IDEA_CBC_INIT
  148.     F_SSL_ENC_NULL_INIT
  149.     F_SSL_ENC_RC2_CBC_INIT
  150.     F_SSL_ENC_RC4_INIT
  151.     F_SSL_GET_NEW_SESSION
  152.     F_SSL_MAKE_CIPHER_LIST
  153.     F_SSL_NEW
  154.     F_SSL_READ
  155.     F_SSL_RSA_PRIVATE_DECRYPT
  156.     F_SSL_RSA_PUBLIC_ENCRYPT
  157.     F_SSL_SESSION_NEW
  158.     F_SSL_SESSION_PRINT_FP
  159.     F_SSL_SET_CERTIFICATE
  160.     F_SSL_SET_FD
  161.     F_SSL_SET_RFD
  162.     F_SSL_SET_WFD
  163.     F_SSL_STARTUP
  164.     F_SSL_USE_CERTIFICATE
  165.     F_SSL_USE_CERTIFICATE_ASN1
  166.     F_SSL_USE_CERTIFICATE_FILE
  167.     F_SSL_USE_PRIVATEKEY
  168.     F_SSL_USE_PRIVATEKEY_ASN1
  169.     F_SSL_USE_PRIVATEKEY_FILE
  170.     F_SSL_USE_RSAPRIVATEKEY
  171.     F_SSL_USE_RSAPRIVATEKEY_ASN1
  172.     F_SSL_USE_RSAPRIVATEKEY_FILE
  173.     F_WRITE_PENDING
  174.     MAX_MASTER_KEY_LENGTH_IN_BITS
  175.     MAX_RECORD_LENGTH_2_BYTE_HEADER
  176.     MAX_RECORD_LENGTH_3_BYTE_HEADER
  177.     MAX_SSL_SESSION_ID_LENGTH_IN_BYTES
  178.     MIN_RSA_MODULUS_LENGTH_IN_BYTES
  179.     MT_CLIENT_CERTIFICATE
  180.     MT_CLIENT_FINISHED
  181.     MT_CLIENT_HELLO
  182.     MT_CLIENT_MASTER_KEY
  183.     MT_ERROR
  184.     MT_REQUEST_CERTIFICATE
  185.     MT_SERVER_FINISHED
  186.     MT_SERVER_HELLO
  187.     MT_SERVER_VERIFY
  188.     NOTHING
  189.     OPENSSL_VERSION_NUMBER
  190.     PE_BAD_CERTIFICATE
  191.     PE_NO_CERTIFICATE
  192.     PE_NO_CIPHER
  193.     PE_UNSUPPORTED_CERTIFICATE_TYPE
  194.     READING
  195.     RWERR_BAD_MAC_DECODE
  196.     RWERR_BAD_WRITE_RETRY
  197.     RWERR_INTERNAL_ERROR
  198.     R_BAD_AUTHENTICATION_TYPE
  199.     R_BAD_CHECKSUM
  200.     R_BAD_MAC_DECODE
  201.     R_BAD_RESPONSE_ARGUMENT
  202.     R_BAD_SSL_FILETYPE
  203.     R_BAD_SSL_SESSION_ID_LENGTH
  204.     R_BAD_STATE
  205.     R_BAD_WRITE_RETRY
  206.     R_CHALLENGE_IS_DIFFERENT
  207.     R_CIPHER_CODE_TOO_LONG
  208.     R_CIPHER_TABLE_SRC_ERROR
  209.     R_CONECTION_ID_IS_DIFFERENT
  210.     R_INVALID_CHALLENGE_LENGTH
  211.     R_NO_CERTIFICATE_SET
  212.     R_NO_CERTIFICATE_SPECIFIED
  213.     R_NO_CIPHER_LIST
  214.     R_NO_CIPHER_MATCH
  215.     R_NO_CIPHER_WE_TRUST
  216.     R_NO_PRIVATEKEY
  217.     R_NO_PUBLICKEY
  218.     R_NO_READ_METHOD_SET
  219.     R_NO_WRITE_METHOD_SET
  220.     R_NULL_SSL_CTX
  221.     R_PEER_DID_NOT_RETURN_A_CERTIFICATE
  222.     R_PEER_ERROR
  223.     R_PEER_ERROR_CERTIFICATE
  224.     R_PEER_ERROR_NO_CIPHER
  225.     R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE
  226.     R_PERR_ERROR_NO_CERTIFICATE
  227.     R_PUBLIC_KEY_ENCRYPT_ERROR
  228.     R_PUBLIC_KEY_IS_NOT_RSA
  229.     R_PUBLIC_KEY_NO_RSA
  230.     R_READ_WRONG_PACKET_TYPE
  231.     R_REVERSE_KEY_ARG_LENGTH_IS_WRONG
  232.     R_REVERSE_MASTER_KEY_LENGTH_IS_WRONG
  233.     R_REVERSE_SSL_SESSION_ID_LENGTH_IS_WRONG
  234.     R_SHORT_READ
  235.     R_SSL_SESSION_ID_IS_DIFFERENT
  236.     R_UNABLE_TO_EXTRACT_PUBLIC_KEY
  237.     R_UNDEFINED_INIT_STATE
  238.     R_UNKNOWN_REMOTE_ERROR_TYPE
  239.     R_UNKNOWN_STATE
  240.     R_UNSUPORTED_CIPHER
  241.     R_WRONG_PUBLIC_KEY_TYPE
  242.     R_X509_LIB
  243.     SERVER_VERSION
  244.     SESSION
  245.     SESSION_ASN1_VERSION
  246.     ST_ACCEPT
  247.     ST_BEFORE
  248.     ST_CLIENT_START_ENCRYPTION
  249.     ST_CONNECT
  250.     ST_GET_CLIENT_FINISHED_A
  251.     ST_GET_CLIENT_FINISHED_B
  252.     ST_GET_CLIENT_HELLO_A
  253.     ST_GET_CLIENT_HELLO_B
  254.     ST_GET_CLIENT_MASTER_KEY_A
  255.     ST_GET_CLIENT_MASTER_KEY_B
  256.     ST_GET_SERVER_FINISHED_A
  257.     ST_GET_SERVER_FINISHED_B
  258.     ST_GET_SERVER_HELLO_A
  259.     ST_GET_SERVER_HELLO_B
  260.     ST_GET_SERVER_VERIFY_A
  261.     ST_GET_SERVER_VERIFY_B
  262.     ST_INIT
  263.     ST_OK
  264.     ST_READ_BODY
  265.     ST_READ_HEADER
  266.     ST_SEND_CLIENT_CERTIFICATE_A
  267.     ST_SEND_CLIENT_CERTIFICATE_B
  268.     ST_SEND_CLIENT_CERTIFICATE_C
  269.     ST_SEND_CLIENT_CERTIFICATE_D
  270.     ST_SEND_CLIENT_FINISHED_A
  271.     ST_SEND_CLIENT_FINISHED_B
  272.     ST_SEND_CLIENT_HELLO_A
  273.     ST_SEND_CLIENT_HELLO_B
  274.     ST_SEND_CLIENT_MASTER_KEY_A
  275.     ST_SEND_CLIENT_MASTER_KEY_B
  276.     ST_SEND_REQUEST_CERTIFICATE_A
  277.     ST_SEND_REQUEST_CERTIFICATE_B
  278.     ST_SEND_REQUEST_CERTIFICATE_C
  279.     ST_SEND_REQUEST_CERTIFICATE_D
  280.     ST_SEND_SERVER_FINISHED_A
  281.     ST_SEND_SERVER_FINISHED_B
  282.     ST_SEND_SERVER_HELLO_A
  283.     ST_SEND_SERVER_HELLO_B
  284.     ST_SEND_SERVER_VERIFY_A
  285.     ST_SEND_SERVER_VERIFY_B
  286.     ST_SERVER_START_ENCRYPTION
  287.     ST_X509_GET_CLIENT_CERTIFICATE
  288.     ST_X509_GET_SERVER_CERTIFICATE
  289.     TXT_DES_192_EDE3_CBC_WITH_MD5
  290.     TXT_DES_192_EDE3_CBC_WITH_SHA
  291.     TXT_DES_64_CBC_WITH_MD5
  292.     TXT_DES_64_CBC_WITH_SHA
  293.     TXT_DES_64_CFB64_WITH_MD5_1
  294.     TXT_IDEA_128_CBC_WITH_MD5
  295.     TXT_NULL
  296.     TXT_NULL_WITH_MD5
  297.     TXT_RC2_128_CBC_EXPORT40_WITH_MD5
  298.     TXT_RC2_128_CBC_WITH_MD5
  299.     TXT_RC4_128_EXPORT40_WITH_MD5
  300.     TXT_RC4_128_WITH_MD5
  301.     VERIFY_CLIENT_ONCE
  302.     VERIFY_FAIL_IF_NO_PEER_CERT
  303.     VERIFY_NONE
  304.     VERIFY_PEER
  305.     WRITING
  306.     X509_LOOKUP
  307.     X509_V_FLAG_CB_ISSUER_CHECK
  308.     X509_V_FLAG_USE_CHECK_TIME
  309.     X509_V_FLAG_CRL_CHECK
  310.     X509_V_FLAG_CRL_CHECK_ALL
  311.     X509_V_FLAG_IGNORE_CRITICAL
  312.     CTX_new
  313.     CTX_v2_new
  314.     CTX_v3_new
  315.     CTX_v23_new
  316.     CTX_free
  317.     new
  318.     free
  319.     accept
  320.     clear
  321.     connect
  322.     set_fd
  323.     set_rfd
  324.     set_wfd
  325.     get_fd
  326.     read
  327.     write
  328.     peek
  329.     use_RSAPrivateKey
  330.     use_RSAPrivateKey_ASN1
  331.     use_RSAPrivateKey_file
  332.     CTX_use_RSAPrivateKey_file
  333.     use_PrivateKey
  334.     use_PrivateKey_ASN1
  335.     use_PrivateKey_file
  336.     use_certificate
  337.     use_certificate_ASN1
  338.     use_certificate_file
  339.     CTX_use_certificate_file
  340.     load_error_strings
  341.     ERR_load_SSL_strings
  342.     state_string
  343.     rstate_string
  344.     state_string_long
  345.     rstate_string_long
  346.     get_time
  347.     set_time
  348.     get_timeout
  349.     set_timeout
  350.     copy_session_id
  351.     set_read_ahead
  352.     get_read_ahead
  353.     pending
  354.     get_cipher_list
  355.     set_cipher_list
  356.     get_cipher
  357.     get_shared_ciphers
  358.     get_peer_certificate
  359.     set_verify
  360.     flush_sessions
  361.     set_bio
  362.     get_rbio
  363.     get_wbio
  364.     SESSION_new
  365.     SESSION_print
  366.     SESSION_free
  367.     i2d_SSL_SESSION
  368.     set_session
  369.     add_session
  370.     remove_session
  371.     d2i_SSL_SESSION
  372.     BIO_f_ssl
  373.     BIO_new
  374.     BIO_new_file
  375.         BIO_s_mem
  376.         BIO_free
  377.         BIO_read
  378.         BIO_write
  379.     BIO_eof
  380.     BIO_pending
  381.     BIO_wpending
  382.     ERR_get_error
  383.     ERR_error_string
  384.     err
  385.     clear_error
  386.     X509_get_issuer_name
  387.     X509_get_subject_name
  388.         X509_NAME_oneline
  389.     X509_NAME_get_text_by_NID
  390.     CTX_get_cert_store
  391.     X509_STORE_add_cert
  392.     X509_STORE_add_crl
  393.     X509_STORE_CTX_set_flags
  394.     X509_load_cert_file
  395.     X509_load_crl_file
  396.     X509_load_cert_crl_file
  397.     PEM_read_bio_X509_CRL
  398.     die_if_ssl_error
  399.     die_now
  400.     print_errs
  401.     set_cert_and_key
  402.     set_server_cert_and_key
  403.         make_form
  404.         make_headers
  405.     do_https
  406.     get_https
  407.         post_https
  408.         sslcat
  409.     ssl_read_CRLF
  410.     ssl_read_all
  411.     ssl_read_until
  412.     ssl_write_CRLF
  413.         ssl_write_all
  414.         dump_peer_certificate
  415.     RSA_generate_key
  416.     RSA_free
  417.     X509_free
  418.     SESSION_get_master_key
  419.     get_client_random
  420.     get_server_random
  421. );
  422.  
  423. sub AUTOLOAD {
  424.     # This AUTOLOAD is used to 'autoload' constants from the constant()
  425.     # XS function.  If a constant is not found then control is passed
  426.     # to the AUTOLOAD in AutoLoader.
  427.  
  428.     my $constname;
  429.     ($constname = $AUTOLOAD) =~ s/.*:://;
  430.     my $val = constant($constname);
  431.     if ($! != 0) {
  432.     if ($! =~ /((Invalid)|(not valid))/i || $!{EINVAL}) {
  433.         $AutoLoader::AUTOLOAD = $AUTOLOAD;
  434.         goto &AutoLoader::AUTOLOAD;
  435.     }
  436.     else {
  437.       croak "Your vendor has not defined SSLeay macro $constname";
  438.     }
  439.     }
  440.     eval "sub $AUTOLOAD { $val }";
  441.     goto &$AUTOLOAD;
  442. }
  443.  
  444. bootstrap Net::SSLeay $VERSION;
  445.  
  446. # Preloaded methods go here.
  447.  
  448. $CRLF = "\x0d\x0a";  # because \r\n is not fully portable
  449.  
  450. ### Print SSLeay error stack
  451.  
  452. sub print_errs {
  453.     my ($msg) = @_;
  454.     my ($count, $err, $errs, $e) = (0,0,'');
  455.     while ($err = ERR_get_error()) {
  456.         $count ++;
  457.     $e = "$msg $$: $count - " . ERR_error_string($err) . "\n";
  458.     $errs .= $e;
  459.     warn $e if $Net::SSLeay::trace;
  460.     }
  461.     return $errs;
  462. }
  463.  
  464. # Death is conditional to SSLeay errors existing, i.e. this function checks
  465. # for errors and only dies in affirmative.
  466. # usage: Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)");
  467.  
  468. sub die_if_ssl_error {
  469.     my ($msg) = @_;    
  470.     die "$$: $msg\n" if print_errs($msg);
  471. }
  472.  
  473. # Unconditional death. Used to print SSLeay errors before dying.
  474. # usage: Net::SSLeay:connect($ssl) or die_now("Failed SSL connect ($!)");
  475.  
  476. sub die_now {
  477.     my ($msg) = @_;    
  478.     print_errs($msg);
  479.     die "$$: $msg\n";
  480. }
  481.  
  482. # Perl 5.6.* unicode support causes that length() no longer reliably
  483. # reflects the byte length of a string. This eval is to fix that.
  484. # Thanks to Sean Burke for the snippet.
  485.  
  486. BEGIN{ 
  487. eval 'use bytes; sub blength ($) { length $_[0] }'; 
  488. $@ and eval '    sub blength ($) { length $_[0] }' ; 
  489. }
  490.  
  491. # Autoload methods go after =cut, and are processed by the autosplit program.
  492.  
  493. 1;
  494. __END__
  495. # Documentation. Use `perl-root/pod/pod2html SSLeay.pm` to output html
  496.  
  497. =head1 NAME
  498.  
  499. Net::SSLeay - Perl extension for using OpenSSL or SSLeay
  500.  
  501. =head1 SYNOPSIS
  502.  
  503.   use Net::SSLeay, qw(get_https post_https sslcat make_headers make_form);
  504.  
  505.   ($page) = get_https('www.bacus.pt', 443, '/');                 # 1
  506.  
  507.   ($page, $response, %reply_headers)
  508.      = get_https('www.bacus.pt', 443, '/',                   # 2
  509.          make_headers(User-Agent => 'Cryptozilla/5.0b1',
  510.                  Referer    => 'https://www.bacus.pt'
  511.         ));
  512.  
  513.   ($page, $result, %headers) =                                   # 2b
  514.          = get_https('www.bacus.pt', 443, '/protected.html',
  515.           make_headers(Authorization =>
  516.                'Basic ' . MIME::Base64::encode("$user:$pass",''))
  517.           );
  518.  
  519.   ($page, $response, %reply_headers)
  520.      = post_https('www.bacus.pt', 443, '/foo.cgi', '',       # 3
  521.         make_form(OK   => '1',
  522.               name => 'Sampo'
  523.         ));
  524.  
  525.   $reply = sslcat($host, $port, $request);                       # 4
  526.  
  527.   ($reply, $err, $server_cert) = sslcat($host, $port, $request); # 5
  528.  
  529.   $Net::SSLeay::trace = 2;  # 0=no debugging, 1=ciphers, 2=trace, 3=dump data
  530.  
  531. =head1 DESCRIPTION
  532.  
  533. There is a related module called Net::SSLeay::Handle included in this
  534. distribution that you might want to use instead. It has its own pod
  535. documentation.
  536.  
  537. This module offers some high level convinience functions for accessing
  538. web pages on SSL servers, a sslcat() function for writing your own
  539. clients, and finally access to the SSL api of SSLeay/OpenSSL package so you
  540. can write servers or clients for more complicated applications.
  541.  
  542. For high level functions it is most convinient to import them to your
  543. main namespace as indicated in the synopsis.
  544.  
  545. Case 1 demonstrates typical invocation of get_https() to fetch an HTML
  546. page from secure server. The first argument provides host name or ip
  547. in dotted decimal notation of the remote server to contact. Second
  548. argument is the TCP port at the remote end (your own port is picked
  549. arbitrarily from high numbered ports as usual for TCP). The third
  550. argument is the URL of the page without the host name part. If in
  551. doubt consult HTTP specifications at <http://www.w3c.org>
  552.  
  553. Case 2 demonstrates full fledged use of get_https(). As can be seen,
  554. get_https() parses the response and response headers and returns them as
  555. a list, which can be captured in a hash for later reference. Also a
  556. fourth argument to get_https() is used to insert some additional headers
  557. in the request. make_headers() is a function that will convert a list or
  558. hash to such headers. By default get_https() supplies Host (make virtual
  559. hosting easy) and Accept (reportedly needed by IIS) headers.
  560.  
  561. Case 2b demonstrates how to get password protected page. Refer to
  562. HTTP protocol specifications for further details (e.g. RFC2617).
  563.  
  564. Case 3 invokes post_https() to submit a HTML/CGI form to secure
  565. server. First four arguments are equal to get_https() (note that empty
  566. string ('') is passed as header argument). The fifth argument is the
  567. contents of the form formatted according to CGI specification. In this
  568. case the helper function make_https() is used to do the formatting,
  569. but you could pass any string. The post_https() automatically adds
  570. Content-Type and Content-Length headers to the request.
  571.  
  572. Case 4 shows the fundamental sslcat() function (inspired in spirit by
  573. netcat utility :-). Its your swiss army knife that allows you to
  574. easily contact servers, send some data, and then get the response. You
  575. are responsible for formatting the data and parsing the response -
  576. sslcat() is just a transport.
  577.  
  578. Case 5 is a full invocation of sslcat() which allows return of errors
  579. as well as the server (peer) certificate.
  580.  
  581. The $trace global variable can be used to control the verbosity of high
  582. level functions. Level 0 guarantees silence, level 1 (the default)
  583. only emits error messages.
  584.  
  585. =head2 Alternate versions of the API
  586.  
  587. The above mentioned functions actually return the response headers as
  588. a list, which only gets converted to hash upon assignment (this
  589. assignment looses information if the same header occurs twice, as may
  590. be the case with cookies). There are also other variants of the
  591. functions that return unprocessed headers and that return a reference
  592. to a hash.
  593.  
  594.   ($page, $response, @headers) = get_https('www.bacus.pt', 443, '/');
  595.   for ($i = 0; $i < $#headers; $i+=2) {
  596.       print "$headers[$i] = " . $headers[$i+1] . "\n";
  597.   }
  598.   
  599.   ($page, $response, $headers, $server_cert)
  600.     = get_https3('www.bacus.pt', 443, '/');
  601.   print "$headers\n";
  602.  
  603.   ($page, $response, %headers_ref, $server_cert)
  604.     = get_https4('www.bacus.pt', 443, '/');
  605.   for $k (sort keys %{headers_ref}) {
  606.       for $v (@{$headers_ref{$k}}) {
  607.       print "$k = $v\n";
  608.       }
  609.   }
  610.  
  611. All of the above code fragments accomplish the same thing: display all
  612. values of all headers. The API functions ending in "3" return the
  613. headers simply as a scalar string and it is up to the application to
  614. split them up. The functions ending in "4" return a reference to
  615. hash of arrays (see perlref and perllol manual pages if you are
  616. not familiar with complex perl data structures). To access single value
  617. of such header hash you would do something like
  618.  
  619.   print $headers_ref{COOKIE}[0];
  620.  
  621. The variants 3 and 4 also allow you to discover the server certificate
  622. in case you would like to store or display it, e.g.
  623.  
  624.   ($p, $resp, $hdrs, $server_cert) = get_https3('www.bacus.pt', 443, '/');
  625.   if (!defined($server_cert) || ($server_cert == 0)) {
  626.       warn "Subject Name: undefined, Issuer  Name: undefined";
  627.   } else {
  628.       warn 'Subject Name: '
  629.       . Net::SSLeay::X509_NAME_oneline(
  630.          Net::SSLeay::X509_get_subject_name($server_cert))
  631.           . 'Issuer  Name: '
  632.           . Net::SSLeay::X509_NAME_oneline(
  633.                          Net::SSLeay::X509_get_issuer_name($server_cert));
  634.   }
  635.  
  636. Beware that this method only allows after the fact verification of
  637. the certificate: by the time get_https3() has returned the https
  638. request has already been sent to the server, whether you decide to
  639. tryst it or not. To do the verification correctly you must either
  640. employ the OpenSSL certificate verification framework or use
  641. the lower level API to first connect and verify the certificate
  642. and only then send the http data. See implementation of ds_https3()
  643. for guidance on how to do this.
  644.  
  645. =head2 Using client certificates
  646.  
  647. Secure web communications are encrypted using symmetric crypto keys
  648. exchanged using encryption based on the certificate of the
  649. server. Therefore in all SSL connections the server must have a
  650. certificate. This serves both to authenticate the server to the
  651. clients and to perform the key exchange.
  652.  
  653. Sometimes it is necessary to authenticate the client as well. Two
  654. options are available: http basic authentication and client side
  655. certificate. The basic authentication over https is actually quite
  656. safe because https guarantees that the password will not travel in
  657. clear. Never-the-less, problems like easily guessable passwords
  658. remain. The client certificate method involves authentication of the
  659. client at SSL level using a certificate. For this to work, both the
  660. client and the server will have certificates (which typically are
  661. different) and private keys.
  662.  
  663. The API functions outlined above accept additional arguments that
  664. allow one to supply the client side certificate and key files. The
  665. format of these files is the same as used for server certificates and
  666. the caveat about encrypting private key applies.
  667.  
  668.   ($page, $result, %headers) =                                   # 2c
  669.          = get_https('www.bacus.pt', 443, '/protected.html',
  670.           make_headers(Authorization =>
  671.                'Basic ' . MIME::Base64::encode("$user:$pass",'')),
  672.           '', $mime_type6, $path_to_crt7, $path_to_key8);
  673.  
  674.   ($page, $response, %reply_headers)
  675.      = post_https('www.bacus.pt', 443, '/foo.cgi',           # 3b
  676.           make_headers('Authorization' =>
  677.                'Basic ' . MIME::Base64::encode("$user:$pass",'')),
  678.           make_form(OK   => '1', name => 'Sampo'),
  679.           $mime_type6, $path_to_crt7, $path_to_key8);
  680.  
  681. Case 2c demonstrates getting password protected page that also requires
  682. client certificate, i.e. it is possible to use both authentication
  683. methods simultaneously.
  684.  
  685. Case 3b is full blown post to secure server that requires both password
  686. authentication and client certificate, just like in case 2c.
  687.  
  688. Note: Client will not send a certificate unless the server requests one.
  689. This is typically achieved by setting verify mode to VERIFY_PEER on the
  690. server:
  691.  
  692.   Net::SSLeay::set_verify(ssl, Net::SSLeay::VERIFY_PEER, 0);
  693.  
  694. See perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod for full description.
  695.  
  696. =head2 Working through Web proxy
  697.  
  698. Net::SSLeay can use a web proxy to make its connections. You need to
  699. first set the proxy host and port using set_proxy() and then just
  700. use the normal API functions, e.g:
  701.  
  702.   Net::SSLeay::set_proxy('gateway.myorg.com', 8080);
  703.   ($page) = get_https('www.bacus.pt', 443, '/');
  704.  
  705. If your proxy requires authentication, you can supply username and
  706. password as well
  707.  
  708.   Net::SSLeay::set_proxy('gateway.myorg.com', 8080, 'joe', 'salainen');
  709.   ($page, $result, %headers) =
  710.          = get_https('www.bacus.pt', 443, '/protected.html',
  711.           make_headers(Authorization =>
  712.                'Basic ' . MIME::Base64::encode("susie:pass",''))
  713.           );
  714.  
  715. This example demonstrates case where we authenticate to the proxy as
  716. "joe" and to the final web server as "susie". Proxy authentication
  717. requires MIME::Base64 module to work.
  718.  
  719. =head2 Certificate verification and Certificate Revoocation Lists (CRLs)
  720.  
  721. OpenSSL supports the ability to verify peer certificates. It can also optionally
  722. check peer certificate against a Certificate Revocation List (CRL) from teh certificates
  723. issuer. A CRL is a file, created by the certificate issuer that lists all the 
  724. certificates that ir previously signed, but which it now revokes. CRLs are in PEM format.
  725.  
  726. You can enable Net::SSLeay CRL checking like this:
  727.  
  728.         &Net::SSLeay::X509_STORE_CTX_set_flags
  729.         (&Net::SSLeay::CTX_get_cert_store($ssl), 
  730.          &Net::SSLeay::X509_V_FLAG_CRL_CHECK); 
  731.  
  732. After setting this flag, if OpenSSL checks a peer's certificate, then it will attempt
  733. to find a CRL for the issuer. It does this by looking for a specially named file in
  734. the sercah directory specified by CTX_load_verify_locations. 
  735. CRL files are named with the hash of the issuers subject name, followed by .r0, .r1 etc.
  736. For example ab1331b2.r0, ab1331b2.r1. It will read all the .r files for the issuer,
  737. and then check for a revocation of the peer cerificate in all of them. 
  738. (You can also force it to look in a specific named CRL file., see below).
  739. You can find out the hash of the issuer subject name in a CRL with
  740.     openssl crl -in crl.pem -hash -noout
  741.  
  742. If the peer certificate does not pass the revocation list, or if no CRL is found,
  743. then the handshaking fails with an error.
  744.  
  745. You can also force OpenSSL to look for CRLs in one or more arbitrarily named files.
  746.  
  747. my $bio = &Net::SSLeay::BIO_new_file($crlfilename, 'r');
  748. my $crl = &Net::SSLeay::PEM_read_bio_X509_CRL($bio);
  749. if ($crl)
  750. {
  751.     &Net::SSLeay::X509_STORE_add_crl(&Net::SSLeay::CTX_get_cert_store($ssl, $crl);
  752. }
  753. else
  754. {
  755.     error reading CRL....
  756. }
  757.  
  758.  
  759. =head2 Convenience routines
  760.  
  761. To be used with Low level API
  762.  
  763.     Net::SSLeay::randomize($rn_seed_file,$additional_seed);
  764.     Net::SSLeay::set_cert_and_key($ctx, $cert_path, $key_path);
  765.     $cert = Net::SSLeay::dump_peer_certificate($ssl);
  766.     Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure";
  767.     $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure";
  768.  
  769.     $got = Net::SSLeay::ssl_read_CRLF($ssl [, $max_length]);
  770.     $got = Net::SSLeay::ssl_read_until($ssl [, $delimit [, $max_length]]);
  771.     Net::SSLeay::ssl_write_CRLF($ssl, $message);
  772.  
  773. randomize() seeds the eay PRNG with /dev/urandom (see top of SSLeay.pm
  774. for how to change or configure this) and optionally with user provided
  775. data. It is very important to properly seed your random numbers, so
  776. do not forget to call this. The high level API functions automatically
  777. call randomize() so it is not needed with them. See also caveats.
  778.  
  779. set_cert_and_key() takes two file names as arguments and sets
  780. the certificate and private key to those. This can be used to
  781. set either cerver certificates or client certificates.
  782.  
  783. dump_peer_certificate() allows you to get plaintext description of the
  784. certificate the peer (usually server) presented to us.
  785.  
  786. ssl_read_all() and ssl_write_all() provide true blocking semantics for
  787. these operations (see limitation, below, for explanation). These are
  788. much preferred to the low level API equivalents (which implement BSD
  789. blocking semantics). The message argument to ssl_write_all() can be
  790. reference. This is helpful to avoid unnecessary copy when writing
  791. something big, e.g:
  792.  
  793.     $data = 'A' x 1000000000;
  794.     Net::SSLeay::ssl_write_all($ssl, \$data) or die "ssl write failed";
  795.  
  796. ssl_read_CRLF() uses ssl_read_all() to read in a line terminated with a
  797. carriage return followed by a linefeed (CRLF).  The CRLF is included in
  798. the returned scalar.
  799.  
  800. ssl_read_until() uses ssl_read_all() to read from the SSL input
  801. stream until it encounters a programmer specified delimiter.
  802. If the delimiter is undefined, $/ is used.  If $/ is undefined,
  803. \n is used.  One can optionally set a maximum length of bytes to read
  804. from the SSL input stream.
  805.  
  806. ssl_write_CRLF() writes $message and appends CRLF to the SSL output stream.
  807.  
  808. =head2 Low level API
  809.  
  810. In addition to the high level functions outlined above, this module
  811. contains straight forward access to SSL part of OpenSSL C api. Only the SSL
  812. subpart of OpenSSL is implemented (if anyone wants to implement other
  813. parts, feel free to submit patches).
  814.  
  815. See ssl.h header from OpenSSL C distribution for list of low lever
  816. SSLeay functions to call (to check if some function has been
  817. implemented see directly in SSLeay.xs). The module strips SSLeay names
  818. of the initial "SSL_", generally you should use Net::SSLeay:: in
  819. place. For example:
  820.  
  821. In C:
  822.  
  823.     #include <ssl.h>
  824.     
  825.     err = SSL_set_verify (ssl, SSL_VERIFY_CLIENT_ONCE,
  826.                    &your_call_back_here);
  827.     
  828. In perl:
  829.  
  830.     use Net::SSLeay;
  831.  
  832.     $err = Net::SSLeay::set_verify ($ssl,
  833.                     &Net::SSLeay::VERIFY_CLIENT_ONCE,
  834.                     \&your_call_back_here);
  835.  
  836. If the function does not start by SSL_ you should use the full
  837. function name, e.g.:
  838.  
  839.     $err = &Net::SSLeay::ERR_get_error;
  840.  
  841. Following new functions behave in perlish way:
  842.  
  843.     $got = Net::SSLeay::read($ssl);
  844.                                     # Performs SSL_read, but returns $got
  845.                                     # resized according to data received.
  846.                                     # Returns undef on failure.
  847.  
  848.     Net::SSLeay::write($ssl, $foo) || die;
  849.                                     # Performs SSL_write, but automatically
  850.                                     # figures out the size of $foo
  851.  
  852. In order to use the low level API you should start your programs with
  853. the following encantation:
  854.  
  855.     use Net::SSLeay qw(die_now die_if_ssl_error);
  856.     Net::SSLeay::load_error_strings();
  857.     Net::SSLeay::SSLeay_add_ssl_algorithms();   # Important!
  858.         Net::SSLeay::randomize();
  859.  
  860. die_now() and die_if_ssl_error() are used to conveniently print SSLeay error
  861. stack when something goes wrong, thusly:
  862.  
  863.     Net::SSLeay:connect($ssl) or die_now("Failed SSL connect ($!)");
  864.     Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)");
  865.  
  866. You can also use Net::SSLeay::print_errs() to dump the error stack without
  867. exiting the program. As can be seen, your code becomes much more readable
  868. if you import the error reporting functions to your main name space.
  869.  
  870. I can not emphasize enough the need to check error returns. Use these
  871. functions even in most simple programs, they will reduce debugging
  872. time greatly. Do not ask questions in mailing list without having
  873. first sprinkled these in your code.
  874.  
  875. =head2 Sockets
  876.  
  877. Perl uses file handles for all I/O. While SSLeay has quite flexible BIO
  878. mechanism and perl has evolved PerlIO mechanism, this module still
  879. sticks to using file descriptors. Thus to attach SSLeay to socket you
  880. should use fileno() to extract the underlying file descriptor:
  881.  
  882.     Net::SSLeay::set_fd($ssl, fileno(S));   # Must use fileno
  883.  
  884. You should also use "$|=1;" to eliminate STDIO buffering so you do not
  885. get confused if you use perl I/O functions to manipulate your socket
  886. handle.
  887.  
  888. If you need to select(2) on the socket, go right ahead, but be warned
  889. that OpenSSL does some internal buffering so SSL_read does not always
  890. return data even if socket selected for reading (just keep on
  891. selecting and trying to read). Net::SSLeay.pm is no different from the
  892. C language OpenSSL in this respect.
  893.  
  894. =head2 Callbacks
  895.  
  896. WARNING: as of 1.04 the callbacks have changed and have not been tested.
  897.  
  898. At this moment the implementation of verify_callback is crippeled in
  899. the sense that at any given time there can be only one call back which
  900. is shared by all SSL contexts, sessions and connections. This is
  901. due to having to keep the reference to the perl call back in a
  902. static variable so that the callback C glue can find it. To remove
  903. this restriction would require either a more complex data structure
  904. (like a hash?) in XSUB to map the call backs to their owners or,
  905. cleaner, adding a context pointer in the SSL structure. This context would
  906. then be passed to the C callback, which in our case would be the glue
  907. to look up the proper Perl function from the context and call it.
  908.  
  909. ---- inaccurate ----
  910. The verify call back looks like this in C:
  911.  
  912.     int (*callback)(int ok,X509 *subj_cert,X509 *issuer_cert,
  913.                         int depth,int errorcode,char *arg,STACK *cert_chain)
  914.  
  915. The corresponding Perl function should be something like this:
  916.  
  917.     sub verify {
  918.         my ($ok, $subj_cert, $issuer_cert, $depth, $errorcode,
  919.         $arg, $chain) = @_;
  920.         print "Verifying certificate...\n";
  921.         ...
  922.         return $ok;
  923.     }
  924.  
  925. It is used like this:
  926.  
  927.     Net::SSLeay::set_verify ($ssl, Net::SSLeay::VERIFY_PEER, \&verify);
  928.  
  929. Callbacks for decrypting private keys are implemented, but have the
  930. same limitation as the verify_callback implementation (one password
  931. callback shared between all contexts.)  You might use it something
  932. like this:
  933.  
  934.         Net::SSLeay::CTX_set_default_passwd_cb($ctx, sub { "top-secret" });
  935.         Net::SSLeay::CTX_use_PrivateKey_file($ctx, "key.pem",
  936.                          Net::SSLeay::FILETYPE_PEM)
  937.             or die "Error reading private key";
  938.  
  939. No other callbacks are implemented. You do not need to use any
  940. callback for simple (i.e. normal) cases where the SSLeay built-in
  941. verify mechanism satisfies your needs.
  942. ---- end inaccurate ----
  943.  
  944. If you want to use callback stuff, see examples/callback.pl! Its the
  945. only one I am able to make work reliably.
  946.  
  947. =head2 X509 and RAND stuff
  948.  
  949. This module largely lacks interface to the X509 and RAND routines, but
  950. as I was lazy and needed them, the following kludges are implemented:
  951.  
  952.     $x509_name = Net::SSLeay::X509_get_subject_name($x509_cert);
  953.     $x509_name = Net::SSLeay::X509_get_issuer_name($x509_cert);
  954.     print Net::SSLeay::X509_NAME_oneline($x509_name);
  955.     Net::SSLeay::RAND_seed($buf);   # Perlishly figures out buf size
  956.     Net::SSLeay::RAND_cleanup();
  957.     Net::SSLeay::RAND_load_file($file_name, $how_many_bytes);
  958.     Net::SSLeay::RAND_write_file($file_name);
  959.     Net::SSLeay::RAND_egd($path);
  960.     $text = Net::SSLeay::X509_NAME_get_text_by_NID($name, $nid);
  961.  
  962. Actually you should consider using the following helper functions:
  963.  
  964.     print Net::SSLeay::dump_peer_certificate($ssl);
  965.     Net::SSLeay::randomize();
  966.  
  967. =head2 RSA interface
  968.  
  969. Some RSA functions are available:
  970.  
  971. $rsakey = Net::SSLeay::RSA_generate_key();
  972. Net::SSLeay::CTX_set_tmp_rsa($ctx, $rsakey);
  973. Net::SSLeay::RSA_free($rsakey);
  974.  
  975. =head2 BIO interface
  976.  
  977. Some BIO functions are available:
  978.  
  979.   Net::SSLeay::BIO_s_mem();
  980.   $bio = Net::SSLeay::BIO_new(BIO_s_mem())
  981.   $bio = Net::SSLeay::BIO_new_file($filename, $mode);
  982.   Net::SSLeay::BIO_free($bio)
  983.   $count = Net::SSLeay::BIO_write($data);
  984.   $data = Net::SSLeay::BIO_read($bio);
  985.   $data = Net::SSLeay::BIO_read($bio, $maxbytes);
  986.   $is_eof = Net::SSLeay::BIO_eof($bio);
  987.   $count = Net::SSLeay::BIO_pending($bio);
  988.   $count = Net::SSLeay::BIO_wpending ($bio);
  989.  
  990. =head2 Low level API
  991. Some very low level API functions are available:
  992.     $client_random = &Net::SSLeay::get_client_random($ssl);
  993.     $server_random = &Net::SSLeay::get_server_random($ssl);
  994.     $session = &Net::SSLeay::get_session($ssl);
  995.     $master_key = &Net::SSLeay::SESSION_get_master_key($session);
  996.  
  997. =head1 EXAMPLES
  998.  
  999. One very good example is to look at the implementation of sslcat() in the
  1000. SSLeay.pm file.
  1001.  
  1002. Following is a simple SSLeay client (with too little error checking :-(
  1003.  
  1004.     #!/usr/local/bin/perl
  1005.     use Socket;
  1006.     use Net::SSLeay qw(die_now die_if_ssl_error) ;
  1007.     Net::SSLeay::load_error_strings();
  1008.     Net::SSLeay::SSLeay_add_ssl_algorithms();
  1009.     Net::SSLeay::randomize();
  1010.  
  1011.     ($dest_serv, $port, $msg) = @ARGV;      # Read command line
  1012.     $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/;
  1013.     $dest_ip = gethostbyname ($dest_serv);
  1014.     $dest_serv_params  = sockaddr_in($port, $dest_ip);
  1015.     
  1016.     socket  (S, &AF_INET, &SOCK_STREAM, 0)  or die "socket: $!";
  1017.     connect (S, $dest_serv_params)          or die "connect: $!";
  1018.     select  (S); $| = 1; select (STDOUT);   # Eliminate STDIO buffering
  1019.     
  1020.     # The network connection is now open, lets fire up SSL    
  1021.  
  1022.     $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!");
  1023.     Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
  1024.          and die_if_ssl_error("ssl ctx set options");
  1025.     $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
  1026.     Net::SSLeay::set_fd($ssl, fileno(S));   # Must use fileno
  1027.     $res = Net::SSLeay::connect($ssl) and die_if_ssl_error("ssl connect");
  1028.     print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
  1029.     
  1030.     # Exchange data
  1031.     
  1032.     $res = Net::SSLeay::write($ssl, $msg);  # Perl knows how long $msg is
  1033.     die_if_ssl_error("ssl write");
  1034.     CORE::shutdown S, 1;  # Half close --> No more output, sends EOF to server
  1035.     $got = Net::SSLeay::read($ssl);         # Perl returns undef on failure
  1036.     die_if_ssl_error("ssl read");
  1037.     print $got;
  1038.         
  1039.     Net::SSLeay::free ($ssl);               # Tear down connection
  1040.     Net::SSLeay::CTX_free ($ctx);
  1041.     close S;
  1042.  
  1043. Following is a simple SSLeay echo server (non forking):
  1044.  
  1045.     #!/usr/local/bin/perl -w
  1046.     use Socket;
  1047.     use Net::SSLeay qw(die_now die_if_ssl_error);
  1048.     Net::SSLeay::load_error_strings();
  1049.     Net::SSLeay::SSLeay_add_ssl_algorithms();
  1050.     Net::SSLeay::randomize();
  1051.  
  1052.     $our_ip = "\0\0\0\0"; # Bind to all interfaces
  1053.     $port = 1235;                             
  1054.     $sockaddr_template = 'S n a4 x8';
  1055.     $our_serv_params = pack ($sockaddr_template, &AF_INET, $port, $our_ip);
  1056.  
  1057.     socket (S, &AF_INET, &SOCK_STREAM, 0)  or die "socket: $!";
  1058.     bind (S, $our_serv_params)             or die "bind:   $!";
  1059.     listen (S, 5)                          or die "listen: $!";
  1060.     $ctx = Net::SSLeay::CTX_new ()         or die_now("CTX_new ($ctx): $!");
  1061.     Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
  1062.          and die_if_ssl_error("ssl ctx set options");
  1063.  
  1064.     # Following will ask password unless private key is not encrypted
  1065.     Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx, 'plain-rsa.pem',
  1066.                                              &Net::SSLeay::FILETYPE_PEM);
  1067.     die_if_ssl_error("private key");
  1068.     Net::SSLeay::CTX_use_certificate_file ($ctx, 'plain-cert.pem',
  1069.                             &Net::SSLeay::FILETYPE_PEM);
  1070.     die_if_ssl_error("certificate");
  1071.     
  1072.     while (1) {    
  1073.         print "Accepting connections...\n";
  1074.         ($addr = accept (NS, S))           or die "accept: $!";
  1075.         select (NS); $| = 1; select (STDOUT);  # Piping hot!
  1076.     
  1077.         ($af,$client_port,$client_ip) = unpack($sockaddr_template,$addr);
  1078.         @inetaddr = unpack('C4',$client_ip);
  1079.         print "$af connection from " .
  1080.         join ('.', @inetaddr) . ":$client_port\n";
  1081.     
  1082.     # We now have a network connection, lets fire up SSLeay...
  1083.  
  1084.         $ssl = Net::SSLeay::new($ctx)      or die_now("SSL_new ($ssl): $!");
  1085.         Net::SSLeay::set_fd($ssl, fileno(NS));
  1086.     
  1087.         $err = Net::SSLeay::accept($ssl) and die_if_ssl_error('ssl accept');
  1088.         print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
  1089.     
  1090.         # Connected. Exchange some data.
  1091.     
  1092.         $got = Net::SSLeay::read($ssl);     # Returns undef on fail
  1093.         die_if_ssl_error("ssl read");
  1094.         print "Got `$got' (" . length ($got) . " chars)\n";
  1095.         
  1096.         Net::SSLeay::write ($ssl, uc ($got)) or die "write: $!";
  1097.         die_if_ssl_error("ssl write");
  1098.     
  1099.         Net::SSLeay::free ($ssl);           # Tear down connection
  1100.         close NS;
  1101.     }
  1102.  
  1103. Yet another echo server. This one runs from /etc/inetd.conf so it avoids
  1104. all the socket code overhead. Only caveat is opening rsa key file -
  1105. it had better be without any encryption or else it will not know where
  1106. to ask for the password. Note how STDIN and STDOUT are wired to SSL.
  1107.  
  1108.     #!/usr/local/bin/perl
  1109.     # /etc/inetd.conf
  1110.     #    ssltst stream tcp nowait root /path/to/server.pl server.pl
  1111.     # /etc/services
  1112.     #    ssltst        1234/tcp
  1113.  
  1114.     use Net::SSLeay qw(die_now die_if_ssl_error);
  1115.     Net::SSLeay::load_error_strings();
  1116.     Net::SSLeay::SSLeay_add_ssl_algorithms();
  1117.     Net::SSLeay::randomize();
  1118.  
  1119.     chdir '/key/dir' or die "chdir: $!";
  1120.     $| = 1;  # Piping hot!
  1121.     open LOG, ">>/dev/console" or die "Can't open log file $!";
  1122.     select LOG; print "server.pl started\n";
  1123.     
  1124.     $ctx = Net::SSLeay::CTX_new()     or die_now "CTX_new ($ctx) ($!)";
  1125.     $ssl = Net::SSLeay::new($ctx)     or die_now "new ($ssl) ($!)";
  1126.     Net::SSLeay::set_options($ssl, &Net::SSLeay::OP_ALL)
  1127.          and die_if_ssl_error("ssl set options");
  1128.  
  1129.     # We get already open network connection from inetd, now we just
  1130.     # need to attach SSLeay to STDIN and STDOUT
  1131.     Net::SSLeay::set_rfd($ssl, fileno(STDIN));
  1132.     Net::SSLeay::set_wfd($ssl, fileno(STDOUT));
  1133.  
  1134.     Net::SSLeay::use_RSAPrivateKey_file ($ssl, 'plain-rsa.pem',
  1135.                                          &Net::SSLeay::FILETYPE_PEM);
  1136.     die_if_ssl_error("private key");
  1137.     Net::SSLeay::use_certificate_file ($ssl, 'plain-cert.pem',
  1138.                         &Net::SSLeay::FILETYPE_PEM);
  1139.     die_if_ssl_error("certificate");
  1140.  
  1141.     Net::SSLeay::accept($ssl) and die_if_ssl_err("ssl accept: $!");
  1142.     print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
  1143.     
  1144.     $got = Net::SSLeay::read($ssl);
  1145.     die_if_ssl_error("ssl read");
  1146.     print "Got `$got' (" . length ($got) . " chars)\n";
  1147.  
  1148.     Net::SSLeay::write ($ssl, uc($got)) or die "write: $!";
  1149.     die_if_ssl_error("ssl write");
  1150.  
  1151.     Net::SSLeay::free ($ssl);         # Tear down the connection
  1152.     Net::SSLeay::CTX_free ($ctx);
  1153.     close LOG;
  1154.  
  1155. There are also a number of example/test programs in the examples directory:
  1156.  
  1157.     sslecho.pl   -  A simple server, not unlike the one above
  1158.     minicli.pl   -  Implements a client using low level SSLeay routines
  1159.     sslcat.pl    -  Demonstrates using high level sslcat utility function
  1160.     get_page.pl  -  Is a utility for getting html pages from secure servers
  1161.     callback.pl  -  Demonstrates certificate verification and callback usage
  1162.     stdio_bulk.pl       - Does SSL over Unix pipes
  1163.     ssl-inetd-serv.pl   - SSL server that can be invoked from inetd.conf
  1164.     httpd-proxy-snif.pl - Utility that allows you to see how a browser
  1165.                           sends https request to given server and what reply
  1166.                           it gets back (very educative :-)
  1167.     makecert.pl  -  Creates a self signed cert (does not use this module)
  1168.  
  1169. =head1 LIMITATIONS
  1170.  
  1171. Net::SSLeay::read uses internal buffer of 32KB, thus no single read
  1172. will return more. In practice one read returns much less, usually
  1173. as much as fits in one network packet. To work around this,
  1174. you should use a loop like this:
  1175.  
  1176.     $reply = '';
  1177.     while ($got = Net::SSLeay::read($ssl)) {
  1178.     last if print_errs('SSL_read');
  1179.     $reply .= $got;
  1180.     }
  1181.  
  1182. Although there is no built-in limit in Net::SSLeay::write, the network
  1183. packet size limitation applies here as well, thus use:
  1184.  
  1185.     $written = 0;
  1186.  
  1187.     while ($written < length($message)) {
  1188.     $written += Net::SSLeay::write($ssl, substr($message, $written));
  1189.     last if print_errs('SSL_write');
  1190.     }
  1191.  
  1192. Or alternatively you can just use the following convinence functions:
  1193.  
  1194.     Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure";
  1195.     $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure";
  1196.  
  1197. =head1 KNOWN BUGS AND CAVEATS
  1198.  
  1199. Autoloader emits
  1200.  
  1201.     Argument "xxx" isn't numeric in entersub at blib/lib/Net/SSLeay.pm'
  1202.  
  1203. warning if die_if_ssl_error is made autoloadable. If you figure out why,
  1204. drop me a line.
  1205.  
  1206. Callback set using SSL_set_verify() does not appear to work. This may
  1207. well be eay problem (e.g. see ssl/ssl_lib.c line 1029). Try using
  1208. SSL_CTX_set_verify() instead and do not be surprised if even this stops
  1209. working in future versions.
  1210.  
  1211. Callback and certificate verification stuff is generally too little tested.
  1212.  
  1213. Random numbers are not initialized randomly enough, especially if you
  1214. do not have /dev/random and/or /dev/urandom (such as in Solaris
  1215. platforms - but I've been suggested that cryptorand daemon from SUNski
  1216. package solves this). In this case you should investigate third party
  1217. software that can emulate these devices, e.g. by way of a named pipe
  1218. to some program.
  1219.  
  1220. Another gotcha with random number initialization is randomness
  1221. depletion. This phenomenon, which has been extensively discussed in
  1222. OpenSSL, Apache-SSL, and Apache-mod_ssl forums, can cause your
  1223. script to block if you use /dev/random or to operate insecurely
  1224. if you use /dev/urandom. What happens is that when too much
  1225. randomness is drawn from the operating system's randomness pool
  1226. then randomness can temporarily be unavailable. /dev/random solves
  1227. this problem by waiting until enough randomness can be gathered - and
  1228. this can take a long time since blocking reduces activity in the
  1229. machine and less activity provides less random events: a vicious circle.
  1230. /dev/urandom solves this dilemma more pragmatically by simply returning
  1231. predictable "random" numbers. Some /dev/urandom emulation software
  1232. however actually seems to implement /dev/random semantics. Caveat emptor.
  1233.  
  1234. I've been pointed to two such daemons by Mik Firestone <mik@@speed.stdio._com>
  1235. who has used them on Solaris 8
  1236.  
  1237.    1. Entropy Gathering Daemon (EGD) at http://www.lothar.com/tech/crypto/
  1238.    2. Pseudo-random number generating daemon (PRNGD) at
  1239.         http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html
  1240.  
  1241. If you are using the low level API functions to communicate with other
  1242. SSL implementations, you would do well to call
  1243.  
  1244.     Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
  1245.          and die_if_ssl_error("ssl ctx set options");
  1246.  
  1247. to cope with some well know bugs in some other SSL
  1248. implementations. The high level API functions always set all known
  1249. compatibility options.
  1250.  
  1251. Sometimes sslcat (and the high level https functions that build on it)
  1252. is too fast in signaling the EOF to legacy https servers. This causes
  1253. the server to return empty page. To work around this problem you can
  1254. set global variable
  1255.  
  1256.     $Net::SSLeay::slowly = 1;   # Add sleep so broken servers can keep up
  1257.  
  1258. http/1.1 is not supported. Specifically this module does not know to
  1259. issue or serve multiple http requests per connection. This is a serious
  1260. short coming, but using SSL session cache on your server helps to
  1261. alleviate the CPU load somewhat.
  1262.  
  1263. As of version 1.09 many newer OpenSSL auxiliary functions were
  1264. added (from REM_AUTOMATICALLY_GENERATED_1_09 onwards in SSLeay.xs).
  1265. Unfortunately I have not had any opportunity to test these. Some of
  1266. them are trivial enough that I believe they "just work", but others
  1267. have rather complex interfaces with function pointers and all. In these
  1268. cases you should proceed wit great caution.
  1269.  
  1270. This module defaults to using OpenSSL automatic protocol negotiation
  1271. code for automatically detecting the version of the SSL protocol
  1272. that the other end talks. With most web servers this works just
  1273. fine, but once in a while I get complaints from people that the module
  1274. does not work with some web servers. Usually this can be solved
  1275. by explicitly setting the protocol version, e.g.
  1276.  
  1277.    $Net::SSLeay::ssl_version = 2;  # Insist on SSLv2
  1278.    $Net::SSLeay::ssl_version = 3;  # Insist on SSLv3
  1279.    $Net::SSLeay::ssl_version = 10; # Insist on TLSv1
  1280.  
  1281. Although the autonegotiation is nice to have, the SSL standards
  1282. do not formally specify any such mechanism. Most of the world has
  1283. accepted the SSLeay/OpenSSL way of doing it as the de facto standard. But
  1284. for the few that think differently, you have to explicitly speak
  1285. the correct version. This is not really a bug, but rather a deficiency
  1286. in the standards. If a site refuses to respond or sends back some
  1287. nonsensical error codes (at SSL handshake level), try this option
  1288. before mailing me.
  1289.  
  1290. The high level API returns the certificate of the peer, thus allowing
  1291. one to check what certificate was supplied. However, you will only be
  1292. able to check the certificate after the fact, i.e. you already sent
  1293. your form data by the time you find out that you did not trust them,
  1294. oops.
  1295.  
  1296. So, while being able to know the certificate after the fact is surely
  1297. useful, the security minded would still choose to do the connection
  1298. and certificate verification first and only after that exchange data
  1299. with the site. Currently none of the high level API functions do
  1300. this, thus you would have to program it using the low level API. A
  1301. good place to start is to see how Net::SSLeay::http_cat() function
  1302. is implemented.
  1303.  
  1304. =head1 DIAGNOSTICS
  1305.  
  1306. "Random number generator not seeded!!!"
  1307.   This warning indicates that randomize() was not able to read
  1308.   /dev/random or /dev/urandom, possibly because your system does not
  1309.   have them or they are differently named. You can still use SSL, but
  1310.   the encryption will not be as strong.
  1311.  
  1312. "open_tcp_connection: destination host not found:`server' (port 123) ($!)"
  1313.   Name lookup for host named `server' failed.
  1314.  
  1315. "open_tcp_connection: failed `server', 123 ($!)"
  1316.   The name was resolved, but establising the TCP connection failed.
  1317.  
  1318. "msg 123: 1 - error:140770F8:SSL routines:SSL23_GET_SERVER_HELLO:unknown proto"
  1319.   SSLeay error string. First (123) number is PID, second number (1) indicates
  1320.   the position of the error message in SSLeay error stack. You often see
  1321.   a pile of these messages as errors cascade.
  1322.  
  1323. "msg 123: 1 - error:02001002::lib(2) :func(1) :reason(2)"
  1324.   The same as above, but you didn't call load_error_strings() so SSLeay
  1325.   couldn't verbosely explain the error. You can still find out what it
  1326.   means with this command:
  1327.  
  1328.      /usr/local/ssl/bin/ssleay errstr 02001002
  1329.  
  1330. Password is being asked for private key
  1331.   This is normal behaviour if your private key is encrypted. Either
  1332.   you have to supply the password or you have to use unencrypted
  1333.   private key. Scan OpenSSL.org for the FAQ that explains how to
  1334.   do this (or just study examples/makecert.pl which is used
  1335.   during `make test' to do just that).
  1336.  
  1337. =head1 REPORTING BUGS AND SUPPORT
  1338.  
  1339. Please see README for full bug reporting instructions. In general I do
  1340. not answer for free stupid questions or questions where you did not
  1341. do your home work.
  1342.  
  1343. Commercial support for Net::SSLeay may be obtained from
  1344.  
  1345.    Symlabs (netssleay@symlabs.com)
  1346.    Tel: +351-214.222.630
  1347.    Fax: +351-214.222.637
  1348.  
  1349. =head1 VERSION
  1350.  
  1351. This man page documents version 1.14, released on 25.3.2002.
  1352.  
  1353. There are currently two perl modules for using OpenSSL C
  1354. library: Net::SSLeay (maintaned by me) and SSLeay (maintained by OpenSSL
  1355. team). This module is the Net::SSLeay variant.
  1356.  
  1357. At the time of making this release, Eric's module was still quite
  1358. sketchy and could not be used for real work, thus I felt motivated to
  1359. make this maintenance release. This module is not planned to evolve to
  1360. contain any further functionality, i.e. I will concentrate on just
  1361. making a simple SSL connection over TCP socket. Presumably Eric's own
  1362. module will offer full SSLeay API one day.
  1363.  
  1364. This module uses OpenSSL-0.9.6c. It does not work with any earlier
  1365. version and there is no guarantee that it will work with later
  1366. versions either, though as long as C API does not change, it
  1367. should. This module requires perl5.005, or 5.6.0 (or better?) though I
  1368. believe it would build with any perl5.002 or newer.
  1369.  
  1370. =head1 AUTHOR
  1371.  
  1372. Sampo KellomĪ£ki <sampo@symlabs.com>
  1373.  
  1374. Please send bug reports to the above address. General questions should be
  1375. sent either to me or to the mailing list (subscribe by sending mail
  1376. to openssl-users-request@openssl.org or using web interface at
  1377. http://www.openssl.org/support/).
  1378.  
  1379. =head1 COPYRIGHT
  1380.  
  1381. Copyright (c) 1996-2002 Sampo KellomĪ£ki <sampo@symlabs.com>
  1382. All Rights Reserved.
  1383.  
  1384. Distribution and use of this module is under the same terms as the
  1385. OpenSSL package itself (i.e. free, but mandatory attribution; NO
  1386. WARRANTY). Please consult LICENSE file in the root of the OpenSSL
  1387. distribution.
  1388.  
  1389. While the source distribution of this perl module does not contain
  1390. Eric's or OpenSSL's code, if you use this module you will use OpenSSL
  1391. library. Please give Eric and OpenSSL team credit (as required by
  1392. their licenses).
  1393.  
  1394. And remember, you, and nobody else but you, are responsible for
  1395. auditing this module and OpenSSL library for security problems,
  1396. backdoors, and general suitability for your application.
  1397.  
  1398. =head1 SEE ALSO
  1399.  
  1400.   Net::SSLeay::Handle                      - File handle interface
  1401.   ./Net_SSLeay/examples                    - Example servers and a clients
  1402.   <http://symlabs.com/Net_SSLeay/index.html>  - Net::SSLeay.pm home
  1403.   <http://symlabs.com/Net_SSLeay/smime.html>  - Another module using OpenSSL
  1404.   <http://www.openssl.org/>                - OpenSSL source, documentation, etc
  1405.   openssl-users-request@openssl.org        - General OpenSSL mailing list
  1406.   <http://home.netscape.com/newsref/std/SSL.html>  - SSL Draft specification
  1407.   <http://www.w3c.org>                     - HTTP specifications
  1408.   <http://www.ietf.org/rfc/rfc2617.txt>    - How to send password
  1409.   <http://www.lothar.com/tech/crypto/>     - Entropy Gathering Daemon (EGD)
  1410.   <http://www.aet.tu-cottbus.de/personen/jaenicke/postfix_tls/prngd.html>
  1411.                            - pseudo-random number generating daemon (PRNGD)
  1412.   perl(1)
  1413.   perlref(1)
  1414.   perllol(1)
  1415.   perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod
  1416.  
  1417. =cut
  1418.  
  1419. # ';
  1420.  
  1421. ### Some methods that are macros in C
  1422.  
  1423. sub want_nothing { want(shift) == 1 }
  1424. sub want_read { want(shift) == 2 }
  1425. sub want_write { want(shift) == 3 }
  1426. sub want_X509_lookup { want(shift) == 4 }
  1427.  
  1428. ###
  1429. ### Open TCP stream to given host and port, looking up the details
  1430. ### from system databases or DNS.
  1431. ###
  1432.  
  1433. sub open_tcp_connection {
  1434.     my ($dest_serv, $port) = @_;
  1435.     my ($errs);
  1436.     
  1437.     $port = getservbyname($port, 'tcp') unless $port =~ /^\d+$/;
  1438.     my $dest_serv_ip = gethostbyname($dest_serv);
  1439.     unless (defined($dest_serv_ip)) {
  1440.     $errs = "$0 $$: open_tcp_connection: destination host not found:"
  1441.             . " `$dest_serv' (port $port) ($!)\n";
  1442.     warn $errs if $trace;
  1443.         return wantarray ? (0, $errs) : 0;
  1444.     }
  1445.     my $sin = sockaddr_in($port, $dest_serv_ip);
  1446.     
  1447.     warn "Opening connection to $dest_serv:$port (" .
  1448.     inet_ntoa($dest_serv_ip) . ")" if $trace>2;
  1449.     
  1450.     my $proto = getprotobyname('tcp');
  1451.     if (socket (SSLCAT_S, &PF_INET(), &SOCK_STREAM(), $proto)) {
  1452.         warn "next connect" if $trace>3;
  1453.         if (CORE::connect (SSLCAT_S, $sin)) {
  1454.             my $old_out = select (SSLCAT_S); $| = 1; select ($old_out);
  1455.             warn "connected to $dest_serv, $port" if $trace>3;
  1456.             return wantarray ? (1, undef) : 1; # Success
  1457.         }
  1458.     }
  1459.     $errs = "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n";
  1460.     warn $errs if $trace;
  1461.     close SSLCAT_S;
  1462.     return wantarray ? (0, $errs) : 0; # Fail
  1463. }
  1464.  
  1465. ### Open connection via standard web proxy, if one was defined
  1466. ### using set_proxy().
  1467.  
  1468. sub open_proxy_tcp_connection {
  1469.     my ($dest_serv, $port) = @_;
  1470.     
  1471.     return open_tcp_connection($dest_serv, $port) if !$proxyhost;
  1472.     
  1473.     warn "Connect via proxy: $proxyhost:$proxyport" if $trace>2;
  1474.     my @ret = open_tcp_connection($proxyhost, $proxyport);
  1475.     return wantarray ? @ret : 0 if !$ret[0];  # Connection fail
  1476.     
  1477.     warn "Asking proxy to connect to $dest_serv:$port" if $trace>2;
  1478.     print SSLCAT_S "CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF";
  1479.     my $line = <SSLCAT_S>; 
  1480.     warn "Proxy response: $line" if $trace>2;
  1481.     
  1482.     return wantarray ? (1,undef) : 1;  # Success
  1483. }
  1484.  
  1485. ###
  1486. ### read and write helpers that block
  1487. ###
  1488.  
  1489. sub debug_read {
  1490.     my ($replyr, $gotr) = @_;
  1491.     my $vm = $trace>2 && $linux_debug ?
  1492.     (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
  1493.     warn "  got " . blength($$gotr) . ':'
  1494.     . blength($$replyr) . " bytes (VM=$vm).\n" if $trace == 3;
  1495.     warn "  got `$$gotr' (" . blength($$gotr) . ':'
  1496.     . blength($$replyr) . " bytes, VM=$vm)\n" if $trace>3;
  1497. }
  1498.  
  1499. sub ssl_read_all {
  1500.     my ($ssl,$how_much) = @_;
  1501.     $how_much = 2000000000 unless $how_much;
  1502.     my ($got, $errs);
  1503.     my $reply = '';
  1504.  
  1505.     while ($how_much > 0) {
  1506.     $got = Net::SSLeay::read($ssl,$how_much);
  1507.     last if $errs = print_errs('SSL_read');
  1508.     $how_much -= blength($got);
  1509.     debug_read(\$reply, \$got) if $trace>1;
  1510.     last if $got eq '';  # EOF
  1511.     $reply .= $got;
  1512.     }
  1513.     return wantarray ? ($reply, $errs) : $reply;
  1514. }
  1515.  
  1516. sub ssl_write_all {
  1517.     my $ssl = $_[0];    
  1518.     my ($data_ref, $errs);
  1519.     if (ref $_[1]) {
  1520.     $data_ref = $_[1];
  1521.     } else {
  1522.     $data_ref = \$_[1];
  1523.     }
  1524.     my ($wrote, $written, $to_write) = (0,0, blength($$data_ref));
  1525.     my $vm = $trace>2 && $linux_debug ?
  1526.     (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
  1527.     warn "  write_all VM at entry=$vm\n" if $trace>2;
  1528.     while ($to_write) {
  1529.     #sleep 1; # *** DEBUG
  1530.     warn "partial `$$data_ref'\n" if $trace>3;
  1531.     $wrote = write_partial($ssl, $written, $to_write, $$data_ref);
  1532.     $written += $wrote if defined $wrote;
  1533.     $to_write -= $wrote if defined $wrote;
  1534.     $vm = $trace>2 && $linux_debug ?
  1535.         (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown';
  1536.     warn "  written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2;
  1537.     
  1538.     $errs .= print_errs('SSL_write');
  1539.     return (wantarray ? (undef, $errs) : undef) if $errs;
  1540.     }
  1541.     return wantarray ? ($written, $errs) : $written;
  1542. }
  1543.  
  1544. ### from patch by Clinton Wong <clintdw@netcom.com>
  1545.  
  1546. # ssl_read_until($ssl [, $delimit [, $max_length]])
  1547. #  if $delimit missing, use $/ if it exists, otherwise use \n
  1548. #  read until delimiter reached, up to $max_length chars if defined
  1549.  
  1550. sub ssl_read_until ($;$$) {
  1551.     my ($ssl,$delim, $max_length) = @_;
  1552.     local $[;
  1553.  
  1554.     # guess the delim string if missing
  1555.     if ( ! defined $delim ) {           
  1556.       if ( defined $/ && length $/  ) { $delim = $/ }
  1557.       else { $delim = "\n" }      # Note: \n,$/ value depends on the platform
  1558.     }
  1559.     my $len_delim = length $delim;
  1560.  
  1561.     my ($got);
  1562.     my $reply = '';
  1563.     
  1564.     # If we have OpenSSL 0.9.6a or later, we can use SSL_peek to
  1565.     # speed things up.
  1566.     # N.B. 0.9.6a has security problems, so the support for
  1567.     #      anything earlier than 0.9.6e will be dropped soon.
  1568.     if (&Net::SSLeay::OPENSSL_VERSION_NUMBER >= 0x0090601f) {
  1569.     $max_length = 2000000000 unless (defined $max_length);
  1570.     my ($pending, $peek_length, $found, $done);
  1571.     while (blength($reply) < $max_length and !$done) {
  1572.         #Block if necessary until we get some data
  1573.         $got = Net::SSLeay::peek($ssl,1);
  1574.         last if print_errs('SSL_peek');
  1575.  
  1576.         $pending = Net::SSLeay::pending($ssl) + blength($reply);
  1577.         $peek_length = ($pending > $max_length) ? $max_length : $pending;
  1578.         $peek_length -= blength($reply);
  1579.         $got = Net::SSLeay::peek($ssl, $peek_length);
  1580.         last if print_errs('SSL_peek');
  1581.         $peek_length = blength($got);
  1582.         
  1583.         #$found = index($got, $delim);  # Old and broken
  1584.         
  1585.         # the delimeter may be split across two gets, so we prepend
  1586.         # a little from the last get onto this one before we check
  1587.         # for a match
  1588.         my $match;
  1589.         if(blength($reply) >= blength($delim) - 1) {
  1590.         #if what we've read so far is greater or equal
  1591.         #in length of what we need to prepatch
  1592.         $match = substr $reply, blength($reply) - blength($delim) + 1;
  1593.         } else {
  1594.         $match = $reply;
  1595.         }
  1596.  
  1597.         $match .= $got;
  1598.         $found = index($match, $delim);
  1599.  
  1600.         if ($found > -1) {
  1601.         #$got = Net::SSLeay::read($ssl, $found+$len_delim);
  1602.         #read up to the end of the delimeter
  1603.         $got = Net::SSLeay::read($ssl,
  1604.                      $found + $len_delim
  1605.                      - ((blength $match) - (blength $got)));
  1606.         $done = 1;
  1607.         } else {
  1608.         $got = Net::SSLeay::read($ssl, $peek_length);
  1609.         $done = 1 if ($peek_length == $max_length - blength($reply));
  1610.         } 
  1611.  
  1612.         last if print_errs('SSL_read');
  1613.         debug_read(\$reply, \$got) if $trace>1;
  1614.         last if $got eq '';
  1615.         $reply .= $got;
  1616.     }
  1617.     } else {
  1618.     while (!defined $max_length || length $reply < $max_length) {
  1619.         $got = Net::SSLeay::read($ssl,1);  # one by one
  1620.         last if print_errs('SSL_read');
  1621.         debug_read(\$reply, \$got) if $trace>1;
  1622.         last if $got eq '';
  1623.         $reply .= $got;
  1624.         last if $len_delim
  1625.         && substr($reply, blength($reply)-$len_delim) eq $delim;
  1626.     }
  1627.     }
  1628.     return $reply;
  1629. }
  1630.  
  1631. # ssl_read_CRLF($ssl [, $max_length])
  1632. sub ssl_read_CRLF ($;$) { ssl_read_until($_[0], $CRLF, $_[1]) }
  1633.  
  1634. # ssl_write_CRLF($ssl, $message) writes $message and appends CRLF
  1635. sub ssl_write_CRLF ($$) { 
  1636.   # the next line uses less memory but might use more network packets
  1637.   return ssl_write_all($_[0], $_[1]) + ssl_write_all($_[0], $CRLF);
  1638.  
  1639.   # the next few lines do the same thing at the expense of memory, with
  1640.   # the chance that it will use less packets, since CRLF is in the original
  1641.   # message and won't be sent separately.
  1642.  
  1643.   #my $data_ref;
  1644.   #if (ref $_[1]) { $data_ref = $_[1] }
  1645.   # else { $data_ref = \$_[1] }
  1646.   #my $message = $$data_ref . $CRLF;
  1647.   #return ssl_write_all($_[0], \$message);
  1648. }
  1649.  
  1650. ### Quickly print out with whom we're talking
  1651.  
  1652. sub dump_peer_certificate ($) {
  1653.     my ($ssl) = @_;
  1654.     my $cert = get_peer_certificate($ssl);
  1655.     return if print_errs('get_peer_certificate');
  1656.     print "no cert defined\n" if !defined($cert);
  1657.     # Cipher=NONE with empty cert fix
  1658.     if (!defined($cert) || ($cert == 0)) {
  1659.     warn "cert = `$cert'\n" if $trace;
  1660.     return "Subject Name: undefined\nIssuer  Name: undefined\n";
  1661.     } else {
  1662.     my $x = 'Subject Name: '
  1663.         . X509_NAME_oneline(X509_get_subject_name($cert)) . "\n"
  1664.         . 'Issuer  Name: '
  1665.             . X509_NAME_oneline(X509_get_issuer_name($cert))  . "\n";
  1666.     Net::SSLeay::X509_free($cert);
  1667.     return $x;
  1668.     }
  1669. }
  1670.  
  1671. ### Arrange some randomness for eay PRNG
  1672.  
  1673. sub randomize (;$$) {
  1674.     my ($rn_seed_file, $seed, $egd_path) = @_;
  1675.     my $rnsf = defined($rn_seed_file) && -r $rn_seed_file;
  1676.  
  1677.     $egd_path = $ENV{'EGD_PATH'} if $ENV{'EGD_PATH'};
  1678.     $egd_path = '/tmp/entropy'   unless $egd_path;
  1679.     
  1680.     RAND_seed(rand() + $$);  # Stir it with time and pid
  1681.     
  1682.     unless ($rnsf || -r $Net::SSLeay::random_device || $seed || -S $egd_path) {
  1683.     warn "Random number generator not seeded!!!" if $trace;
  1684.     }
  1685.     
  1686.     RAND_load_file($rn_seed_file, -s _) if $rnsf;
  1687.     RAND_seed($seed) if $seed;
  1688.     RAND_egd($egd_path) if -S $egd_path;
  1689.     RAND_load_file($Net::SSLeay::random_device, $Net::SSLeay::how_random/8)
  1690.     if -r $Net::SSLeay::random_device;
  1691. }
  1692.  
  1693. sub new_x_ctx {
  1694.     if    ($ssl_version == 2)  { $ctx = CTX_v2_new(); }
  1695.     elsif ($ssl_version == 3)  { $ctx = CTX_v3_new(); }
  1696.     elsif ($ssl_version == 10) { $ctx = CTX_tlsv1_new(); }
  1697.     else                       { $ctx = CTX_new(); }
  1698.     return $ctx;
  1699. }
  1700.  
  1701. ###
  1702. ### Basic request - response primitive (don't use for https)
  1703. ###
  1704.  
  1705. sub sslcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert)
  1706.     my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
  1707.     my ($ctx, $ssl, $got, $errs, $written);
  1708.     
  1709.     ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
  1710.     return (wantarray ? (undef, $errs) : undef) unless $got;
  1711.     
  1712.     ### Do SSL negotiation stuff
  1713.         
  1714.     warn "Creating SSL $ssl_version context...\n" if $trace>2;
  1715.     load_error_strings();         # Some bloat, but I'm after ease of use
  1716.     SSLeay_add_ssl_algorithms();  # and debuggability.
  1717.     randomize();
  1718.     
  1719.     $ctx = new_x_ctx();
  1720.     goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
  1721.  
  1722.     CTX_set_options($ctx, &OP_ALL);
  1723.     goto cleanup2 if $errs = print_errs('CTX_set_options');
  1724.  
  1725.     warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
  1726.     set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
  1727.     
  1728.     warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
  1729.     $ssl = new($ctx);
  1730.     goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
  1731.     
  1732.     warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
  1733.     set_fd($ssl, fileno(SSLCAT_S));
  1734.     goto cleanup if $errs = print_errs('set_fd');
  1735.     
  1736.     warn "Entering SSL negotiation phase...\n" if $trace>2;
  1737.  
  1738.     if ($trace>2) {
  1739.     my $i = 0;
  1740.     my $p = '';
  1741.     my $cipher_list = 'Cipher list: ';
  1742.     $p=Net::SSLeay::get_cipher_list($ssl,$i);
  1743.     $cipher_list .= $p if $p;
  1744.     do {
  1745.         $i++;
  1746.         $cipher_list .= ', ' . $p if $p;
  1747.         $p=Net::SSLeay::get_cipher_list($ssl,$i);
  1748.     } while $p;
  1749.     $cipher_list .= '\n';
  1750.     warn $cipher_list;
  1751.     }
  1752.     
  1753.     $got = Net::SSLeay::connect($ssl);
  1754.     warn "SSLeay connect returned $got\n" if $trace>2;
  1755.     goto cleanup if $errs = print_errs('SSL_connect');
  1756.     
  1757.     my $server_cert = get_peer_certificate($ssl);
  1758.     print_errs('get_peer_certificate');
  1759.     if ($trace>1) {        
  1760.     warn "Cipher `" . get_cipher($ssl) . "'\n";
  1761.     print_errs('get_ciper');
  1762.     warn dump_peer_certificate($ssl);
  1763.     }
  1764.     
  1765.     ### Connected. Exchange some data (doing repeated tries if necessary).
  1766.         
  1767.     warn "sslcat $$: sending " . blength($out_message) . " bytes...\n"
  1768.     if $trace==3;
  1769.     warn "sslcat $$: sending `$out_message' (" . blength($out_message)
  1770.     . " bytes)...\n" if $trace>3;
  1771.     ($written, $errs) = ssl_write_all($ssl, $out_message);
  1772.     goto cleanup unless $written;
  1773.     
  1774.     sleep $slowly if $slowly;  # Closing too soon can abort broken servers
  1775.     CORE::shutdown SSLCAT_S, 1;  # Half close --> No more output, send EOF to server
  1776.     
  1777.     warn "waiting for reply...\n" if $trace>2;
  1778.     ($got, $errs) = ssl_read_all($ssl);
  1779.     warn "Got " . blength($got) . " bytes.\n" if $trace==3;
  1780.     warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
  1781.  
  1782. cleanup:        
  1783.     free ($ssl);
  1784.     $errs .= print_errs('SSL_free');
  1785. cleanup2:
  1786.     CTX_free ($ctx);
  1787.     $errs .= print_errs('CTX_free');
  1788.     close SSLCAT_S;    
  1789.     return wantarray ? ($got, $errs, $server_cert) : $got;
  1790. }
  1791.  
  1792. ###
  1793. ### Basic request - response primitive, this is different from sslcat
  1794. ###                 because this does not shutdown the connection.
  1795. ###
  1796.  
  1797. sub https_cat { # address, port, message --> returns reply / (reply,errs,cert)
  1798.     my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_;
  1799.     my ($ctx, $ssl, $got, $errs, $written);
  1800.     
  1801.     ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port);
  1802.     return (wantarray ? (undef, $errs) : undef) unless $got;
  1803.         
  1804.     ### Do SSL negotiation stuff
  1805.         
  1806.     warn "Creating SSL $ssl_version context...\n" if $trace>2;
  1807.     load_error_strings();         # Some bloat, but I'm after ease of use
  1808.     SSLeay_add_ssl_algorithms();  # and debuggability.
  1809.     randomize();
  1810.  
  1811.     $ctx = new_x_ctx();
  1812.     goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx;
  1813.  
  1814.     CTX_set_options($ctx, &OP_ALL);
  1815.     goto cleanup2 if $errs = print_errs('CTX_set_options');
  1816.     
  1817.     warn "Cert `$crt_path' given without key" if $crt_path && !$key_path;
  1818.     set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path;
  1819.     
  1820.     warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2;
  1821.     $ssl = new($ctx);
  1822.     goto cleanup if $errs = print_errs('SSL_new') or !$ssl;
  1823.     
  1824.     warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2;
  1825.     set_fd($ssl, fileno(SSLCAT_S));
  1826.     goto cleanup if $errs = print_errs('set_fd');
  1827.     
  1828.     warn "Entering SSL negotiation phase...\n" if $trace>2;
  1829.     
  1830.     if ($trace>2) {
  1831.     my $i = 0;
  1832.     my $p = '';
  1833.     my $cipher_list = 'Cipher list: ';
  1834.     $p=Net::SSLeay::get_cipher_list($ssl,$i);
  1835.     $cipher_list .= $p if $p;
  1836.     do {
  1837.         $i++;
  1838.         $cipher_list .= ', ' . $p if $p;
  1839.         $p=Net::SSLeay::get_cipher_list($ssl,$i);
  1840.     } while $p;
  1841.     $cipher_list .= '\n';
  1842.     warn $cipher_list;
  1843.     }
  1844.  
  1845.     $got = Net::SSLeay::connect($ssl);
  1846.     warn "SSLeay connect failed" if $trace>2 && $got==0;
  1847.     goto cleanup if $errs = print_errs('SSL_connect');
  1848.     
  1849.     my $server_cert = get_peer_certificate($ssl);
  1850.     print_errs('get_peer_certificate');
  1851.     if ($trace>1) {        
  1852.     warn "Cipher `" . get_cipher($ssl) . "'\n";
  1853.     print_errs('get_ciper');
  1854.     warn dump_peer_certificate($ssl);
  1855.     }
  1856.     
  1857.     ### Connected. Exchange some data (doing repeated tries if necessary).
  1858.         
  1859.     warn "sslcat $$: sending " . blength($out_message) . " bytes...\n"
  1860.     if $trace==3;
  1861.     warn "sslcat $$: sending `$out_message' (" . blength($out_message)
  1862.     . " bytes)...\n" if $trace>3;
  1863.     ($written, $errs) = ssl_write_all($ssl, $out_message);
  1864.     goto cleanup unless $written;
  1865.     
  1866.     warn "waiting for reply...\n" if $trace>2;
  1867.     ($got, $errs) = ssl_read_all($ssl);
  1868.     warn "Got " . blength($got) . " bytes.\n" if $trace==3;
  1869.     warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3;
  1870.  
  1871. cleanup:
  1872.     free ($ssl);
  1873.     $errs .= print_errs('SSL_free');
  1874. cleanup2:
  1875.     CTX_free ($ctx);
  1876.     $errs .= print_errs('CTX_free');
  1877.     close SSLCAT_S;    
  1878.     return wantarray ? ($got, $errs, $server_cert) : $got;
  1879. }
  1880.  
  1881. ###
  1882. ### Easy set up of private key and certificate
  1883. ###
  1884.  
  1885. sub set_cert_and_key ($$$) {
  1886.     my ($ctx, $cert_path, $key_path) = @_;    
  1887.     my $errs = '';
  1888.     # Following will ask password unless private key is not encrypted
  1889.     CTX_use_RSAPrivateKey_file ($ctx, $key_path, &FILETYPE_PEM);
  1890.     $errs .= print_errs("private key `$key_path' ($!)");
  1891.     CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM);
  1892.     $errs .= print_errs("certificate `$cert_path' ($!)");
  1893.     return wantarray ? (undef, $errs) : ($errs eq '');
  1894. }
  1895.  
  1896. ### Old deprecated API
  1897.  
  1898. sub set_server_cert_and_key ($$$) { &set_cert_and_key }
  1899.  
  1900. ### Set up to use web proxy
  1901.  
  1902. sub set_proxy ($$;**) {
  1903.     ($proxyhost, $proxyport, $proxyuser, $proxypass) = @_;
  1904.     require MIME::Base64 if $proxyuser;
  1905.     $proxyauth = 'Proxy-authorization: basic '
  1906.     . MIME::Base64::encode("$proxyuser:$proxypass", '')
  1907.         if $proxyuser;
  1908. }
  1909.  
  1910. ###
  1911. ### Easy https manipulation routines
  1912. ###
  1913.  
  1914. sub make_form {
  1915.     my (@fields) = @_;
  1916.     my $form;
  1917.     while (@fields) {
  1918.     my ($name, $data) = (shift(@fields), shift(@fields));
  1919.     $data =~ s/([^\w\-.\@\$ ])/sprintf("%%%2.2x",ord($1))/gse;
  1920.         $data =~ tr[ ][+];
  1921.     $form .= "$name=$data&";
  1922.     }
  1923.     chop $form;
  1924.     return $form;
  1925. }
  1926.  
  1927. sub make_headers {
  1928.     my (@headers) = @_;
  1929.     my $headers;
  1930.     while (@headers) {
  1931.     my $header = shift(@headers);
  1932.     my $value = shift(@headers);
  1933.     $header =~ s/:$//;
  1934.     $value =~ s/\x0d?\x0a$//; # because we add it soon, see below
  1935.     $headers .= "$header: $value$CRLF";
  1936.     }
  1937.     return $headers;
  1938. }
  1939.  
  1940. sub do_https3 {
  1941.     my ($method, $site, $port, $path, $headers,
  1942.     $content, $mime_type, $crt_path, $key_path) = @_;
  1943.     my ($response, $page, $h,$v);
  1944.  
  1945.     if ($content) {
  1946.     $mime_type = "application/x-www-form-urlencoded" unless $mime_type;
  1947.     my $len = blength($content);
  1948.     $content = "Content-Type: $mime_type$CRLF"
  1949.         . "Content-Length: $len$CRLF$CRLF$content";
  1950.     } else {
  1951.     $content = "$CRLF$CRLF";
  1952.     }
  1953.     my $req = "$method $path HTTP/1.0$CRLF"."Host: $site:$port$CRLF"
  1954.       . (defined $headers ? $headers : '') . "Accept: */*$CRLF$content";    
  1955.  
  1956.     my ($http, $errs, $server_cert)
  1957.     = https_cat($site, $port, $req, $crt_path, $key_path);
  1958.     return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs;
  1959.     
  1960.     $http = '' if !defined $http;
  1961.     ($headers, $page) = split /\s?\n\s?\n/, $http, 2;
  1962.     ($response, $headers) = split /\s?\n/, $headers, 2;
  1963.     return ($page, $response, $headers, $server_cert);
  1964. }
  1965.  
  1966. ### do_https2() is a legacy version in the sense that it is unable
  1967. ### to return all instances of duplicate headers.
  1968.  
  1969. sub do_https2 {
  1970.     my ($page, $response, $headers) = &do_https3;
  1971.     return ($page, $response,
  1972.         map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); }
  1973.         split(/\s?\n/, $headers)
  1974.         )
  1975.         );
  1976. }
  1977.  
  1978. ### Returns headers as a hash where multiple instances of same header
  1979. ### are handled correctly.
  1980.  
  1981. sub do_https4 {
  1982.     my ($page, $response, $headers) = &do_https3;
  1983.     my %hr = ();
  1984.     for my $hh (split /\s?\n/, $headers) {
  1985.     my ($h,$v)=/^(\S+)\:\s*(.*)$/;
  1986.     push @{$hr{uc($h)}}, $v;
  1987.     }
  1988.     return ($page, $response, \%hr);
  1989. }
  1990.  
  1991. sub get_https ($$$;***)  { do_https2(GET  => @_) }
  1992. sub post_https ($$$;***) { do_https2(POST => @_) }
  1993. sub put_https ($$$;***)  { do_https2(PUT  => @_) }
  1994. sub head_https ($$$;***) { do_https2(HEAD => @_) }
  1995.  
  1996. sub get_https3 ($$$;***)  { do_https3(GET  => @_) }
  1997. sub post_https3 ($$$;***) { do_https3(POST => @_) }
  1998. sub put_https3 ($$$;***)  { do_https3(PUT  => @_) }
  1999. sub head_https3 ($$$;***) { do_https3(HEAD => @_) }
  2000.  
  2001. sub get_https4 ($$$;***)  { do_https4(GET  => @_) }
  2002. sub post_https4 ($$$;***) { do_https4(POST => @_) }
  2003. sub put_https4 ($$$;***)  { do_https4(PUT  => @_) }
  2004. sub head_https4 ($$$;***) { do_https4(HEAD => @_) }
  2005.  
  2006. ### Legacy
  2007. # ($page, $respone_or_err, %headers) = do_https(...);
  2008.  
  2009. sub do_https {
  2010.     my ($site, $port, $path, $method, $headers,
  2011.     $content, $mime_type, $crt_path, $key_path) = @_;
  2012.  
  2013.     do_https2($method, $site, $port, $path, $headers,
  2014.          $content, $mime_type, $crt_path, $key_path);
  2015. }
  2016.  
  2017. 1;
  2018. __END__
  2019.