home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _68189974ee5888e3f989ca6027d18413 < prev    next >
Encoding:
Text File  |  2004-06-01  |  13.9 KB  |  435 lines
  1.  
  2. #
  3. # An Simple Web server Socket.
  4. #
  5. # Contributed by John Holdsworth (c) 2001.
  6. # http://www.openpsp.org
  7. #
  8. # This code is distriubuted under the 
  9. # "Artistic" license a copy of which 
  10. # is distributed with perl.
  11. #
  12.  
  13.  
  14. my $ID = q$Id: Socket.pm,v 3.49 2002/01/19 21:37:02 johnh Exp $;
  15.  
  16. require 5.004;
  17. package ActivePerl::DocTools::PSP::Socket;
  18. use base qw(IO::Socket::INET);
  19.  
  20. use vars qw($ID $config $log %env %roots %hosts %users %times);
  21. use Sys::Hostname;
  22. use IO::Socket;
  23. use Symbol;
  24. use strict;
  25.  
  26. my $nuser;
  27.  
  28. $config = {
  29.     # base directory of server for @INC and DOCUMENT_ROOT
  30.     root => (__FILE__ =~ m@(.*)/PSP/Socket.pm@)[0] || ".",
  31.  
  32. };
  33.  
  34. sub newListener {
  35.     # String, String, int
  36.     my $pkg = shift;
  37.     my $socket = $pkg->SUPER::new( Listen=>5, Reuse=>1,
  38.                    Type=>SOCK_STREAM, Proto=>6,
  39. #                   @_ ? @_ : @_ = (LocalPort=>9090)
  40.                    ) or die "@_ not available as '$!'";
  41.     return $socket->initenv();
  42. }
  43.  
  44. sub initenv {
  45.     # PSP::Socket [, PSP::Socket]
  46.     my $listener = $_[1] || $_[0];
  47.  
  48.     # set up static environment variables
  49.     if ( !$ENV{SERVER_PORT} ) {
  50.     @ENV{map "SERVER_$_", qw(SOFTWARE PROTOCOL NAME PORT)} = 
  51.         ( $ID, "HTTP/1.0", hostname(), $listener->sockport );
  52.     $ENV{GATEWAY_INTERFACE} = "CGI/1.0";
  53.     }
  54.  
  55.     return $listener;
  56. }
  57.  
  58. sub run {
  59.     # PSP::Socket, PSP::State, PSP::Env
  60.     my $listener = shift;
  61.     $listener = $listener->new( LocalPort=>9090 ) if !ref $listener;
  62.     $_[0] ||= {listener=>$listener, sessions=>{}};
  63.  
  64.     $SIG{PIPE} = (sub { warn "** Write to closed socket" }) if !$SIG{PIPE};
  65.  
  66.     while ( fileno $listener ) {
  67.     $listener->poll( @_ );
  68.     }
  69.  
  70.     warn "*** Server exiting *** Last known error: '$!'";
  71. }
  72.  
  73. sub poll {
  74.     # PSP::Socket, PSP::State, PSP::Env
  75.     my $listener = shift;
  76.     my ($client, $from) = $listener->accept( ref $listener );
  77.     $client->accepted( $from, @_ ) if $client;
  78. }
  79.  
  80. sub accepted {
  81.     # PSP::Socket, Bytes[], PSP::State, PSP::Env
  82.     my ($client, $from) = (shift, shift);
  83.     my $stdin = $client->divert( $client->fileno() );
  84.     map $_="", @env{keys %env};
  85.  
  86.     # parse header from browser into %env
  87.     $client->parse_request( $stdin => \%env, $from ) || return;
  88.  
  89.     # these are required for CGI.pm to be re-entrant
  90.     CGI->_reset_globals();  # reset parameters
  91.     CGI->nph( 1 );  # Non parsed headers
  92.  
  93.     my $delta = time() - $times{$env{REMOTE_HANDLE}};
  94.     my @log = @env{qw(REMOTE_HANDLE REQUEST_METHOD HTTP_HOST REQUEST_URI)};
  95.     warn "@log +$delta\n" if $log && $env{REQUEST_URI} !~ /^\/default.ida/;
  96.  
  97.     @ENV{keys %env} = map $_ || "", values %env;
  98.     eval { $client->main( @_, bless \%ENV, 'PSP::Env' ) };
  99.     $client->error() if $@;
  100. }
  101.  
  102. sub error {
  103.     # PSP::Socket [, String]
  104.     my $error = $_[1] || $@;
  105.     warn "Error processing url: '$ENV{REQUEST_URI}':\n$error";
  106.  
  107.     # perl errors are also sent to client
  108.     print <<ERROR;
  109. HTTP/1.0 200 OK
  110. Content-type: text/html
  111.  
  112. <plaintext>
  113. *** Error processing url: '$ENV{REQUEST_URI}':
  114. $error
  115. ERROR
  116. }
  117.  
  118. sub main {
  119.     # PSP::Socket, PSP::State, PSP::Env
  120.     return main::main( @_ ) if "main"->can( "main" );
  121.  
  122.     $_[0]->error( "A subclass of package PSP::Socket must implement main()" );
  123. }
  124.  
  125. sub parse_request {
  126.     # PSP::Socket, PSP::Socket, PSP::Env, Bytes[]
  127.     my ($client, $stdin, $env, $from) = @_;    
  128.     my $request = $stdin->getline() || return;
  129.  
  130.     # standard workaround to avoid any blank line left over after a POST
  131.     $request = $stdin->getline() || return if $request =~ /^\r?\n/;
  132.  
  133.     # remote client can be relayed from parent server
  134.     if ( $request =~ /^FROM 0x(\S*)/ ) {
  135.     $from = pack "h*", $1;
  136.     $request = $stdin->getline();
  137.     }
  138.  
  139.     # warn "Request is: $request";
  140.     if ( @$env{qw(REQUEST_METHOD PROXY_REQUEST PROXY_HOST PROXY_PORT
  141.           REQUEST_URI SCRIPT_NAME PATH_INFO
  142.           DOCUMENT_ZIPPED DOCUMENT_DIR DOCUMENT_REST DOCUMENT_EXT
  143.           QUERY_STRING REQUEST_PROTOCOL)} = 
  144.      $request =~ m@^(\S+)\s  # REQUEST_METHOD (GET or POST etc.)
  145.      (\w+://(?:([^/:]+)(?::(\d+))?))? # PROXY_REQUEST (HOST, PORT)
  146.      (() # REQUEST_URI + empty initial SCRIPT_NAME + GZIP flag
  147.       ((/gzip)?/([^./?\s]+(?=/|\s|$))? # DOCUMENT_DIR (first part of path)
  148.       ([^.?\s]*(?:\.+([^?\.\s]+))*)) # PATH_INFO and DOCUMENT_EXT
  149.       (?:\?(\S*))? # QUERY_STRING (URI after any "?")
  150.       )\s+(\S+)? # REQUEST_PROTOCOL (if present, header lines follow)
  151.      @xs ) {
  152.  
  153.     # HTTP>=1.0 has header of "name: value\r\n" pairs then a blank line
  154.     if ( $$env{REQUEST_PROTOCOL} ) { 
  155.  
  156.         while ( my ($name, $value) =
  157.             $stdin->getline() =~ /^([^:]*):? ([^\r\n]*)/ ) {
  158.  
  159.         warn "$name: '$value'"
  160.             if $log && $log > 1 && $name =~ /Cookie/i;
  161.  
  162.         # convert to upper case and replace "-" with "_"
  163.         $name =~ tr/-a-z/_A-Z/;
  164.  
  165.         # prefix names with "HTTP_" unless they start with "CONTENT_"
  166.         $name = "HTTP_$name" if $name !~ /^CONTENT_/;
  167.         $$env{$name} = $value;
  168.         }
  169.     }
  170.  
  171.     # resolve address into hostname of remote client
  172.     # log characterisation and assign user handle
  173.     $client->characterise( $from, $env ) if $from;
  174.  
  175.     # unescape any naughty characters in document path
  176.     $$env{PATH_INFO} =~ s/%(\w{2})/pack "c", hex $1/ge;
  177.  
  178.     # determine root for this server
  179.     $client->document_root( $env );
  180.  
  181.     # use host reported by browser as host name for urls()
  182.     ($$env{SERVER_NAME} = $$env{HTTP_HOST}) =~ s/:.*//g;
  183.     return $$env{PATH_INFO};
  184.     }
  185.  
  186.     warn "Unable to parse: $request";
  187.     return;
  188. }
  189.  
  190. sub characterise {
  191.     my ($client, $from, $env) = @_;
  192.     ($$env{REMOTE_PORT}, my $addr) = unpack_sockaddr_in( $from );
  193.     my $dots = join '.', unpack 'C*', $addr;
  194.  
  195.     $$env{REMOTE_HOST} = $hosts{$addr} ||= 
  196.     gethostbyaddr( $addr, AF_INET ) || $dots;
  197.     $$env{HTTP_HOST} ||= "unknown";
  198.  
  199.     # users are refered to by their "handles" in the server logs
  200.     $$env{REMOTE_HANDLE} = $users{
  201.     my $hndl = "@$env{qw(REMOTE_HOST HTTP_HOST HTTP_USER_AGENT)}"};
  202.     if ( !$$env{REMOTE_HANDLE} ) {
  203.     $$env{REMOTE_HANDLE} = $users{$hndl} = "user".++$nuser;
  204.     $times{$$env{REMOTE_HANDLE}} = time();
  205.     $$env{USER_AGENT} ||= "unknown";
  206.  
  207.     warn $$env{REQUEST_URI} !~ /^\/defaut.ida/ ?
  208.         <<NEW_USER : "red alert $$env{REMOTE_HOST} ($$env{REMOTE_HANDLE}";
  209. ** New user: $$env{REMOTE_HANDLE} - @{[scalar localtime]} - protocol: $$env{REQUEST_PROTOCOL}
  210.   Browser: $$env{HTTP_USER_AGENT}
  211.   Referer: @{[$$env{HTTP_REFERER}||""]}
  212.   Machine: $$env{REMOTE_HOST}
  213.   Address: $dots
  214.  
  215. NEW_USER
  216.     }
  217. }
  218.  
  219. sub document_root {
  220.     my ($client, $env) = @_;
  221.     my $host ||= $$env{HTTP_HOST} ||= hostname();
  222.     return $roots{$host} if exists $roots{$host};
  223.  
  224.     my $root = $config->{root};
  225.     my $port = $host =~ s/:(\d+)$// ? $1 : 80;
  226.     my $name = $client->sockname();
  227.     my $addr = $name? join '.',unpack 'C*',(unpack_sockaddr_in $name)[1]:$host;
  228.  
  229.     # Simple name based virtual hosting is implemented here
  230.     # Different sets of documents can be selected on the basis
  231.     # of which name the server is refered to at the client.
  232.     # This is passed through as the "Host: " header parameter.
  233.     $$env{DOCUMENT_ROOT} = (grep -d $_, map "$root/$_", 
  234.         "$addr:$port", $addr, # virtual hosting by IP address
  235.         "$host:$port", $host, # virtual hosting by Host: from header
  236.         "docs:$port", "docs", "default")[0];
  237.     $$env{PATH_TRANSLATED} = $$env{DOCUMENT_ROOT}.$$env{PATH_INFO};
  238.     return $$env{DOCUMENT_ROOT};
  239. }
  240.  
  241. sub params {
  242.     # read in any POST input POST and convert into method "GET"
  243.     # in case a package CGI instance is created later
  244.     if ( $ENV{REQUEST_METHOD} eq "POST" ) {
  245.     read STDIN, $ENV{QUERY_STRING}, $ENV{CONTENT_LENGTH};
  246.     $ENV{REQUST_METHOD} = "GET";
  247.     }
  248.  
  249.     # split the QUERY_STRING in the format name1=value2&name2=name2
  250.     # into a hash escaping "+" to " " and "%nn" back to ascii char
  251.     map $_ =~ s/%(\w{2})|\+/$1 ? pack "c", hex $1 : " "/ge,
  252.     my @pairs = split /=|&/, $ENV{QUERY_STRING};
  253.     return wantarray() ? @pairs : {@pairs};
  254. }
  255.  
  256. sub cookies {
  257.     # split header string Cookie: name1=value1; name2=value2 into hash
  258.     return {map {
  259.     map $_ =~ s/%(\w{2})/pack "c", hex $1/ge,
  260.     my ( $key, @values ) = split /=|&/, $_;
  261.     $key, \@values;
  262.     } split "; ", $ENV{HTTP_COOKIE}};
  263. }
  264.  
  265. sub authenticate {
  266.     # PSP::Socket, String
  267.     my ($client, $realm, $stdout, $env) = @_;
  268.     $env ||= \%ENV;
  269.  
  270.     if ( (delete $$env{HTTP_AUTHORIZATION} or "") =~ /Basic ([^;]*)/ ) {
  271.     (my $str = $1) =~ tr@A-Za-z0-9+=/@@cd;  # remove non-base64 chars
  272.     warn "Length of base64 data not a multiple of 4" if (length($str) % 4);
  273.  
  274.     $str =~ s/=+$//;                        # remove padding
  275.     $str =~ tr@A-Za-z0-9+/@ -_@;            # convert to uuencoded format
  276.  
  277.     return join "", map {
  278.         unpack("u", chr(32 + length($_)*3/4) . $_ );    # uudecode
  279.     } $str =~ /(.{1,60})/gs;
  280.     }
  281.     else {
  282.     $stdout ||= \*STDOUT;
  283.     print $stdout <<AUTH_REQUIRED;
  284. HTTP/1.0 401 Authentification required
  285. WWW-Authenticate: Basic realm="$realm"
  286.  
  287. AUTH_REQUIRED
  288.     return ();
  289.     }
  290. }
  291.  
  292. sub divert {
  293.     # PSP::Socket, int
  294.     my ($client, $fileno) = @_;
  295.  
  296.     # redirect STDIN and STDOUT as a CGI script would expect
  297.     open STDIN,  "<& $fileno" or die "dup STDIN  => $fileno '$!'";
  298.     open STDOUT, ">& $fileno" or die "dup STDOUT => $fileno '$!'";
  299.  
  300.     select STDOUT; $| = 1;
  301.     return bless \*STDIN, 'IO::Handle';
  302. }
  303.  
  304. sub DESTROY {
  305.     # reopen these to close them and keep them out of dups way
  306.     my $log = fileno main::STDLOG ? "main::STDLOG" : "STDERR";
  307.     open STDIN,  ">& $log" or die "dup STDIN ->CONSOLE '$!'";
  308.     open STDERR, ">& $log" or die "dup STDERR->CONSOLE '$!'"
  309.     if fileno main::STDLOG;
  310.  
  311.     close STDOUT; # reaps any gzips
  312.     open STDOUT, ">& $log" or die "dup STDOUT->CONSOLE '$!'";
  313.     select STDOUT; $| = 1;
  314.  
  315.     # warn "   DESTROYED @_" if $debug;
  316.     return shift->SUPER::DESTROY();
  317. }
  318.  
  319. 1;
  320.  
  321. __END__
  322.  
  323. =head1 NAME
  324.  
  325. PSP::Socket - Socket to process Web requests.
  326.  
  327. =head1 SYNOPSIS
  328.  
  329. Subclass of IO::Socket::INET to simulate CGI interface without a fork().
  330. A web application can subclass this package and request will be served
  331. by the main() method of that class. This method can be coded as you would
  332. a noraml CGI script. A script "../exmaple.pl" is provided with this
  333. distribution demonstrates this with a simple implementation of "mastermind".
  334.  
  335. =head1 DESCRIPTION
  336.  
  337. This class accepts connections from browser clients on the specified
  338. LocalPort and reqdirects STDIN and STDOUT to the client to allow
  339. the request to be precessed without a fork in a manner compatabile
  340. with the Apache "CGI" interface. Requests are expected to be processed
  341. by overriding the "main()" method of a subclass of this package.
  342.  
  343. =head2 METHODS
  344.  
  345. =head3 $listener = PSP::Socket->new( LocalPort=>9090 );
  346.  
  347. Create a new instance of a Web server for accepting and serving connections
  348. from browser clients. This will generally be called for a subclass of 
  349. PSP::Socket
  350.  
  351. =head3 $listener->initenv();
  352.  
  353. Setup unchanging environment varaiable which are part of the CGI interface
  354. which identify the server software, port number etc.
  355.  
  356. =head3 $listener->run();
  357.  
  358. Run the Web serverm polling for new connections, accepting them, parsing
  359. their requests and serveing them by calling the main() method of listeners
  360. package.
  361.  
  362. =head3 $listener->poll();
  363.  
  364. Poll for a connection from a browser by calling "accept()". This would
  365. generally block unless the socket has been fcntled to be O_NONBLOCK
  366. or the socket was opened with a zero (or near zero to work around a
  367. restriction in IO::Socket) timeout. Calls "accepted()" on the client
  368. socket returned for it to be processed.
  369.  
  370. =head3 $client->accepted( $from, ... );
  371.  
  372. A new connection has arrived from a client and should be processed.
  373. The request header is parsed by "parse_request()" and STDIN/STDOUT
  374. redirected to be connected directly to the client browser (so called
  375. "NPH" or non-parsed-header operation). Method main is then called on
  376. the socket to process the request.
  377.  
  378. =head3 $client->error( ... );
  379.  
  380. Create a Web page reporting an server error to the client browser.
  381.  
  382. =head3 $client->main( ... );
  383.  
  384. This is the method which should actually process the request and
  385. should be overidden in a subclass of thispackage to do something useful.
  386.  
  387. =head3 $client->parse_request();
  388.  
  389. Parse the incomming header from the browser client and setup the
  390. environment varaiables specified in the CGI "common gateway interface"
  391. to allow modules such as "CGI.pm" to operate as the would from
  392. a CGI script.
  393.  
  394. =head3 $client->characterise( $from $env );
  395.  
  396. As a new user connects, record any refering page and the browser type.
  397. This is used to determine which browsers to support.
  398.  
  399. =head3 $client->document_root( $env );
  400.  
  401. Determine the root directory for documents for the server that the client
  402. connected to. A Web servers host can be connected to using a number of 
  403. different names and this information is recorded in the "Host:" request
  404. attribute sent from the client browser. This can be used to switch between
  405. a number document driectories to create a "Virtual hosts". Create a driectory
  406. with the name of the vritual host and it will be used for that web site.
  407.  
  408. =head3 $client->params();
  409.  
  410. An implementation of parameter parsing to demystify it a little
  411. but in general it is best to use CGI.pm.
  412.  
  413. =head3 $client->cookies();
  414.  
  415. Returns a hash of cookies again to show how it is done.
  416.  
  417. =head3 $client->authenticate( $realm );
  418.  
  419. The last utility routine which requires the user to login to a page for
  420. which this function is called. The resulting login is unencoded and
  421. returned to the callee. If this function returns an empty array a
  422. "401 authentification required" header has been sent to the browser
  423. to popup a login panel for the "realm" and thepage must retry.
  424.  
  425. =head3 $client->divert();
  426.  
  427. connects STDIN and STDOUT to the socket connected to the client browser
  428. so that output sent using "print()" will find its way to the browser.
  429.  
  430. =head3 $client->DESTROY();
  431.  
  432. called when the client socket closes to unrediect STDIN and STDOUT
  433. so the the connect to the client is closed correctly.
  434.  
  435.