home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / HTTP / Daemon.pm < prev    next >
Text File  |  1997-11-26  |  13KB  |  582 lines
  1. # $Id: Daemon.pm,v 1.15 1997/11/26 10:44:08 aas Exp $
  2. #
  3.  
  4. use strict;
  5.  
  6. package HTTP::Daemon;
  7.  
  8. =head1 NAME
  9.  
  10. HTTP::Daemon - a simple http server class
  11.  
  12. =head1 SYNOPSIS
  13.  
  14.   use HTTP::Daemon;
  15.   use HTTP::Status;
  16.  
  17.   $d = new HTTP::Daemon;
  18.   print "Please contact me at: <URL:", $d->url, ">\n";
  19.   while ($c = $d->accept) {
  20.       $r = $c->get_request;
  21.       if ($r) {
  22.       if ($r->method eq 'GET' and $r->url->path eq "/xyzzy") {
  23.               # this is *not* recommened practice
  24.           $c->send_file_response("/etc/passwd");
  25.       } else {
  26.           $c->send_error(RC_FORBIDDEN)
  27.       }
  28.       }
  29.       $c = undef;  # close connection
  30.   }
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. Instances of the I<HTTP::Daemon> class are HTTP/1.1 servers that
  35. listens on a socket for incoming requests. The I<HTTP::Daemon> is a
  36. sub-class of I<IO::Socket::INET>, so you can do socket operations
  37. directly on it.
  38.  
  39. The accept() method will return when a connection from a client is
  40. available. The returned value will be a reference to a object of the
  41. I<HTTP::Daemon::ClientConn> class which is another I<IO::Socket::INET>
  42. subclass. Calling the get_request() method on this object will read
  43. data from the client and return an I<HTTP::Request> object reference.
  44.  
  45. This HTTP daemon does not fork(2) for you.  Your application, i.e. the
  46. user of the I<HTTP::Daemon> is reponsible for forking if that is
  47. desirable.  Also note that the user is responsible for generating
  48. responses that conforms to the HTTP/1.1 protocol.  The
  49. I<HTTP::Daemon::ClientConn> provide some methods that make this easier.
  50.  
  51. =head1 METHODS
  52.  
  53. The following is a list of methods that are new (or enhanced) relative
  54. to the I<IO::Socket::INET> base class.
  55.  
  56. =over 4
  57.  
  58. =cut
  59.  
  60.  
  61. use vars qw($VERSION @ISA $PROTO);
  62.  
  63. $VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
  64.  
  65. use IO::Socket ();
  66. @ISA=qw(IO::Socket::INET);
  67.  
  68. $PROTO = "HTTP/1.1";
  69.  
  70. =item $d = new HTTP::Daemon
  71.  
  72. The object constructor takes the same parameters as the
  73. I<IO::Socket::INET> constructor.  It can also be called without
  74. specifying any parameters. The daemon will then set up a listen queue
  75. of 5 connections and allocate some random port number.  A server
  76. that want to bind to some specific address on the standard HTTP port
  77. will be constructed like this:
  78.  
  79.   $d = new HTTP::Daemon
  80.         LocalAddr => 'www.someplace.com',
  81.         LocalPort => 80;
  82.  
  83. =cut
  84.  
  85. sub new
  86. {
  87.     my($class, %args) = @_;
  88.     $args{Listen} ||= 5;
  89.     $args{Proto}  ||= 'tcp';
  90.     my $self = $class->SUPER::new(%args);
  91.     return undef unless $self;
  92.  
  93.     my $host = $args{LocalAddr};
  94.     unless ($host) {
  95.     require Sys::Hostname;
  96.     $host = Sys::Hostname::hostname();
  97.     }
  98.     ${*$self}{'httpd_server_name'} = $host;
  99.     $self;
  100. }
  101.  
  102.  
  103. =item $c = $d->accept([$pkg])
  104.  
  105. Same as I<IO::Socket::accept> but will return an
  106. I<HTTP::Daemon::ClientConn> reference by default.  It will return
  107. undef if you have specified a timeout and no connection is made within
  108. that time.
  109.  
  110. =cut
  111.  
  112. sub accept
  113. {
  114.     my $self = shift;
  115.     my $pkg = shift || "HTTP::Daemon::ClientConn";
  116.     my $sock = $self->SUPER::accept($pkg);
  117.     ${*$sock}{'httpd_daemon'} = $self if $sock;
  118.     $sock;
  119. }
  120.  
  121.  
  122. =item $d->url
  123.  
  124. Returns a URL string that can be used to access the server root.
  125.  
  126. =cut
  127.  
  128. sub url
  129. {
  130.     my $self = shift;
  131.     my $url = "http://";
  132.     $url .= ${*$self}{'httpd_server_name'};
  133.     my $port = $self->sockport;
  134.     $url .= ":$port" if $port != 80;
  135.     $url .= "/";
  136.     $url;
  137. }
  138.  
  139.  
  140. =item $d->product_tokens
  141.  
  142. Returns the name that this server will use to identify itself.  This
  143. is the string that is sent with the I<Server> response header.
  144.  
  145. =cut
  146.  
  147. sub product_tokens
  148. {
  149.     "libwww-perl-daemon/$HTTP::Daemon::VERSION";
  150. }
  151.  
  152.  
  153. package HTTP::Daemon::ClientConn;
  154.  
  155. use vars '@ISA';
  156. use IO::Socket ();
  157. @ISA=qw(IO::Socket::INET);
  158.  
  159. use HTTP::Request  ();
  160. use HTTP::Response ();
  161. use HTTP::Status;
  162. use HTTP::Date qw(time2str);
  163. use URI::URL qw(url);
  164. use LWP::MediaTypes qw(guess_media_type);
  165. use Carp ();
  166.  
  167. my $CRLF = "\015\012";   # "\r\n" is not portable
  168.  
  169. =back
  170.  
  171. The I<HTTP::Daemon::ClientConn> is also a I<IO::Socket::INET>
  172. subclass. Instances of this class are returned by the accept() method
  173. of the I<HTTP::Daemon>.  The following additional methods are
  174. provided:
  175.  
  176. =over 4
  177.  
  178. =item $c->get_request
  179.  
  180. Will read data from the client and turn it into a I<HTTP::Request>
  181. object which is then returned. Will return undef if reading of the
  182. request failed.  If it fails, then the I<HTTP::Daemon::ClientConn>
  183. object ($c) should be discarded.
  184.  
  185. The $c->get_request method support HTTP/1.1 content bodies, including
  186. I<chunked> transfer encoding with footer and I<multipart/*> types.
  187.  
  188. =cut
  189.  
  190. sub get_request
  191. {
  192.     my $self = shift;
  193.     my $buf = "";
  194.     
  195.     my $timeout = $ {*$self}{'io_socket_timeout'};
  196.     my  $fdset = "";
  197.     vec($fdset, $self->fileno,1) = 1;
  198.  
  199.   READ_HEADER:
  200.     while (1) {
  201.     if ($timeout) {
  202.         return undef unless select($fdset,undef,undef,$timeout);
  203.     }
  204.     my $n = sysread($self, $buf, 1024, length($buf));
  205.     return undef if !$n;  # unexpected EOF
  206.     if ($buf =~ /^\w+[^\n]+HTTP\/\d+\.\d+\015?\012/) {
  207.         last READ_HEADER if $buf =~ /(\015?\012){2}/;
  208.     } elsif ($buf =~ /\012/) {
  209.         last READ_HEADER;  # HTTP/0.9 client
  210.     }
  211.     }
  212.     $buf =~ s/^(\w+)\s+(\S+)(?:\s+(HTTP\/\d+\.\d+))?[^\012]*\012//;
  213.     my $proto = $3 || "HTTP/0.9";
  214.     ${*$self}{'httpd_client_proto'} = $proto;
  215.     my $r = HTTP::Request->new($1, url($2, $self->daemon->url));
  216.     $r->protocol($proto);
  217.  
  218.     my($key, $val);
  219.   HEADER:
  220.     while ($buf =~ s/^([^\012]*)\012//) {
  221.     $_ = $1;
  222.     s/\015$//;
  223.     if (/^([\w\-]+)\s*:\s*(.*)/) {
  224.         $r->push_header($key, $val) if $key;
  225.         ($key, $val) = ($1, $2);
  226.     } elsif (/^\s+(.*)/) {
  227.         $val .= " $1";
  228.     } else {
  229.         last HEADER;
  230.     }
  231.     }
  232.     $r->push_header($key, $val) if $key;
  233.  
  234.     my $te  = $r->header('Transfer-Encoding');
  235.     my $ct  = $r->header('Content-Type');
  236.     my $len = $r->header('Content-Length');
  237.  
  238.     if ($te && lc($te) eq 'chunked') {
  239.     # Handle chunked transfer encoding
  240.     my $body = "";
  241.       CHUNK:
  242.     while (1) {
  243.         if ($buf =~ s/^([^\012]*)\012//) {
  244.         my $chunk_head = $1;
  245.         $chunk_head =~ /^([0-9A-Fa-f]+)/;
  246.         return undef unless length($1);
  247.         my $size = hex($1);
  248.         last CHUNK if $size == 0;
  249.  
  250.         my $missing = $size - length($buf);
  251.         $missing += 2; # also read CRLF at chunk end
  252.         $body .= $buf;
  253.         $buf = "";
  254.         # must read rest of chunk and append it to the $body
  255.         while ($missing > 0) {
  256.             if ($timeout) {
  257.             return undef unless select($fdset,undef,undef,$timeout);
  258.             }
  259.             my $n = sysread($self, $body, $missing, length($body));
  260.             return undef if !$n;
  261.             $missing -= $n;
  262.         }
  263.         substr($body, -2, 2) = ''; # remove CRLF at end
  264.  
  265.         } else {
  266.         # need more data in order to have a complete chunk header
  267.         if ($timeout) {
  268.             return undef unless select($fdset,undef,undef,$timeout);
  269.         }
  270.         my $n = sysread($self, $buf, 2048, length($buf));
  271.         return undef if !$n;
  272.         }
  273.     }
  274.     $r->content($body);
  275.  
  276.     # pretend it was a normal entity body
  277.     $r->remove_header('Transfer-Encoding');
  278.     $r->header('Content-Length', length($body));
  279.  
  280.     my($key, $val);
  281.       FOOTER:
  282.     while (1) {
  283.         if ($buf !~ /\012/) {
  284.         # need at least one line to look at
  285.         if ($timeout) {
  286.             return undef unless select($fdset,undef,undef,$timeout);
  287.         }
  288.         my $n = sysread($self, $buf, 2048, length($buf));
  289.         return undef if !$n;
  290.         } else {
  291.         $buf =~ s/^([^\012]*)\012//;
  292.         $_ = $1;
  293.         s/\015$//;
  294.         last FOOTER if length($_) == 0;
  295.  
  296.         if (/^([\w\-]+)\s*:\s*(.*)/) {
  297.             $r->push_header($key, $val) if $key;
  298.             ($key, $val) = ($1, $2);
  299.         } elsif (/^\s+(.*)/) {
  300.             $val .= " $1";
  301.         } else {
  302.             return undef;  # bad syntax
  303.         }
  304.         }
  305.     }
  306.     $r->push_header($key, $val) if $key;
  307.  
  308.     } elsif ($te) {
  309.     # Unknown transfer encoding
  310.     $self->send_error(501);
  311.     return undef;
  312.  
  313.     } elsif ($ct && lc($ct) =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*(\w+)/) {
  314.     # Handle multipart content type
  315.     my $boundary = "$CRLF--$1--$CRLF";
  316.     while (index($buf, $boundary) < 0) {
  317.         # end marker not yet found
  318.         if ($timeout) {
  319.         return undef unless select($fdset,undef,undef,$timeout);
  320.         }
  321.         my $n = sysread($self, $buf, 2048, length($buf));
  322.         return undef if !$n;
  323.     }
  324.     $r->content($buf);
  325.  
  326.     } elsif ($len) {
  327.     # Plain body specified by "Content-Length"
  328.  
  329.     $len -= length($buf);
  330.     while ($len > 0) {
  331.         if ($timeout) {
  332.         return undef unless select($fdset,undef,undef,$timeout);
  333.         }
  334.         my $n = sysread($self, $buf, $len, length($buf));
  335.         return undef if !$n;
  336.         $len -= $n;
  337.     }
  338.     $r->content($buf);
  339.  
  340.     }
  341.  
  342.     $r;
  343. }
  344.  
  345.  
  346. =item $c->antique_client
  347.  
  348. Returns TRUE if the client speaks the HTTP/0.9 protocol, i.e. no
  349. status code or headers should be returned.
  350.  
  351. =cut
  352.  
  353. sub antique_client
  354. {
  355.     my $self = shift;
  356.     ${*$self}{'httpd_client_proto'} eq 'HTTP/0.9';
  357. }
  358.  
  359.  
  360. =item $c->send_status_line( [$code, [$mess, [$proto]]] )
  361.  
  362. Sends the status line back to the client.
  363.  
  364. =cut
  365.  
  366. sub send_status_line
  367. {
  368.     my($self, $status, $message, $proto) = @_;
  369.     return if $self->antique_client;
  370.     $status  ||= RC_OK;
  371.     $message ||= status_message($status);
  372.     $proto   ||= $HTTP::Daemon::PROTO;
  373.     print $self "$proto $status $message$CRLF";
  374. }
  375.  
  376.  
  377. sub send_crlf
  378. {
  379.     my $self = shift;
  380.     print $self $CRLF;
  381. }
  382.  
  383.  
  384. =item $c->send_basic_header( [$code, [$mess, [$proto]]] )
  385.  
  386. Sends the status line and the "Date:" and "Server:" headers back to
  387. the client.
  388.  
  389. =cut
  390.  
  391. sub send_basic_header
  392. {
  393.     my $self = shift;
  394.     return if $self->antique_client;
  395.     $self->send_status_line(@_);
  396.     print $self "Date: ", time2str(time), $CRLF;
  397.     my $product = $self->daemon->product_tokens;
  398.     print $self "Server: $product$CRLF" if $product;
  399. }
  400.  
  401.  
  402. =item $c->send_response( [$res] )
  403.  
  404. Takes a I<HTTP::Response> object as parameter and send it back to the
  405. client as the response.
  406.  
  407. =cut
  408.  
  409. sub send_response
  410. {
  411.     my $self = shift;
  412.     my $res = shift;
  413.     if (!ref $res) {
  414.     $res ||= RC_OK;
  415.     $res = HTTP::Response->new($res, @_);
  416.     }
  417.     unless ($self->antique_client) {
  418.     $self->send_basic_header($res->code, $res->message, $res->protocol);
  419.     print $self $res->headers_as_string($CRLF);
  420.     print $self $CRLF;  # separates headers and content
  421.     }
  422.     print $self $res->content;
  423. }
  424.  
  425.  
  426. =item $c->send_redirect( $loc, [$code, [$entity_body]] )
  427.  
  428. Sends a redirect response back to the client.  The location ($loc) can
  429. be an absolute or a relative URL. The $code must be one the redirect
  430. status codes, and it defaults to "301 Moved Permanently"
  431.  
  432. =cut
  433.  
  434. sub send_redirect
  435. {
  436.     my($self, $loc, $status, $content) = @_;
  437.     $status ||= RC_MOVED_PERMANENTLY;
  438.     Carp::croak("Status '$status' is not redirect") unless is_redirect($status);
  439.     $self->send_basic_header($status);
  440.     $loc = url($loc, $self->daemon->url) unless ref($loc);
  441.     $loc = $loc->abs;
  442.     print $self "Location: $loc$CRLF";
  443.     if ($content) {
  444.     my $ct = $content =~ /^\s*</ ? "text/html" : "text/plain";
  445.     print $self "Content-Type: $ct$CRLF";
  446.     }
  447.     print $self $CRLF;
  448.     print $self $content if $content;
  449. }
  450.  
  451.  
  452. =item $c->send_error( [$code, [$error_message]] )
  453.  
  454. Send an error response back to the client.  If the $code is missing a
  455. "Bad Request" error is reported.  The $error_message is a string that
  456. is incorporated in the body of the HTML entity body.
  457.  
  458. =cut
  459.  
  460. sub send_error
  461. {
  462.     my($self, $status, $error) = @_;
  463.     $status ||= RC_BAD_REQUEST;
  464.     Carp::croak("Status '$status' is not an error") unless is_error($status);
  465.     my $mess = status_message($status);
  466.     $error  ||= "";
  467.     unless ($self->antique_client) {
  468.         $self->send_basic_header($status);
  469.         print $self "Content-Type: text/html$CRLF";
  470.         print $self $CRLF;
  471.     }
  472.     print $self <<EOT;
  473. <title>$status $mess</title>
  474. <h1>$status $mess</h1>
  475. $error
  476. EOT
  477.     $status;
  478. }
  479.  
  480.  
  481. =item $c->send_file_response($filename)
  482.  
  483. Send back a response with the specified $filename as content.  If the
  484. file happen to be a directory we will generate a HTML index for it.
  485.  
  486. =cut
  487.  
  488. sub send_file_response
  489. {
  490.     my($self, $file) = @_;
  491.     if (-d $file) {
  492.     $self->send_dir($file);
  493.     } elsif (-f _) {
  494.     # plain file
  495.     local(*F);
  496.     sysopen(F, $file, 0) or 
  497.       return $self->send_error(RC_FORBIDDEN);
  498.     my($ct,$ce) = guess_media_type($file);
  499.     my($size,$mtime) = (stat _)[7,9];
  500.     unless ($self->antique_client) {
  501.         $self->send_basic_header;
  502.         print $self "Content-Type: $ct$CRLF";
  503.         print $self "Content-Encoding: $ce$CRLF" if $ce;
  504.         print $self "Content-Length: $size$CRLF";
  505.         print $self "Last-Modified: ", time2str($mtime), "$CRLF";
  506.         print $self $CRLF;
  507.     }
  508.     $self->send_file(\*F);
  509.     return RC_OK;
  510.     } else {
  511.     $self->send_error(RC_NOT_FOUND);
  512.     }
  513. }
  514.  
  515.  
  516. sub send_dir
  517. {
  518.     my($self, $dir) = @_;
  519.     $self->send_error(RC_NOT_FOUND) unless -d $dir;
  520.     $self->send_error(RC_NOT_IMPLEMENTED);
  521. }
  522.  
  523.  
  524. =item $c->send_file($fd);
  525.  
  526. Copies the file back to the client.  The file can be a string (which
  527. will be interpreted as a filename) or a reference to a glob.
  528.  
  529. =cut
  530.  
  531. sub send_file
  532. {
  533.     my($self, $file) = @_;
  534.     my $opened = 0;
  535.     if (!ref($file)) {
  536.     local(*F);
  537.     open(F, $file) || return undef;
  538.     $file = \*F;
  539.     $opened++;
  540.     }
  541.     my $cnt = 0;
  542.     my $buf = "";
  543.     my $n;
  544.     while ($n = sysread($file, $buf, 8*1024)) {
  545.     last if !$n;
  546.     $cnt += $n;
  547.     print $self $buf;
  548.     }
  549.     close($file) if $opened;
  550.     $cnt;
  551. }
  552.  
  553.  
  554. =item $c->daemon
  555.  
  556. Return a reference to the corresponding I<HTTP::Daemon> object.
  557.  
  558. =cut
  559.  
  560. sub daemon
  561. {
  562.     my $self = shift;
  563.     ${*$self}{'httpd_daemon'};
  564. }
  565.  
  566. =back
  567.  
  568. =head1 SEE ALSO
  569.  
  570. L<IO::Socket>, L<Apache>
  571.  
  572. =head1 COPYRIGHT
  573.  
  574. Copyright 1996, Gisle Aas
  575.  
  576. This library is free software; you can redistribute it and/or
  577. modify it under the same terms as Perl itself.
  578.  
  579. =cut
  580.  
  581. 1;
  582.