home *** CD-ROM | disk | FTP | other *** search
/ PC Open 100 / PC Open 100 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / UI / HTTP.pm < prev   
Encoding:
Perl POD Document  |  2004-03-05  |  12.1 KB  |  368 lines
  1. #----------------------------------------------------------------------------
  2. #
  3. # This package contains an HTTP server used as a base class for other
  4. # modules that service requests over HTTP (e.g. the UI)
  5. #
  6. # Copyright (c) 2001-2003 John Graham-Cumming
  7. #
  8. #   This file is part of POPFile
  9. #
  10. #   POPFile is free software; you can redistribute it and/or modify
  11. #   it under the terms of the GNU General Public License as published by
  12. #   the Free Software Foundation; either version 2 of the License, or
  13. #   (at your option) any later version.
  14. #
  15. #   POPFile is distributed in the hope that it will be useful,
  16. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. #   GNU General Public License for more details.
  19. #
  20. #   You should have received a copy of the GNU General Public License
  21. #   along with POPFile; if not, write to the Free Software
  22. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  23. #
  24. #----------------------------------------------------------------------------
  25. package UI::HTTP;
  26.  
  27. use POPFile::Module;
  28. @ISA = ("POPFile::Module");
  29.  
  30. use strict;
  31. use warnings;
  32. use locale;
  33.  
  34. use IO::Socket::INET qw(:DEFAULT :crlf);
  35. use IO::Select;
  36.  
  37. # A handy variable containing the value of an EOL for the network
  38.  
  39. my $eol = "\015\012";
  40.  
  41. #----------------------------------------------------------------------------
  42. # new
  43. #
  44. #   Class new() function
  45. #----------------------------------------------------------------------------
  46. sub new
  47. {
  48.     my $type = shift;
  49.     my $self = POPFile::Module->new();
  50.  
  51.     bless $self;
  52.  
  53.     return $self;
  54. }
  55.  
  56. # ---------------------------------------------------------------------------------------------
  57. #
  58. # start
  59. #
  60. # Called to start the HTTP interface running
  61. #
  62. # ---------------------------------------------------------------------------------------------
  63. sub start
  64. {
  65.     my ( $self ) = @_;
  66.  
  67.     $self->{server_} = IO::Socket::INET->new( Proto     => 'tcp',             # PROFILE BLOCK START
  68.                                     $self->config_( 'local' )  == 1 ? (LocalAddr => 'localhost') : (),
  69.                                      LocalPort => $self->config_( 'port' ),
  70.                                      Listen    => SOMAXCONN,
  71.                                      Reuse     => 1 );                        # PROFILE BLOCK STOP
  72.  
  73.     if ( !defined( $self->{server_} ) ) {
  74.         my $port = $self->config_( 'port' );
  75.         my $name = $self->name();
  76.         print STDERR <<EOM;                                                   # PROFILE BLOCK START
  77.  
  78. \nCouldn't start the $name HTTP interface because POPFile could not bind to the
  79. HTTP port $port. This could be because there is another service
  80. using that port or because you do not have the right privileges on
  81. your system (On Unix systems this can happen if you are not root
  82. and the port you specified is less than 1024).
  83.  
  84. EOM
  85. # PROFILE BLOCK STOP
  86.  
  87.         return 0;
  88.     }
  89.  
  90.     $self->{selector_} = new IO::Select( $self->{server_} );
  91.  
  92.     return 1;
  93. }
  94.  
  95. # ---------------------------------------------------------------------------------------------
  96. #
  97. # stop
  98. #
  99. # Called when the interface must shutdown
  100. #
  101. # ---------------------------------------------------------------------------------------------
  102. sub stop
  103. {
  104.     my ( $self ) = @_;
  105.  
  106.     close $self->{server_} if ( defined( $self->{server_} ) );
  107. }
  108.  
  109. # ---------------------------------------------------------------------------------------------
  110. #
  111. # service
  112. #
  113. # Called to handle interface requests
  114. #
  115. # ---------------------------------------------------------------------------------------------
  116. sub service
  117. {
  118.     my ( $self ) = @_;
  119.  
  120.     my $code = 1;
  121.  
  122.     # See if there's a connection waiting for us, if there is we accept it handle a single
  123.     # request and then exit
  124.     my ( $ready ) = $self->{selector_}->can_read(0);
  125.  
  126.     # Handle HTTP requests for the UI
  127.     if ( ( defined( $ready ) ) && ( $ready == $self->{server_} ) ) {
  128.  
  129.         if ( my $client = $self->{server_}->accept() ) {
  130.  
  131.             # Check that this is a connection from the local machine, if it's not then we drop it immediately
  132.             # without any further processing.  We don't want to allow remote users to admin POPFile
  133.  
  134.             my ( $remote_port, $remote_host ) = sockaddr_in( $client->peername() );
  135.  
  136.             if ( ( $self->config_( 'local' ) == 0 ) ||                # PROFILE BLOCK START
  137.                  ( $remote_host eq inet_aton( "127.0.0.1" ) ) ) {     # PROFILE BLOCK STOP
  138.  
  139.                 # Read the request line (GET or POST) from the client and if we manage to do that
  140.                 # then read the rest of the HTTP headers grabbing the Content-Length and using
  141.                 # it to read any form POST content into $content
  142.  
  143.                 $client->autoflush(1);
  144.  
  145.                 if ( ( defined( $client ) ) && ( my $request = $self->slurp_( $client ) ) ) {
  146.                     my $content_length = 0;
  147.                     my $content;
  148.  
  149.                     while ( my $line = $self->slurp_( $client ) )  {
  150.                         $content_length = $1 if ( $line =~ /Content-Length: (\d+)/i );
  151.  
  152.                         # Discovered that Norton Internet Security was adding
  153.                         # HTTP headers of the form
  154.                         #
  155.                         # ~~~~~~~~~~~~~~: ~~~~~~~~~~~~~
  156.                         #
  157.                         # which we were not recognizing as valid (surprise,
  158.                         # surprise) and this was messing about our handling
  159.                         # of POST data.  Changed the end of header identification
  160.                         # to any line that does not contain a :
  161.  
  162.                         last                 if ( $line !~ /:/ );
  163.                     }
  164.  
  165.                     if ( $content_length > 0 ) {
  166.                         $content = $self->slurp_buffer_( $client, $content_length );
  167.                     }
  168.  
  169.                     if ( $request =~ /^(GET|POST) (.*) HTTP\/1\./i ) {
  170.                         $code = $self->handle_url( $client, $2, $1, $content );
  171.                     } else {
  172.                         http_error_( $self, $client, 500 );
  173.                     }
  174.                 }
  175.             }
  176.  
  177.             $self->done_slurp_( $client );
  178.             close $client;
  179.         }
  180.     }
  181.  
  182.     return $code;
  183. }
  184.  
  185. # ---------------------------------------------------------------------------------------------
  186. #
  187. # forked
  188. #
  189. # Called when someone forks POPFile
  190. #
  191. # ---------------------------------------------------------------------------------------------
  192. sub forked
  193. {
  194.     my ( $self ) = @_;
  195.  
  196.     close $self->{server_};
  197. }
  198.  
  199. # ---------------------------------------------------------------------------------------------
  200. #
  201. # handle_url - Handle a URL request
  202. #
  203. # $client     The web browser to send the results to
  204. # $url        URL to process
  205. # $command    The HTTP command used (GET or POST)
  206. # $content    Any non-header data in the HTTP command
  207. #
  208. # ---------------------------------------------------------------------------------------------
  209. sub handle_url
  210. {
  211.     my ( $self, $client, $url, $command, $content ) = @_;
  212.  
  213.     return $self->{url_handler_}( $self, $client, $url, $command, $content );
  214. }
  215.  
  216. # ---------------------------------------------------------------------------------------------
  217. #
  218. # parse_form_    - parse form data and fill in $self->{form_}
  219. #
  220. # $arguments         The text of the form arguments (e.g. foo=bar&baz=fou) or separated by
  221. #                    CR/LF
  222. #
  223. # ---------------------------------------------------------------------------------------------
  224. sub parse_form_
  225. {
  226.     my ( $self, $arguments ) = @_;
  227.  
  228.     # Normally the browser should have done & to & translation on
  229.     # URIs being passed onto us, but there was a report that someone
  230.     # was having a problem with form arguments coming through with
  231.     # something like http://127.0.0.1/history?session=foo&filter=bar
  232.     # which would mess things up in the argument splitter so this code
  233.     # just changes & to & for safety
  234.  
  235.     $arguments =~ s/&/&/g;
  236.  
  237.     while ( $arguments =~ m/\G(.*?)=(.*?)(&|\r|\n|$)/g ) {
  238.         my $arg = $1;
  239.  
  240.         my $need_array = defined( $self->{form_}{$arg} );
  241.  
  242.         if ( $need_array ) {
  243.         if ( $#{ $self->{form_}{$arg . "_array"} } == -1 ) {
  244.                 push( @{ $self->{form_}{$arg . "_array"} }, $self->{form_}{$arg} );
  245.         }
  246.     }
  247.  
  248.         $self->{form_}{$arg} = $2;
  249.         $self->{form_}{$arg} =~ s/\+/ /g;
  250.  
  251.         # Expand hex escapes in the form data
  252.  
  253.         $self->{form_}{$arg} =~ s/%([0-9A-F][0-9A-F])/chr hex $1/gie;
  254.  
  255.         # Push the value onto an array to allow for multiple values of the same name
  256.  
  257.         if ( $need_array ) {
  258.             push( @{ $self->{form_}{$arg . "_array"} }, $self->{form_}{$arg} );
  259.         }
  260.     }
  261. }
  262.  
  263. # ---------------------------------------------------------------------------------------------
  264. #
  265. # url_encode_
  266. #
  267. # $text     Text to encode for URL safety
  268. #
  269. # Encode a URL so that it can be safely passed in a URL as per RFC2396
  270. #
  271. # ---------------------------------------------------------------------------------------------
  272. sub url_encode_
  273. {
  274.     my ( $self, $text ) = @_;
  275.  
  276.     $text =~ s/ /\+/;
  277.     $text =~ s/([^a-zA-Z0-9_\-.\+\'!~*\(\)])/sprintf("%%%02x",ord($1))/eg;
  278.  
  279.     return $text;
  280. }
  281.  
  282. # ---------------------------------------------------------------------------------------------
  283. #
  284. # http_redirect_ - tell the browser to redirect to a url
  285. #
  286. # $client   The web browser to send redirect to
  287. # $url      Where to go
  288. #
  289. # Return a valid HTTP/1.0 header containing a 302 redirect message to the passed in URL
  290. #
  291. # ---------------------------------------------------------------------------------------------
  292. sub http_redirect_
  293. {
  294.     my ( $self, $client, $url ) = @_;
  295.  
  296.     my $header = "HTTP/1.0 302 Found$eol" . 'Location: ';
  297.     $header .= $url;
  298.     $header .= "$eol$eol";
  299.     print $client $header;
  300. }
  301.  
  302. # ---------------------------------------------------------------------------------------------
  303. #
  304. # http_error_ - Output a standard HTTP error message
  305. #
  306. # $client     The web browser to send the results to
  307. # $error      The error number
  308. #
  309. # Return a simple HTTP error message in HTTP 1/0 format
  310. #
  311. # ---------------------------------------------------------------------------------------------
  312. sub http_error_
  313. {
  314.     my ( $self, $client, $error ) = @_;
  315.  
  316.     print $client "HTTP/1.0 $error Error$eol$eol";
  317. }
  318.  
  319. # ---------------------------------------------------------------------------------------------
  320. #
  321. # http_file_ - Read a file from disk and send it to the other end
  322. #
  323. # $client     The web browser to send the results to
  324. # $file       The file to read (always assumed to be a GIF right now)
  325. # $type       Set this to the HTTP return type (e.g. text/html or image/gif)
  326. #
  327. # Returns the contents of a file formatted into an HTTP 200 message or an HTTP 404 if the
  328. # file does not exist
  329. #
  330. # ---------------------------------------------------------------------------------------------
  331. sub http_file_
  332. {
  333.     my ( $self, $client, $file, $type ) = @_;
  334.     my $contents = '';
  335.  
  336.     if ( open FILE, "<$file" ) {
  337.  
  338.         binmode FILE;
  339.         while (<FILE>) {
  340.             $contents .= $_;
  341.         }
  342.         close FILE;
  343.  
  344.         # To prevent the browser for continuously asking for file handled in this way
  345.         # we calculate the current date and time plus 1 hour to give the browser
  346.         # cache 1 hour to keep things like graphics and style sheets in cache.
  347.  
  348.         my @day   = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
  349.         my @month = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
  350.         my $zulu = time;
  351.         $zulu += 60 * 60; # 1 hour
  352.         my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime( $zulu );
  353.  
  354.         my $expires = sprintf( "%s, %02d %s %04d %02d:%02d:%02d GMT",          # PROFILE BLOCK START
  355.                                $day[$wday], $mday, $month[$mon], $year+1900,
  356.                                $hour, 59, 0);                                  # PROFILE BLOCK STOP
  357.  
  358.         my $header = "HTTP/1.0 200 OK$eol" . "Content-Type: $type$eol" . "Expires: $expires$eol" . "Content-Length: ";
  359.         $header .= length($contents);
  360.         $header .= "$eol$eol";
  361.         print $client $header . $contents;
  362.     } else {
  363.         http_error_( $self, $client, 404 );
  364.     }
  365. }
  366.  
  367.  
  368.