home *** CD-ROM | disk | FTP | other *** search
/ PC Open 101 / PC Open 101 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / UI / HTTP.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-03  |  12.7 KB  |  396 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-2004 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
  123.     # accept it handle a single request and then exit
  124.  
  125.     my ( $ready ) = $self->{selector_}->can_read(0);
  126.  
  127.     # Handle HTTP requests for the UI
  128.  
  129.     if ( ( defined( $ready ) ) && ( $ready == $self->{server_} ) ) {
  130.  
  131.         if ( my $client = $self->{server_}->accept() ) {
  132.  
  133.             # Check that this is a connection from the local machine,
  134.             # if it's not then we drop it immediately without any
  135.             # further processing.  We don't want to allow remote users
  136.             # to admin POPFile
  137.  
  138.             my ( $remote_port, $remote_host ) = sockaddr_in( $client->peername() );
  139.  
  140.             if ( ( $self->config_( 'local' ) == 0 ) ||                # PROFILE BLOCK START
  141.                  ( $remote_host eq inet_aton( "127.0.0.1" ) ) ) {     # PROFILE BLOCK STOP
  142.  
  143.                 # Read the request line (GET or POST) from the client
  144.                 # and if we manage to do that then read the rest of
  145.                 # the HTTP headers grabbing the Content-Length and
  146.                 # using it to read any form POST content into $content
  147.  
  148.                 $client->autoflush(1);
  149.  
  150.                 if ( ( defined( $client ) ) &&
  151.                      ( my $request = $self->slurp_( $client ) ) ) {
  152.                     my $content_length = 0;
  153.                     my $content;
  154.  
  155.                     $self->log_( 2, $request );
  156.  
  157.                     while ( my $line = $self->slurp_( $client ) )  {
  158.                         $content_length = $1 if ( $line =~ /Content-Length: (\d+)/i );
  159.  
  160.                         # Discovered that Norton Internet Security was
  161.                         # adding HTTP headers of the form
  162.                         #
  163.                         # ~~~~~~~~~~~~~~: ~~~~~~~~~~~~~
  164.                         #
  165.                         # which we were not recognizing as valid
  166.                         # (surprise, surprise) and this was messing
  167.                         # about our handling of POST data.  Changed
  168.                         # the end of header identification to any line
  169.                         # that does not contain a :
  170.  
  171.                         last                 if ( $line !~ /:/ );
  172.                     }
  173.  
  174.                     if ( $content_length > 0 ) {
  175.                         $content = $self->slurp_buffer_( $client,
  176.                             $content_length );
  177.                         $self->log_( 2, $content );
  178.                     }
  179.  
  180.                     if ( $request =~ /^(GET|POST) (.*) HTTP\/1\./i ) {
  181.                         $code = $self->handle_url( $client, $2, $1, $content );
  182.                         $self->log_( 2,
  183.                             "HTTP handle_url returned code $code\n" );
  184.                     } else {
  185.                         $self->http_error_( $client, 500 );
  186.                     }
  187.                 }
  188.             }
  189.  
  190.             $self->log_( 2, "Close HTTP connection on $client\n" );
  191.             $self->done_slurp_( $client );
  192.             close $client;
  193.         }
  194.     }
  195.  
  196.     return $code;
  197. }
  198.  
  199. # ---------------------------------------------------------------------------------------------
  200. #
  201. # forked
  202. #
  203. # Called when someone forks POPFile
  204. #
  205. # ---------------------------------------------------------------------------------------------
  206. sub forked
  207. {
  208.     my ( $self ) = @_;
  209.  
  210.     close $self->{server_};
  211. }
  212.  
  213. # ---------------------------------------------------------------------------------------------
  214. #
  215. # handle_url - Handle a URL request
  216. #
  217. # $client     The web browser to send the results to
  218. # $url        URL to process
  219. # $command    The HTTP command used (GET or POST)
  220. # $content    Any non-header data in the HTTP command
  221. #
  222. # ---------------------------------------------------------------------------------------------
  223. sub handle_url
  224. {
  225.     my ( $self, $client, $url, $command, $content ) = @_;
  226.  
  227.     return $self->{url_handler_}( $self, $client, $url, $command, $content );
  228. }
  229.  
  230. # ---------------------------------------------------------------------------------------------
  231. #
  232. # parse_form_    - parse form data and fill in $self->{form_}
  233. #
  234. # $arguments         The text of the form arguments (e.g. foo=bar&baz=fou) or separated by
  235. #                    CR/LF
  236. #
  237. # ---------------------------------------------------------------------------------------------
  238. sub parse_form_
  239. {
  240.     my ( $self, $arguments ) = @_;
  241.  
  242.     # Normally the browser should have done & to & translation on
  243.     # URIs being passed onto us, but there was a report that someone
  244.     # was having a problem with form arguments coming through with
  245.     # something like http://127.0.0.1/history?session=foo&filter=bar
  246.     # which would mess things up in the argument splitter so this code
  247.     # just changes & to & for safety
  248.  
  249.     $arguments =~ s/&/&/g;
  250.  
  251.     while ( $arguments =~ m/\G(.*?)=(.*?)(&|\r|\n|$)/g ) {
  252.         my $arg = $1;
  253.  
  254.         my $need_array = defined( $self->{form_}{$arg} );
  255.  
  256.         if ( $need_array ) {
  257.         if ( $#{ $self->{form_}{$arg . "_array"} } == -1 ) {
  258.                 push( @{ $self->{form_}{$arg . "_array"} }, $self->{form_}{$arg} );
  259.         }
  260.     }
  261.  
  262.         $self->{form_}{$arg} = $2;
  263.         $self->{form_}{$arg} =~ s/\+/ /g;
  264.  
  265.         # Expand hex escapes in the form data
  266.  
  267.         $self->{form_}{$arg} =~ s/%([0-9A-F][0-9A-F])/chr hex $1/gie;
  268.  
  269.         # Push the value onto an array to allow for multiple values of
  270.         # the same name
  271.  
  272.         if ( $need_array ) {
  273.             push( @{ $self->{form_}{$arg . "_array"} }, $self->{form_}{$arg} );
  274.         }
  275.     }
  276. }
  277.  
  278. # ---------------------------------------------------------------------------------------------
  279. #
  280. # url_encode_
  281. #
  282. # $text     Text to encode for URL safety
  283. #
  284. # Encode a URL so that it can be safely passed in a URL as per RFC2396
  285. #
  286. # ---------------------------------------------------------------------------------------------
  287. sub url_encode_
  288. {
  289.     my ( $self, $text ) = @_;
  290.  
  291.     $text =~ s/ /\+/;
  292.     $text =~ s/([^a-zA-Z0-9_\-.\+\'!~*\(\)])/sprintf("%%%02x",ord($1))/eg;
  293.  
  294.     return $text;
  295. }
  296.  
  297. # ---------------------------------------------------------------------------------------------
  298. #
  299. # http_redirect_ - tell the browser to redirect to a url
  300. #
  301. # $client   The web browser to send redirect to
  302. # $url      Where to go
  303. #
  304. # Return a valid HTTP/1.0 header containing a 302 redirect message to the passed in URL
  305. #
  306. # ---------------------------------------------------------------------------------------------
  307. sub http_redirect_
  308. {
  309.     my ( $self, $client, $url ) = @_;
  310.  
  311.     my $header = "HTTP/1.0 302 Found$eol" . 'Location: ';
  312.     $header .= $url;
  313.     $header .= "$eol$eol";
  314.     print $client $header;
  315. }
  316.  
  317. # ---------------------------------------------------------------------------------------------
  318. #
  319. # http_error_ - Output a standard HTTP error message
  320. #
  321. # $client     The web browser to send the results to
  322. # $error      The error number
  323. #
  324. # Return a simple HTTP error message in HTTP 1/0 format
  325. #
  326. # ---------------------------------------------------------------------------------------------
  327. sub http_error_
  328. {
  329.     my ( $self, $client, $error ) = @_;
  330.  
  331.     $self->log_( 0, "HTTP error $error returned" );
  332.  
  333.     print $client "HTTP/1.0 $error Error$eol$eol";
  334. }
  335.  
  336. # ---------------------------------------------------------------------------------------------
  337. #
  338. # http_file_ - Read a file from disk and send it to the other end
  339. #
  340. # $client     The web browser to send the results to
  341. # $file       The file to read (always assumed to be a GIF right now)
  342. # $type       Set this to the HTTP return type (e.g. text/html or image/gif)
  343. #
  344. # Returns the contents of a file formatted into an HTTP 200 message or an HTTP 404 if the
  345. # file does not exist
  346. #
  347. # ---------------------------------------------------------------------------------------------
  348. sub http_file_
  349. {
  350.     my ( $self, $client, $file, $type ) = @_;
  351.     my $contents = '';
  352.  
  353.     if ( defined( $file ) && ( open FILE, "<$file" ) ) {
  354.  
  355.         binmode FILE;
  356.         while (<FILE>) {
  357.             $contents .= $_;
  358.         }
  359.         close FILE;
  360.  
  361.         # To prevent the browser for continuously asking for file
  362.         # handled in this way we calculate the current date and time
  363.         # plus 1 hour to give the browser cache 1 hour to keep things
  364.         # like graphics and style sheets in cache.
  365.  
  366.         my @day   = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );
  367.         my @month = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
  368.         my $zulu = time;
  369.         $zulu += 60 * 60; # 1 hour
  370.         my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime( $zulu );
  371.  
  372.         my $expires = sprintf( "%s, %02d %s %04d %02d:%02d:%02d GMT",          # PROFILE BLOCK START
  373.                                $day[$wday], $mday, $month[$mon], $year+1900,
  374.                                $hour, 59, 0);                                  # PROFILE BLOCK STOP
  375.  
  376.         my $header = "HTTP/1.0 200 OK$eol" . "Content-Type: $type$eol" . "Expires: $expires$eol" . "Content-Length: ";
  377.         $header .= length($contents);
  378.         $header .= "$eol$eol";
  379.         print $client $header . $contents;
  380.     } else {
  381.         http_error_( $self, $client, 404 );
  382.     }
  383. }
  384.  
  385. sub history
  386. {
  387.     my ( $self, $value ) = @_;
  388.  
  389.     if ( defined( $value ) ) {
  390.         $self->{history__} = $value;
  391.     }
  392.  
  393.     return $self->{history__};
  394. }
  395.  
  396.