~rjpcasalino/bss

0d2a47a7b89443611a162be05ccaca76a23a84f4 — Ryan 10 months ago 3986312 server
adds basic web server
3 files changed, 129 insertions(+), 114 deletions(-)

A lib/Web.pm
A lib/web_serial.pl
D lib/webserver.pl
A lib/Web.pm => lib/Web.pm +109 -0
@@ 0,0 1,109 @@
package Web;
# Core Web server rounties from
# Chapter 15 of "Network Programming with Perl"
# copyright Linclon D Stein 

use v5.10;

use vars '@ISA', '@EXPORT';
require Exporter;

@ISA = 'Exporter';
@EXPORT = qw(handle_connection docroot);

my $DOCUMENT_ROOT = '/home/rjpc/programs/bss/example/_site';
my $CRLF = "\015\012";

sub handle_connection {
	my $c = shift; #socket
	my ($fh, $type, $length, $url, $method);
	local $/ = "$CRLF$CRLF"; # set end of line character
	my $request = <$c>; # read request header

	return invalid_request($c)
	 unless ($method, $url) = $request =~ m!^(GET|HEAD) (/.*) HTTP/1\.[01]!;
	return not_found($c) unless ($fh, $type, $length) = lookup_file($url);
	return redirect($c, "$url/") if $type eq 'directory';

	# print the header
	print $c "HTTP/1.0 200 OK$CRLF";
	print $c "Content-length: $length$CRLF";
	print $c "Content-type: $type$CRLF";
	print $c $CRLF;

	return unless $method eq 'GET';

	# print the content
	my $buffer;
	while ( read($fh, $buffer, 1024) ) {
		print $c $buffer;
	}
	close $fh;
}

sub lookup_file {
	my $url = shift;
	my $path = $DOCUMENT_ROOT . $url; # turn into path
	$path =~ s/\?.*$//; # ger rid of query
	$path =~ s/\#.*$//; # get rid of fragment
	$path .= 'index.html' if $url =~ m!/$!; # get index.html if path ends in /
	return if $path =~ m!/\.\\./!; # don't allow relative paths (..)
	return (undef, 'directory', undef) if -d $path; # oops! a directory
	my $type = 'text/plain'; # default MIME type
	$type = 'text/html' if $path =~ /\.html?$/i; # HTML file?
	$type = 'text/gif' if $path =~ /\.gif?$/i; # gif file?
	$type = 'text/jpeg' if $path =~ /\.jpe?g$/i; # jpg file?
	return unless my $length = (stat(_))[7]; # file size
	return unless my $fh = IO::File->new($path, "<"); # try to open file
}

sub redirect {
	my ($c, $url) = @_;
	my $hots = $c->sockhost;
	my $port = $c->sockport;
	my $moved_to = "http://$host:$port$url";
	print $c "HTTP/1.0 301 Moved permanently$CRLF";
	print $c "Location: $moved_to$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<HTML>
<HEAD><TITLE>301 Moved</TITLE></HEAD>
<BODY><H1>MOVED</H1>
<p> The requested document has moved <a href="$moved_to">here</a>.<.p>
</BODY>
</HTML>
END
}

sub invalid_request {
	my $c = shift;
	print $c "HTTP/1.0 400 Bad Request$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<HTML>
<HEAD><TITLE>400 Bad Request</TITLE></HEAD>
<BODY><H1>Bad Request</H1>
</BODY>
</HTML>
END
}

sub not_found {
	my $c = shift;
	print $c "HTTP/1.0 404 Not Found$CRLF";
	print $c "Content-type: text/html$CRLF$CRLF";
	print $c <<END;
<HTML>
<HEAD><TITLE>404 Not Found</TITLE></HEAD>
<BODY><H1>404 Not Found</H1>
</BODY>
</HTML>
END
}

sub docroot {
	$DOCUMENT_ROOT = shift if @_;
	return $DOCUMENT_ROOT;
}

1; # perl programs end this way :-) 

A lib/web_serial.pl => lib/web_serial.pl +20 -0
@@ 0,0 1,20 @@
#!/usr/bin/env perl

use v5.10;

use lib './lib';
use IO::Socket;
use Web;

my $port = shift || 1987;
my $socket = IO::Socket::INET->new( LocalPort => $port,
				    Listen => SOMAXCONN,
			    	    Reuse => 1 )
			    	    or die "Can't create listen socket: $!";

say "Started local web server on $port!";
while (my $c = $socket->accept) {
	handle_connection($c);
	close $c;
}
close $socket;

D lib/webserver.pl => lib/webserver.pl +0 -114
@@ 1,114 0,0 @@
#!/usr/bin/env perl

use strict;
use warnings; 

use HTTP::Server::Simple::CGI;

{ package WebServer; use base 'HTTP::Server::Simple::CGI';

use File::Slurp; # import read_file

my $nl = "\x0d\x0a";

my $root = '.';
if (@ARGV) {
  $root = shift;
}
chdir($root);

sub print_header { # {{{

    my $content_type = shift;

    print "HTTP/1.0 200 OK$nl";
    print "Content-Type: $content_type; charset=utf-8$nl$nl";

} # }}}


sub print_400 {
    my $content_type = shift;

    print "HTTP/1.0 400 BAD REQUEST$nl";
    print "Content-Type: $content_type; charset=utf-8$nl$nl";

}

sub serve_file { # {{{

    my $path_relative = shift;
    my $content_type  = shift;

    print_header($content_type);

    print STDOUT "serve_file: $path_relative\n";

    if (-e $path_relative) {
       print read_file($path_relative, binmode => ":raw");
    } else {
       print "file $path_relative not found"; 
    }


} # }}}

sub handle_request {

    my $self = shift;
    my $cgi  = shift;

    my $path = $cgi -> path_info;

    if ($path eq '/') {
      if (-e 'index.html') {
        serve_file ("index.html", 'text/html');
      }
      else {
	print join "\n", glob('*');
      }
      return;
    }

  #  See http://de.selfhtml.org/diverses/mimetypen.htm for Mime Types.

    if ($path =~ /\.htm$/  or $path =~ /\.html$/) {
      serve_file (".$path", 'text/html');
      return;
    }
    if ($path =~ /\.js$/ ) {
      serve_file (".$path", 'application/javascript');
      return;
    }
    if ($path =~ /\.txt$/) {
      serve_file (".$path", 'text/plain');
      return;
    }
    if ($path =~ /\.js$/ ) {
      serve_file (".$path", 'application/javascript');
      return;
    }
    if ($path =~ /\.png$/) {
      serve_file (".$path", 'image/png');
      return;
    }
    if ($path =~ /\.jpg$/ or $path =~ /\.jpeg/) {
      serve_file (".$path", 'image/jpeg');
      return;
    }
    if ($path =~ /\.ico$/) {
      serve_file (".$path", 'image/x-icon');
      return;
    }

    print STDERR "Unknown Mime type for $path\n";
    print_400("text/html");
    return;
}


}

# Use Port 8080 (http://localhost:8080)
my $pid = WebServer -> new(8080) -> background;
print "pid of webserver=$pid\n";