Perl Webserver

Di seguito è presentato un piccolo web server, scritto in perl, di circa 150 righe, che può essere scaricato qui.

Questo web server è nato in questa maniera: avevo la necessita' di creare un piccolo script da usare via web. Usare Apache, o qualche altro web server, non mi sembrava il caso, date le piccole dimensioni dello script ( avrei perso piu' tempo a installare e configurare il web server che a riscriverne uno da capo) e dato il fatto che la macchina su cui la cgi avrebbe girato doveva eseguire solo quell' unica pagina.

Inoltre sapevo che in PERL è estremamente facile scrivere questo genere di programmi. Quindi dopo una veloce ricerca per trovare una base da cui partire, ho realizzato un mio web server.

Questo web server supporta solo i metodi GET e POST di HTTP. Inoltre tutte le pagine devono essere poste in /dev/shm/, il che rende il web server piu' veloce (/dev/shm/ è un RAM disk, tutto sommato) e semplice (il caching delle pagine lo fa il sistema operativo), ma richiede di ricopiare le pagine in /dev/shm/ dopo ogni reboot.

Le cgi (o meglio, le subroutine perl), che vanno registrate nel file config_pw.pl, posto nella stessa directory in cui è posto il web server, hanno accesso alle variabili globali:

 
%_POST, %_GET, %_sent_headers, %sent_lines, %_COOKIES

che contengono rispettivamente: le variabili POST, GET, gli header spediti dal browser al server, tutto il testo "grezzo" spedito dal browser, e i cookies spediti dal browser.

Le cgi devono ritornare quello che sara' l'output (settando anche il content type). Per avere un esempio di seguito sono incluse due (pseudo)cgi, prova_get.pl e generic.pl (che permette di lanciare una cgi a "run time", senza cioè la necessita' di rilanciare il server se viene effettuata una modifica ad una cgi).

Di default il server ascolta sulla porta 8080, non c'è quindi bisogno di lanciarlo come root (anzi, ciò è sconsigliato per questioni di sicurezza). questo piccolo server può esservi utile:

Per scopi didattici (anch'io non sono un mago del perl, e questo script mi è stato utile ad imparare molte cose)
Se avete bisogno di un piccolo server, che consumi poche risorse e che, anche se poco duttile, è comunque sufficientemente potente per molte cose
Se avevte bisogno di un server che possa essere lanciato senza praticamente nessuna configurazione: dovete solo ricordarvi di mettere le pagine in /dev/shm/ (ed eventualmente cambiare la porta del server e registrare le cgi in config_pw.pl)
come dimostrazione della potenza di PERL

perl_webserver.pl

#!/usr/bin/perl
# by Claudio Fanelli
# probably it has a lot of bugs ;-)

# based on a work of Graham Ellis ( you can find it at
# http://www.wellho.net/forum/Perl-Programming/HTTP.html )

# LIMITS:
# supports only GET e POST
# all the web pages must be put in /dev/shm/, except the cgi, which need to 
# be put in the same directory of perl_webserver
# it does not fork (one request at a time)

# GLOBAL VARS (for use in CGI):
# %_POST : contains post variables
# %_GET : contains get variables
# %_REQUEST : contains get&post variables
# %_COOKIES : contains cookies variables
# %sent_headers : contains headers sent by the client browser (the names are 
#                 lowercase)
# %sent_lines : contains all the lines sent by the client browser
# client_ipaddr: ip address of the client

# exported functions:
#   HTMLencode()  #encodes a LIST of strings in url format (=%20)

use warnings;
use Socket;
use POSIX ":sys_wait_h";

# read the configuration file
chdir "/usr/local/perl_webserver";
require("config_pw.pl");
foreach my $c (@cgi) {
    require($c);
}
$exec_dir=`pwd`;
chop $exec_dir;
chdir "/dev/shm/";

sub HTMLencode {
    $cont=0;    
    foreach (@_) {
	$stringa=$_;
	$stringa =~ s/([^a-zA-Z0-1])/sprintf("%%%2x",ord($1))/eg;
	$ris[$cont++]=$stringa;
    }
    if(wantarray) {
      return @ris;
    } else {
	return join "",@ris;
    }
}

sub get_vars {
    # this subroutine splits $data in chuncks separated by $separator, 
    # putting that data in $ref_hash (an hash reference)
    # it is used for obtaining GET vars, POST vars and cookies
    $data=shift || return ;
    $ref_hash=shift || return;
    $separator= shift || "&";
    @pezzi = split(/$separator/,$data);
    foreach my $pezzo (@pezzi) {
	($f,$v) = split(/=/,$pezzo,2);
	# trasformiamo i caratteri %hex in caratteri stampabili
	while( $v =~ /%([0-9a-fA-F]{1,2})/ ) {
	    $ris=chr( hex($1) );
	    $v =~ s/%$1/$ris/;
	    pos($v)=0; # per sicurezza facciamo ripartire il match dalla 
	    # posizione 0, visto che abbiamo cambiato la stringa, 
	    # probabilmente e' inutile
	}	
	$v =~ s/\+/ /; # trasformiamo i + in spazi
	$ref_hash->{lc($f)} = $v;
    }
}

# Set up listener
$proto = getprotobyname("tcp");
socket (Server, PF_INET, SOCK_STREAM, $proto) || 
  die ("cannot  create socket");
setsockopt(Server, SOL_SOCKET,SO_REUSEADDR,1) || 
  die ("cannot set setsock options");
$pbind = sockaddr_in($on_port,INADDR_ANY) ||  
  die ("cannot set socket address");
bind(Server,$pbind) || die ("cannot bind");
listen(Server,SOMAXCONN) || die ("cannot listen");
    
# otteniamo i mime types
open(IN,") {
    if (/^#/) {next;}
    ($mime,$exts)=split(/\s+/,$_,2);
    if($exts ne "") {
	@estensioni=split(/\s/,$exts);
	foreach my $estensione (@estensioni) {
	    $mime_types{$estensione}=$mime;
	}
    }
}
close IN;
    
@response = ;
my $out=join "",@response;
# await a contact
while ($client_ipaddr = accept(Client, Server)) {
    if( fork== 0) { # figlio
	while () { # leggiamo l'header http inviato, e mettiamo in 
	    # %sent_headers
	    push @sent_lines,$_;
	    if ($_ =~ /^\s*$/) { 
		last; # l'header termina con una linea vuota
	    }
	    if(/:\s+/) { # poniamo l'elemento attuale in %sent_headers, se non
		# e' la linea col GET o POST
		($f,$v) = split(/:\s+/,$_,2);
		$v=~ s/\n|\r//g;
		$sent_headers{lc($f)} = $v;
	    }
	       
	}
	# guardiamo se ci sono cookie, in caso affermativo settiamo la
	# variabile %_COOKIE
	%_COOKIE=();
	if($sent_headers{"cookie"} ne "" ) {
	    get_vars($sent_headers{"cookie"},\%_COOKIE,";.");
	}
	    
	# se il methodo e' POST, otteniamo il nome del file e le variabili di POST
	%_POST=();
	if ($sent_lines[0] =~ /^POST \/([^? ]+)/) {
	    $file=$1;
	    read(Client,$data,$sent_headers{"content-length"});
	    get_vars($data,\%_POST);
	} 

	# se il methodo e' GET, otteniamo il nome del file e le variabili di GET
	%_GET=();
	if ($sent_lines[0] =~ /^GET \/([^? ]+)(\?([^ ]+))?/) {
	    $get=1;
	    $file=$1;
	    if($3 ne "") {
		get_vars($3,\%_GET);
	    }
	}
	#creiamo REQUEST fondendo i due array. GET prima di post
	%_REQUEST=();
	foreach (keys %_GET) {
	    $_REQUEST{$_}=$_GET{$_};
	}
	foreach (keys %_POST) {
	    $_REQUEST{$_}=$_POST{$_};
	}

	$file=~ s/\.\.\///g; # eliminiamo tutti i ../, per ridurre problemi di
	#  sicurezza ora stabiliamo  se e' una cgi registrata, accessibile sia
	# in post che in get, o una pagina statica, accessibile solo in GET
	if( $file =~/(.*)\.pl$/ && grep(/$file/,@cgi)) {  # stabiliamo se e' 
	    # una cgi registrata
	    $out.=&$1();
	} elsif( $get && -s $file) { # stabiliamo se e' un file da prelevare
	    # in GET
	    $file =~ /\.([a-z0-9]{3,4})$/i;
	    $ext=$1;
	    $mime=$mime_types{$ext};
	    if($mime eq "") {
		$mime="application/octet-stream";
	    }
	    $out.="Content-type: ".$mime."\n";	    
	    if(!open(IN,"<$file") ) {		
		$out="HTTP/1.0 404 Not Found\n\n".
		  "pagina sconosciuta:$file\n";
	    } else {
		$len= -s $file;
		undef $/;
		$letto=;
		close(IN);
		$out.="Content-length: ".$len."\n\n";
		$out.=$letto;
	    }
	} else { # non e' ne' una pagina cgi, ne' un file da prendere in GET
	    $out="HTTP/1.0 404 Not Found\n\npagina sconosciuta:$file\n";
	}
	print Client $out;
	close Client;
	$#sent_lines = -1;
	undef %sent_headers;
	undef %_POST;
	undef %_GET;
	exit(0);
    }
    # liberiamoci degli zombie
    do {
	$kid = waitpid(-1, WNOHANG);
    } until $kid > 0;
    close Client;
}
__END__
HTTP/1.0 200 OK
Date: Sun, 18 Apr 1999 13:59:18 GMT
Server: vulcano 1.0
Expires: Fri, 30 Oct 1998 14:19:41 GMT

config_pw.pl

# listening port
$on_port = 8080; # if port 80 is used, root privileges are needed
# in this array we register the cgi used. Each cgi need:
# to be written in perl
# to be put in the same directory of perl_webserver.pl

@cgi=("prova_get.pl","generic.pl");

prova_get.pl

use Data::Dumper;

sub prova_get() {
    my $out="";
    $out ="Set-Cookie: prova".int(rand(10))."=".int(rand(10000))."\n"; # create a random cookie
    $out.="Content-type: text/html\n\n";
        
    $tmp=Dumper(%sent_headers);
    $out.="<pre>%_GET\n".Dumper(%_GET)."\n\n%_POST\n".Dumper(%_POST)."\n\n%_COOKIE\n".
    Dumper(%_COOKIE)."\n\n%sent_headers\n".$tmp."</pre>";
    $out.="<form method='post' action='prova_get.pl'><input type='submit' name='pippo'".
    " value='invia 123'></form>";
    return $out;
}

1

generic.pl

# IMPORTANT: THIS SCRIPT IS INSECURE,it is only an example !!!!!

# generic cgi for running other scripts the do not need to be reloaded at startup-time
# it can be dangerorus. Note that the scripts loaded must be in /dev/shm.
# it GET the parameter cgi_name that conteins the name of the perl script to
# run

sub generic {
    my $out="";
    
    $name=$_GET{"cgi_name"} || $_POST{"cgi_name"};
    $name=~ s/..\///g; # eliminiamo tutti i ../, per ridurre problemi di sicurezza
    if(! -f $name ) {
        $out="HTTP/1.0 404 Not Found\n\npagina sconosciuta:$name\n";
        return $out;
    } 
    require($name);
    $func_name= $name;
    $func_name =~ s/^.*\///;
    $func_name =~ s/\.pl//;
    $out= &$func_name();
    if( ! ($out =~ /Content-Type:/i)) {
        $out="Content-Type: text/html\n\n".$out;
    }
    return $out;
}
1

Perl Webserver

perl_webserver.pl

config_pw.pl

prova_get.pl

generic.pl

Download