|
Автор: Lincoln Stein
O'Reilly Perl Conference,
August 17-20, 1998, San Jose.
Логи на веб-сервере могут расти как на дрожжах и пожирать ресурсы.
Но не торопитесь удалять их . Логи - наши друзья.
Скрипт
I.1.1 показывает пример ротации лог-файлов .
Он переименовывает текущий ``access_log'' в ``access_log.0'', ``access_log.0''
в ``access_log.1'', и т.д. самый старый удаляется. Запускайте его из-под крона.
---------------- Script
I.1.1: Basic Log File Rotation ----------
#!/usr/local/bin/perl
$LOGPATH='/usr/local/apache/logs';
@LOGNAMES=('access_log','error_log','referer_log','agent_log');
$PIDFILE = 'httpd.pid';
$MAXCYCLE = 4;
chdir $LOGPATH; # Change to the log directory
foreach $filename (@LOGNAMES) {
for (my $s=$MAXCYCLE; $s--; $s >= 0 ) {
$oldname = $s ? "$filename.$s" : $filename;
$newname = join(".",$filename,$s+1);
rename $oldname,$newname if -e $oldname;
}
}
kill 'HUP',`cat $PIDFILE`;
-----------------------------------------------------------------
Некоторые не хотят ничего удалять.
Скрипт I.1.2 добавляет старейщий лог в zip-архив.
---------- Script
I.1.2: Log File Rotation and Archiving ---------
#!/usr/local/bin/perl
$LOGPATH = '/usr/local/apache/logs';
$PIDFILE = 'httpd.pid';
$MAXCYCLE = 4;
$GZIP = '/bin/gzip';
@LOGNAMES=('access_log','error_log','referer_log','agent_log');
%ARCHIVE=('access_log'=>1,'error_log'=>1);
chdir $LOGPATH; # Change to the log directory
foreach $filename (@LOGNAMES) {
system "$GZIP -c $filename.$MAXCYCLE >> $filename.gz"
if -e "$filename.$MAXCYCLE" and $ARCHIVE{$filename};
for (my $s=$MAXCYCLE; $s--; $s >= 0 ) {
$oldname = $s ? "$filename.$s" : $filename;
$newname = join(".",$filename,$s+1);
rename $oldname,$newname if -e $oldname;
}
}
kill 'HUP',`cat $PIDFILE`;
-----------------------------------------------------------------
Скрипт I.1.3 использует idea (часть пакета SSLEay )
для криптования логов перед компрессией для предотвращения доступа к ним .
Для этого нужен архиватор tar.
---------- Script
I.1.3: Log File Rotation and Encryption ---------
#!/usr/local/bin/perl
use POSIX 'strftime';
$LOGPATH = '/home/www/logs';
$PIDFILE = 'httpd.pid';
$MAXCYCLE = 4;
$IDEA = '/usr/local/ssl/bin/idea';
$GZIP = '/bin/gzip';
$TAR = '/bin/tar';
$PASSWDFILE = '/home/www/logs/secret.passwd';
@LOGNAMES=('access_log','error_log','referer_log','agent_log');
%ARCHIVE=('access_log'=>1,'error_log'=>1);
chdir $LOGPATH; # Change to the log directory
foreach $filename (@LOGNAMES) {
my $oldest = "$filename.$MAXCYCLE";
archive($oldest) if -e $oldest and $ARCHIVE{$filename};
for (my $s=$MAXCYCLE; $s--; $s >= 0 ) {
$oldname = $s ? "$filename.$s" : $filename;
$newname = join(".",$filename,$s+1);
rename $oldname,$newname if -e $oldname;
}
}
kill 'HUP',`cat $PIDFILE`;
sub archive {
my $f = shift;
my $base = $f;
$base =~ s/\.\d+$//;
my $fn = strftime("$base.%Y-%m-%d_%H:%M.gz.idea",localtime);
system "$GZIP -9 -c $f | $IDEA -kfile $PASSWDFILE > $fn";
system "$TAR rvf $base.tar --remove-files $fn";
}
-----------------------------------------------------------------
Скрипт I.1.4 показывает организацию доступа к логу с помощью регулярных выражений :
portio.cshl.org - - [03/Feb/1998:17:42:15 -0500]
``GET /pictures/small_logo.gif
HTTP/1.0'' 200 2172
------------- Script
I.1.4: Basic Log Parsing -------------
#!/usr/local/bin/perl
$REGEX=/^(\S+) (\S+) (\S+) \[([^]]+)\] "(\w+) (\S+).*" (\d+) (\S+)/;
while (<>) {
($host,$rfc931,$user,$date,$request,$URL,$status,$bytes) = m/$REGEX/o;
&collect_some_statistics;
}
&print_some_statistics;
sub collect_some_statistics {
# for you to fill in
}
sub print_some_statistics {
# for you to fill in
}
-----------------------------------------------------------
Скрипт I.1.5 сканирует лог на предмет статус-кодов и печатает урлы.
find_status.pl -t10 200 ~www/logs/access_log
TOP 10 URLS/HOSTS WITH STATUS CODE 200:
REQUESTS URL/HOST
-------- --------
1845 /www/wilogo.gif
1597 /cgi-bin/contig/sts_by_name?database=release
1582 /WWW/faqs/www-security-faq.html
1263 /icons/caution.xbm
930 /
886 /ftp/pub/software/WWW/cgi_docs.html
773 /cgi-bin/contig/phys_map
713 /icons/dna.gif
686 /WWW/pics/small_awlogo.gif
---------- Script I.1.5: Find frequent status codes ---------
#!/usr/local/bin/perl
# File: find_status.pl
require "getopts.pl";
&Getopts('L:t:h') || die <<USAGE;
Usage: find_status.pl [-Lth] <code1> <code2> <code3> ...
Scan Web server log files and list a summary
of URLs whose requests had the one of the
indicated status codes.
Options:
-L <domain> Ignore local hosts matching this domain
-t <integer> Print top integer URLS/HOSTS [10]
-h Sort by host rather than URL
USAGE
;
if ($opt_L) {
$opt_L=~s/\./\\./g;
$IGNORE = "(^[^.]+|$opt_L)\$";
}
$TOP=$opt_t || 10;
while (@ARGV) {
last unless $ARGV[0]=~/^\d+$/;
$CODES{shift @ARGV}++;
}
while (<>) {
($host,$rfc931,$user,$date,$request,$URL,$status,$bytes) =
/^(\S+) (\S+) (\S+) \[([^]]+)\] "(\w+) (\S+).*" (\d+) (\S+)/;
next unless $CODES{$status};
next if $IGNORE && $host=~/$IGNORE/io;
$info = $opt_h ? $host : $URL;
$found{$status}->{$info}++;
}
foreach $status (sort {$a<=>$b;} sort keys %CODES) {
$info = $found{$status};
$count = $TOP;
foreach $i (sort {$info->{$b} <=> $info->{$a};} keys %{$info}) {
write;
last unless --$count;
}
$- = 0; # force a new top-of-report
}
format STDOUT_TOP=
TOP @## URLS/HOSTS WITH STATUS CODE @##:
$TOP, $status
REQUESTS URL/HOST
-------- --------
.
format STDOUT=
@##### @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$info->{$i},$i
.
-----------------------------------------------------------
В лог-файл включается ip-адреса , с которых пришел запрос.
Скрипт I.1.6 делает перевод ip в DNS-имена .
Скрипт поддерживает кэширование DNS. Если ip-шник не резолвится через 2 секунды,
больше мы к этому не возвращаемся.
----------- Script
I.1.6: Reverse
DNS Resolution -----------
#!/usr/local/bin/perl
use constant TIMEOUT => 2;
$SIG{ALRM} = sub {die "timeout"};
while (<>) {
s/^(\S+)/lookup($1)/e;
} continue {
print;
}
sub lookup {
my $ip = shift;
return $ip unless $ip=~/\d+\.\d+\.\d+\.\d+/;
return $CACHE{$ip} if exists $CACHE{$ip};
my @h = eval <<'END';
alarm(TIMEOUT);
my @i = gethostbyaddr(pack('C4',split('\.',$ip)),2);
alarm(0);
@i;
END
$CACHE{$ip} = $h[0];
return $CACHE{$ip} || $ip;
}
-------------------------------------------------------
Скрипт I.1.7 работает следующим образом :
1. Мы заранее оговариваемся , что любой внешний запрос, который
в течение 30 минут не меняет свой ip-шник и хидер "user agent" -
это в общем одно и то же лицо (или робот)
2. если вы фетчите /robots.txt - вы робот
3. Мы считаем общее число запросов
4. Считаем интервалы между запросами
5.Подсчитываем число запросов в единицу времени.У роботов оно выше,чем у людей
6. Все выводим в таблицу
Отсюда можно сделать о вывод о наличии "плохих" роботов.
------------------------- Script
I.1.7: Robo-Cop ----------------------
#!/usr/local/bin/perl
use Time::ParseDate;
use strict 'vars';
# after 30 minutes, we consider this a new session
use constant MAX_INTERVAL => 60*30;
my (%HITS,%INT_NUMERATOR,%INT_DENOMINATOR,%POLITE,%LAST,$HITS);
# This uses a non-standard agent log with lines formatted like this:
my $file = shift;
open(IN,$file=~/\.gz$/ ? "zcat $file|":$file)||die "Can't open file/pipe: $!";
while (<IN>) {
my($date,$host,$agent,$URL) = /^\[(.+)\] (\S+) "(.*)" (\S+)$/;
next unless $URL=~/\.(html|htm|txt)$/;
$HITS++;
$host = "$host:$agent"; # concatenate host and agent
$HITS{$host}++;
my $seconds = parsedate($date);
if ($LAST{$host}) {
my $interval = $seconds - $LAST{$host};
if ($interval < MAX_INTERVAL) {
$INT_NUMERATOR{$host} += $interval;
$INT_DENOMINATOR{$host}++;
}
}
$LAST{$host} = $seconds;
$POLITE{$host}++ if $URL eq '/robots.txt';
print STDERR $HITS,"\n" if ($HITS % 1000) == 0;
}
# print out, sorted by hits
print join("\t",qw/Client Robot Hits Interval Hit_Percent Index/),"\n";
foreach (sort {$HITS{$b}<=>$HITS{$a}} keys %HITS) {
next unless $HITS{$_} >= 5; # not enough total hits to mean much
next unless $INT_DENOMINATOR{$_} >= 5;#not enough consecutive hits to mean much
my $mean_interval = $INT_NUMERATOR{$_}/$INT_DENOMINATOR{$_};
my $percent_hits = 100*($HITS{$_}/$HITS);
my $index = $percent_hits/$mean_interval;
print join("\t",
$_,
$POLITE{$_} ? 'yes' : 'no',
$HITS{$_},
$mean_interval,
$percent_hits,
$index
),"\n";
}
-----------------------------------------------------------------
Если у вас большой кластерный сайт с разнесенными серверами , то у вас может возникнуть
проблема с логами , которые разнесены , и которые надо сводить .
Апач позволяет выводить лог не только в файл , но и в процесс (перловый скрипт).
С помощью Syslog-модуля , написанного Tom Christiansen's , можно посылать информацию
на удаленный syslog daemon.
В конфиге апача пишем следующее :
<VirtualHost www.company2.com>
CustomLog "| /usr/local/apache/bin/logger company2" common
# blah blah
</VirtualHost>
Если центральный хост называется ``loghost'' , то в syslog.con у других веб-серверов пишем:
local0.info @loghost
У центрального веб-сервера пишем в syslog.conf:
local0.info /var/log/web/access_log
Скрипт I.1.8 показывает код для ``logger'' программы:
------------------- Script
I.1.8 ``logger'' ------------------
#!/usr/local/bin/perl
# script: logger
use Sys::Syslog;
$SERVER_NAME = shift || 'www';
$FACILITY = 'local0';
$PRIORITY = 'info';
Sys::Syslog::setlogsock('unix');
openlog ($SERVER_NAME,'ndelay',$FACILITY);
while (<>) {
chomp;
syslog($PRIORITY,$_);
}
closelog;
-------------------------------------------------------------
Веб-сайты могут стать неустойчивыми , если в их поддержке участвует большое число
разработчиков.Скрипты в этой секции наблюдают за сервером и посылают e-mail в случае проблемы.
Следующий скрипт проверяет основной серверный процесс и посылает SOS в случае аварии .
Запускается под рутом .
------------------------
I.2.1 ``localSOS'' --------------------
#!/usr/local/bin/perl
# script: localSOS
use constant PIDFILE => '/usr/local/apache/var/run/httpd.pid';
$MAIL = '/usr/sbin/sendmail';
$MAIL_FLAGS = '-t -oi';
$WEBMASTER = 'webmaster';
open (PID,PIDFILE) || die PIDFILE,": $!\n";
$pid = <PID>; close PID;
kill 0,$pid || sos();
sub sos {
open (MAIL,"| $MAIL $MAIL_FLAGS") || die "mail: $!";
my $date = localtime();
print MAIL <<END;
To: $WEBMASTER
From: The Watchful Web Server Monitor <nobody>
Subject: Web server is down
I tried to call the Web server at $date but there was
no answer.
Respectfully yours,
The Watchful Web Server Monitor
END
close MAIL;
}
--------------------------------------------------------------
Скрипт I.2.2 использует LWP библиотеку
для посылки HEAD-запроса .
Запускается без привилегий .
------------------------
I.2.2 ``remoteSOS'' --------------------
#!/usr/local/bin/perl
# script: remoteSOS
use LWP::Simple;
%SERVERS = (
"Fred's server" => 'http://www.fred.com',
"Martha's server" => 'http://www.stewart-living.com',
"Bill's server" => 'http://www.whitehouse.gov'
);
$MAIL = '/usr/sbin/sendmail';
$MAIL_FLAGS = '-t -oi';
$WEBMASTER = 'webmaster';
foreach (sort keys %SERVERS) {
sos($_) unless head($SERVERS{$_});
}
sub sos {
my $server = shift;
open (MAIL,"| $MAIL $MAIL_FLAGS") || die "mail: $!";
my $date = localtime();
print MAIL <<END;
To: $WEBMASTER
From: The Watchful Web Server Monitor <nobody>
Subject: $server is down
I tried to call $server at $date but there was
no one at home.
Respectfully yours,
The Watchful Web Server Monitor
END
close MAIL;
}
--------------------------------------------------------------
Скрипт I.2.3 пытается перезапустить сервер .
Запускается под рутом .
------------------------ I.2.2 "webLazarus" --------------------
#!/usr/local/bin/perl
# script: webLazarus
use LWP::Simple;
use constant URL => 'http://presto.capricorn.com/';
use constant APACHECTL => '/usr/local/apache/bin/apachectl';
$MAIL = '/usr/sbin/sendmail';
$MAIL_FLAGS = '-t -oi';
$WEBMASTER = 'lstein@prego.capricorn.com';
head(URL) || resurrect();
sub resurrect {
open (STDOUT,"| $MAIL $MAIL_FLAGS") || die "mail: $!";
select STDOUT; $| = 1;
open (STDERR,">&STDOUT");
my $date = localtime();
print <<END;
To: $WEBMASTER
From: The Watchful Web Server Monitor <nobody>
Subject: Web server is down
I tried to call the Web server at $date but there was
no answer. I am going to try to resurrect it now:
Mumble, mumble, mumble, shazzzzammmm!
END
;
system APACHECTL,'restart';
print <<END;
That's the best I could do. Hope it helped.
Worshipfully yours,
The Web Monitor
END
close STDERR;
close STDOUT;
}
--------------------------------------------------------------
Сообщение , которое может быть получено от скрипта :
Date: Sat, 4 Jul 1998 14:55:38 -0400
To: lstein@prego.capricorn.com
Subject: Web server is down
I tried to call the Web server at Sat Jul 4 14:55:37 1998 but there was
no answer. I am going to try to resurrect it now:
Mumble, mumble, mumble, shazzzzammmm!
/usr/local/apache/bin/apachectl restart: httpd not running, trying to start
[Sat Jul 4 14:55:38 1998] [debug] mod_so.c(258): loaded module setenvif_module
[Sat Jul 4 14:55:38 1998] [debug] mod_so.c(258): loaded module unique_id_module
/usr/local/apache/bin/apachectl restart: httpd started
That's the best I could do. Hope it helped.
Worshipfully yours,
The Web Monitor
Для того чтобы иметь зеркало на страницу другого сайта , можно использовать
библиотеку LWP .
% ./MirrorOne.pl
cats.html: Not Modified
dogs.html: OK
gillie_fish.html: Not Modified
----------------------Script
I.3.1 mirrorOne.pl--------------------
#!/usr/local/bin/perl
# mirrorOne.pl
use LWP::Simple;
use HTTP::Status;
use constant DIRECTORY => '/local/web/price_lists';
%DOCUMENTS = (
'dogs.html' => 'http://www.pets.com/dogs/price_list.html',
'cats.html' => 'http://www.pets.com/cats/price_list.html',
'gillie_fish.html' => 'http://aquaria.com/prices.html'
);
chdir DIRECTORY;
foreach (sort keys %DOCUMENTS) {
my $status = mirror($DOCUMENTS{$_},$_);
warn "$_: ",status_message($status),"\n";
}
-------------------------------------------------------------------
С помощью рекурсии это можно сделать и для дерева документов .
Скрипт I.3.2 делает зеркало с помощью модуля
LWP HTML::LinkExtor для получения
HTML links.
----------------------Script
I.3.2 mirrorTree.pl--------------------
#!/usr/local/bin/perl
# File: mirrorTree.pl
use LWP::UserAgent;
use HTML::LinkExtor;
use URI::URL;
use File::Path;
use File::Basename;
%DONE = ();
my $URL = shift;
$UA = new LWP::UserAgent;
$PARSER = HTML::LinkExtor->new();
$TOP = $UA->request(HTTP::Request->new(HEAD => $URL));
$BASE = $TOP->base;
mirror(URI::URL->new($TOP->request->url));
sub mirror {
my $url = shift;
# get rid of query string "?" and fragments "#"
my $path = $url->path;
my $fixed_url = URI::URL->new ($url->scheme . '://' . $url->netloc . $path);
# make the URL relative
my $rel = $fixed_url->rel($BASE);
$rel .= 'index.html' if $rel=~m!/$! || length($rel) == 0;
# skip it if we've already done it
return if $DONE{$rel}++;
# create the directory if it doesn't exist already
my $dir = dirname($rel);
mkpath([$dir]) unless -d $dir;
# mirror the document
my $doc = $UA->mirror($fixed_url,$rel);
print STDERR "$rel: ",$doc->message,"\n";
return if $doc->is_error;
# Follow HTML documents
return unless $rel=~/\.html?$/i;
my $base = $doc->base;
# pull out the links and call us recursively
my @links = $PARSER->parse_file("$rel")->links;
my @hrefs = map { url($_->[2],$base)->abs } @links;
foreach (@hrefs) {
next unless is_child($BASE,$_);
mirror($_);
}
}
sub is_child {
my ($base,$url) = @_;
my $rel = $url->rel($base);
return ($rel ne $url) && ($rel !~ m!^[/.]!);
}
--------------------------------------------------------------
Скрипт I.3.3 проверяет документ на предмет плохих
http:, ftp: и gopher: линков .
% find_bad_links http://prego/apache-1.2/
checking http://prego/apache-1.2/...
checking http://prego/apache-1.2/manual/...
checking http://prego/apache-1.2/manual/misc/footer.html...
checking http://prego/apache-1.2/manual/misc/header.html...
checking http://prego/apache-1.2/manual/misc/nopgp.html...
checking http://www.yahoo.com/Science/Mathematics/Security_and_Encryption/...
checking http://www.eff.org/pub/EFF/Policy/Crypto/...
checking http://www.quadralay.com/www/Crypt/Crypt.html...
checking http://www.law.indiana.edu/law/iclu.html...
checking http://bong.com/~brian...
checking http://prego/apache-1.2/manual/cgi_path.html...
checking http://www.ics.uci.edu/pub/ietf/http/...
.
.
.
BAD LINKS:
manual/misc/known_bugs.html : http://www.apache.org/dist/patches/apply_to_1.2b6/
manual/misc/fin_wait_2.html : http://www.freebsd.org/
manual/misc/fin_wait_2.html : http://www.ncr.com/
manual/misc/compat_notes.html : http://www.eit.com/
manual/misc/howto.html : http://www.zyzzyva.com/robots/alert/
manual/misc/perf.html : http://www.software.hp.com/internet/perf/tuning.html
manual/misc/perf.html : http://www.qosina.com/~awm/apache/linux-tcp.html
152 documents checked
11 bad links
----------------------Script
I.3.3 mirrorTree.pl--------------------
#!/usr/local/bin/perl
# File: find_bad_links.pl
use LWP::UserAgent;
use HTML::LinkExtor;
use URI::URL;
%CAN_HANDLE = ('http'=>1,
'gopher'=>1,
# 'ftp'=>1, # timeout problems?
);
%OUTCOME = ();
$CHECKED = $BAD = 0;
@BAD = ();
my $URL = shift;
$UA = new LWP::UserAgent;
$PARSER = HTML::LinkExtor->new();
$TOP = $UA->request(HTTP::Request->new(HEAD => $URL));
$BASE = $TOP->base;
check_links(URI::URL->new($TOP->request->url));
if (@BAD) {
print "\nBAD LINKS:\n";
print join("\n",@BAD),"\n\n";
}
print "$CHECKED documents checked\n",scalar(@BAD)," bad links\n";
sub check_links {
my $url = shift;
my $fixed_url = $url;
$fixed_url =~ s/\#.+$//;
return 1 unless $CAN_HANDLE{$url->scheme};
# check cached outcomes
return $OUTCOME{$fixed_url} if exists $OUTCOME{$fixed_url};
print STDERR "checking $fixed_url...\n";
$CHECKED++;
my $rel = $url->rel($BASE) || 'index.html';
my $child = is_child($BASE,$url);
$UA->timeout(5);
my $doc = $d = $UA->request(HTTP::Request->new(($child ? 'GET':'HEAD')=>$url));
$OUTCOME{$fixed_url} = $doc->is_success;
return $OUTCOME{$fixed_url}
unless $child && $doc->header('Content-type') eq 'text/html';
# Follow HTML documents
my $base = $doc->base;
# pull out the links and call us recursively
my @links = $PARSER->parse($doc->content)->links;
my @hrefs = map { url($_->[2],$base)->abs } @links;
foreach (@hrefs) {
next if check_links($_);
push (@BAD,"$rel : $_");
}
1;
}
sub is_child {
my ($base,$url) = @_;
my $rel = $url->rel($base);
return ($rel ne $url) && ($rel !~ m!^[/.]!);
}
--------------------------------------------------------------------
Что делать , если сервер не справляется с нагрузкой , которая начинает тормозить ?
Один из вариантов решения - несколько веб-серверов с разными хостами и ip-шниками .
Следующий скрипт запускается на центральном сервере .
Он использует IO::Socket и слушает запросы на 80 порту.
Меняет свою привилегию на nobody.nogroup, словно он настоящий Web server.
Затем переходит в цикл accept() .
При каждом поступающем запросе он форкает дочерний процесс , который читает этот запрос
и перенаправляет его на другой веб-сервер.
---------------- Script
I.4.1:
A Load Balancing ``Web Server'' ---------
#!/usr/local/bin/perl
# list of hosts to balance between
@HOSTS = qw/www1.web.org www2.web.org www3.web.org www4.web.org/;
use IO::Socket;
$SIG{CHLD} = sub { wait() };
$ENV{'PATH'}='/bin:/usr/bin';
chomp($hostname = `/bin/hostname`);
# Listen on port 80
$sock = IO::Socket::INET->new(Listen => 5,
LocalPort => 80,
LocalAddr => $hostname,
Reuse => 1,
Proto => 'tcp');
# become "nobody"
$nobody = (getpwnam('nobody'))[2] || die "nobody is nobody";
$nogroup = (getgrnam('nogroup'))[2] || die "can't grok nogroup";
($<,$() = ($>,$)) = ($nobody,$nogroup); # get rid of root privileges!
($\,$/) = ("\r\n","\r\n\r\n"); # CR/LF on output/input
# Go into server mode
close STDIN; close STDOUT; close STDERR;
# prefork -- gee is that all there is to it?
fork() && fork() && fork() && fork() && exit 0;
# start accepting connections
while (my $s = $sock->accept()) {
do { $s->close; next; } if fork();
my $request = <$s>;
redirect($1,$s) if $request=~/(?:GET|POST|HEAD|PUT)\s+(\S+)/;
$s->flush;
undef $s;
exit 0;
}
sub redirect {
my ($url,$s) = @_;
my $host = $HOSTS[rand(@HOSTS)];
print $s "HTTP/1.0 301 Moved Temporarily";
print $s "Server: Lincoln's Redirector/1.0";
print $s "Location: http://${host}${url}";
print $s "";
}
----------------------------------------------------------------------
Любой сервер , написанный на си , рискует иметь переполнение буфера.
Следующий скрипт I.2.3 выполняет нагрузочное тестирование сайта
путем посылки большого количества данных .
Например , вот что можно увидеть при крахе сервера :
% torture.pl -t 1000 -l 5000 http://www.capricorn.com
torture.pl version 1.0 starting
Base URL: http://www.capricorn.com/cgi-bin/search
Max random data length: 5000
Repetitions: 1000
Post: 0
Append to path: 0
Escape URLs: 0
200 OK
200 OK
200 OK
200 OK
200 OK
500 Internal Server Error
500 Could not connect to www.capricorn.com:80
500 Could not connect to www.capricorn.com:80
500 Could not connect to www.capricorn.com:80
---------------------Script
I.5.1: torture tester------------------
#!/usr/local/bin/perl
# file: torture.pl
# Torture test Web servers and scripts by sending them large arbitrary URLs
# and record the outcome.
use LWP::UserAgent;
use URI::Escape 'uri_escape';
require "getopts.pl";
$USAGE = <<USAGE;
Usage: $0 -[options] URL
Torture-test Web servers and CGI scripts
Options:
-l <integer> Max length of random URL to send [1024 bytes]
-t <integer> Number of times to run the test [1]
-P Use POST method rather than GET method
-p Attach random data to path rather than query string
-e Escape the query string before sending it
USAGE
;
$VERSION = '1.0';
# process command line
&Getopts('l:t:Ppe') || die $USAGE;
# get parameters
$URL = shift || die $USAGE;
$MAXLEN = $opt_l ne '' ? $opt_l : 1024;
$TIMES = $opt_t || 1;
$POST = $opt_P || 0;
$PATH = $opt_p || 0;
$ESCAPE = $opt_e || 0;
# cannot do both a post and a path at the same time
$POST = 0 if $PATH;
# create an LWP agent
my $agent = new LWP::UserAgent;
print <<EOF;
torture.pl version $VERSION starting
Base URL: $URL
Max random data length: $MAXLEN
Repetitions: $TIMES
Post: $POST
Append to path: $PATH
Escape URLs: $ESCAPE
EOF
;
# Do the test $TIMES times
while ($TIMES) {
# create a string of random stuff
my $garbage = random_string(rand($MAXLEN));
$garbage = uri_escape($garbage) if $ESCAPE;
my $url = $URL;
my $request;
if (length($garbage) == 0) { # if no garbage to add, just fetch URL
$request = new HTTP::Request ('GET',$url);
}
elsif ($POST) { # handle POST request
my $header = new HTTP::Headers (
Content_Type => 'application/x-www-form-urlencoded',
Content_Length => length($garbage)
);
# garbage becomes the POST content
$request = new HTTP::Request ('POST',$url,$header,$garbage);
} else { # handle GET request
if ($PATH) { # append garbage to the base URL
chop($url) if substr($url,-1,1) eq '/';
$url .= "/$garbage";
} else { # append garbage to the query string
$url .= "?$garbage";
}
$request = new HTTP::Request('GET',$url);
}
# do the request and fetch the response
my $response = $agent->request($request);
# print the numeric response code and the message
print $response->code,' ',$response->message,"\n";
} continue { $TIMES-- }
# return some random data of the requested length
sub random_string {
my $length = shift;
return undef unless $length >= 1;
return join('',map chr(rand(255)),0..$length-1);
}
--------------------------------------------------------------
Эта секция включает набор скриптов , который иллюстрируют базовые типы
CGI скриптования: динамические документы, фильтры,
URL редирект.
В CGI можно создавать документы на лету.
<I> <hate>
<HTML> <because> <it's>
<ugly> <and> <has> <too> <many>
<$#@*&> <angle> <brackets>.
Скрипт II.1.1 показывает работу с этим списком тегов с помощью CGI.pm.
--------------------Script
II.1.1: vegetables1.pl ------------------
#!/usr/bin/perl
# Script: vegetables1.pl
use CGI ':standard';
print header,
start_html('Vegetables'),
h1('Eat Your Vegetables'),
ol(
li('peas'),
li('broccoli'),
li('cabbage'),
li('peppers',
ul(
li('red'),
li('yellow'),
li('green')
)
),
li('kolrabi'),
li('radishes')
),
hr,
end_html;
--------------------------------------------------------------------
То же самое , но еще проще :
--------------------Script
II.1.2: vegetables2.pl ------------------
#!/usr/bin/perl
# Script: vegetables2.pl
use CGI ':standard';
print header,
start_html('Vegetables'),
h1('Eat Your Vegetables'),
ol(
li(['peas',
'broccoli',
'cabbage',
'peppers' .
ul(['red','yellow','green']),
'kolrabi',
'radishes'
),
hr,
end_html;
--------------------------------------------------------------------
Или так :
--------------------Script
II.1.3: vegetables3.pl ------------------
#!/usr/bin/perl
# Script: vegetables3.pl
use CGI qw/:standard :html3/;
print header,
start_html('Vegetables'),
h1('Vegetables are for the Strong'),
table({-border=>undef},
caption(strong('When Should You Eat Your Vegetables?')),
Tr({-align=>CENTER,-valign=>TOP},
[
th(['','Breakfast','Lunch','Dinner']),
th('Tomatoes').td(['no','yes','yes']),
th('Broccoli').td(['no','no','yes']),
th('Onions').td(['yes','yes','yes'])
]
)
),
end_html;
--------------------------------------------------------------------
CGI.pm имеет набор функций для генерации форм и чтении ее контента при сабмите.
Скрипт II.1.4 создает строку радиобатонов разных цветов.
После сабмита страница рефрешит себя с выбраным цветом :
------------------Script
II.1.4: customizable.pl ------------------
#!/usr/bin/perl
# script: customizable.pl
use CGI qw/:standard/;
$color = param('color') || 'white';
print header,
start_html({-bgcolor=>$color},'Customizable Page'),
h1('Customizable Page'),
"Set this page's background color to:",br,
start_form,
radio_group(-name=>'color',
-value=>['white','red','green','black',
'blue','silver','cyan'],
-cols=>2),
submit(-name=>'Set Background'),
end_form,
p,
hr,
end_html;
--------------------------------------------------------------------
=head3 Making Stateful Forms
Скрипт II.1.5 - пример приложения с 5-ю страницами.
С помощью навигации можно перемещаться по ним.Состояние страниц запоминается
с помощью скрытых полей :
------------------------Script
II.1.5: loan.pl ---------------------
#!/usr/local/bin/perl
# script: loan.pl
use CGI qw/:standard :html3/;
# this defines the contents of the fill out forms
# on each page.
@PAGES = ('Personal Information','References','Assets','Review','Confirmation');
%FIELDS = ('Personal Information' => ['Name','Address','Telephone','Fax'],
'References' => ['Personal Reference 1','Personal Reference 2'],
'Assets' => ['Savings Account','Home','Car']
);
# accumulate the field names into %ALL_FIELDS;
foreach (values %FIELDS) {
grep($ALL_FIELDS{$_}++,@$_);
}
# figure out what page we're on and where we're heading.
$current_page = calculate_page(param('page'),param('go'));
$page_name = $PAGES[$current_page];
print_header();
print_form($current_page) if $FIELDS{$page_name};
print_review($current_page) if $page_name eq 'Review';
print_confirmation($current_page) if $page_name eq 'Confirmation';
print end_html;
# CALCULATE THE CURRENT PAGE
sub calculate_page {
my ($prev,$dir) = @_;
return 0 if $prev eq ''; # start with first page
return $prev + 1 if $dir eq 'Submit Application';
return $prev + 1 if $dir eq 'Next Page';
return $prev - 1 if $dir eq 'Previous Page';
}
# PRINT HTTP AND HTML HEADERS
sub print_header {
print header,
start_html("Your Friendly Family Loan Center"),
h1("Your Friendly Family Loan Center"),
h2($page_name);
}
# PRINT ONE OF THE QUESTIONNAIRE PAGES
sub print_form {
my $current_page = shift;
print "Please fill out the form completely and accurately.",
start_form,
hr;
draw_form(@{$FIELDS{$page_name}});
print hr;
print submit(-name=>'go',-value=>'Previous Page')
if $current_page > 0;
print submit(-name=>'go',-value=>'Next Page'),
hidden(-name=>'page',-value=>$current_page,-override=>1),
end_form;
}
# PRINT THE REVIEW PAGE
sub print_review {
my $current_page = shift;
print "Please review this information carefully before submitting it. ",
start_form;
my (@rows);
foreach $page ('Personal Information','References','Assets') {
push(@rows,th({-align=>LEFT},em($page)));
foreach $field (@{$FIELDS{$page}}) {
push(@rows,
TR(th({-align=>LEFT},$field),
td(param($field)))
);
print hidden(-name=>$field);
}
}
print table({-border=>1},caption($page),@rows),
hidden(-name=>'page',-value=>$current_page,-override=>1),
submit(-name=>'go',-value=>'Previous Page'),
submit(-name=>'go',-value=>'Submit Application'),
end_form;
}
# PRINT THE CONFIRMATION PAGE
sub print_confirmation {
print "Thank you. A loan officer will be contacting you shortly.",
p,
a({-href=>'../source.html'},'Code examples');
}
# CREATE A GENERIC QUESTIONNAIRE
sub draw_form {
my (@fields) = @_;
my (%fields);
grep ($fields{$_}++,@fields);
my (@hidden_fields) = grep(!$fields{$_},keys %ALL_FIELDS);
my (@rows);
foreach (@fields) {
push(@rows,
TR(th({-align=>LEFT},$_),
td(textfield(-name=>$_,-size=>50))
)
);
}
print table(@rows);
foreach (@hidden_fields) {
print hidden(-name=>$_);
}
}
--------------------------------------------------------------------
Скрипт II.1.6 запоминает имя пользователя , выбранный цвет
и при перезагрузке восстанавливает их в течение 30 дней .
-------------------Script
II.1.6: preferences.pl --------------------
#!/usr/local/bin/perl
# file: preferences.pl
use CGI qw(:standard :html3);
# Some constants to use in our form.
@colors=qw/aqua black blue fuschia gray green lime maroon navy olive
purple red silver teal white yellow/;
@sizes=("<default>",1..7);
# recover the "preferences" cookie.
%preferences = cookie('preferences');
# If the user wants to change the background color or her
# name, they will appear among our CGI parameters.
foreach ('text','background','name','size') {
$preferences{$_} = param($_) || $preferences{$_};
}
# Set some defaults
$preferences{'background'} = $preferences{'background'} || 'silver';
$preferences{'text'} = $preferences{'text'} || 'black';
# Refresh the cookie so that it doesn't expire.
$the_cookie = cookie(-name=>'preferences',
-value=>\%preferences,
-path=>'/',
-expires=>'+30d');
print header(-cookie=>$the_cookie);
# Adjust the title to incorporate the user's name, if provided.
$title = $preferences{'name'} ?
"Welcome back, $preferences{name}!" : "Customizable Page";
# Create the HTML page. We use several of the HTML 3.2
# extended tags to control the background color and the
# font size. It's safe to use these features because
# cookies don't work anywhere else anyway.
print start_html(-title=>$title,
-bgcolor=>$preferences{'background'},
-text=>$preferences{'text'}
);
print basefont({-size=>$preferences{size}}) if $preferences{'size'} > 0;
print h1($title);
# Create the form
print hr,
start_form,
"Your first name: ",
textfield(-name=>'name',
-default=>$preferences{'name'},
-size=>30),br,
table(
TR(
td("Preferred"),
td("Page color:"),
td(popup_menu(-name=>'background',
-values=>\@colors,
-default=>$preferences{'background'})
),
),
TR(
td(''),
td("Text color:"),
td(popup_menu(-name=>'text',
-values=>\@colors,
-default=>$preferences{'text'})
)
),
TR(
td(''),
td("Font size:"),
td(popup_menu(-name=>'size',
-values=>\@sizes,
-default=>$preferences{'size'})
)
)
),
submit(-label=>'Set preferences'),
end_form,
hr,
end_html;
--------------------------------------------------------------------
К ним относятся картинки, Postscript , звук и другие.
Скрипт II.1.7 создает набор кликаемых цветных кругов внутри
квадрата . При этом создается форма , которая позволяет пользователю выбирать
цвет и размер .
-------------------Script
II.1.7: circle.pl --------------------
#!/usr/local/bin/perl
# script: circle.pl
use GD;
use CGI qw/:standard Map Area/;
use constant RECTSIZE => 100;
use constant CIRCLE_RADIUS => 40;
%COLORS = (
'white' => [255,255,255],
'red' => [255,0,0],
'green' => [0,255,0],
'blue' => [0,0,255],
'black' => [0,0,0],
'bisque'=> [255,228,196],
'papaya whip' => [255,239,213],
'sienna' => [160,82,45]
);
my $draw = param('draw');
my $circle_color = param('color') || 'bisque';
my $mag = param('magnification') || 1;
if ($draw) {
draw_image();
} else {
make_page()
}
sub draw_image {
# create a new image
my $im = new GD::Image(RECTSIZE*$mag,RECTSIZE*$mag);
# allocate some colors
my $white = $im->colorAllocate(@{$COLORS{'white'}});
my $black = $im->colorAllocate(@{$COLORS{'black'}});
my $circlecolor = $im->colorAllocate(@{$COLORS{$circle_color}});
# make the background transparent and interlaced
$im->transparent($white);
$im->interlaced('true');
# Put a black frame around the picture
$im->rectangle(0,0,RECTSIZE*$mag-1,RECTSIZE*$mag-1,$black);
# Draw the circle
$im->arc(RECTSIZE*$mag/2,
RECTSIZE*$mag/2,CIRCLE_RADIUS*$mag*2,CIRCLE_RADIUS*$mag*2,0,360,$black);
# And fill it with circlecolor
$im->fill(RECTSIZE*$mag/2,RECTSIZE*$mag/2,$circlecolor);
# Convert the image to GIF and print it
print header('image/gif'),$im->gif;
}
sub make_page {
param(-name=>'draw',-value=>1);
print header(),
start_html(-title=>'Feeling Circular',-bgcolor=>'white'),
h1('A Circle is as a Circle Does'),
img({-src=>self_url(),-alt=>'a circle',
-align=>'LEFT',-usemap=>'#map',
-border=>0});
print em(param('message')) if param('message');
Delete('draw');
print start_form,
"Magnification: ",radio_group(-name=>'magnification',-values=>[1..4]),br,
"Color: ",popup_menu(-name=>'color',-values=>[sort keys %COLORS]),
submit(-value=>'Change'),
end_form;
print Map({-name=>'map'},
Area({-shape=>'CIRCLE',
-href=>param(-name=>'message',-value=>"You clicked in the circle")
? self_url() : '',
-coords=>join(',',RECTSIZE*$mag/2,RECTSIZE*$mag/2,CIRCLE_RADIUS*$mag),
-alt=>'Circle'}),
Area({-shape=>'RECT',
-href=>param(-name=>'message',-value=>"You clicked in the square")
? self_url() : '',
-coords=>join(',',0,0,RECTSIZE*$mag,RECTSIZE*$mag),
-alt=>'Square'}));
print end_html;
}
----------------------------------------------------------------------------
Скрипт II.1.8 создает гиф-анимацию.
-------------------Script
II.1.8: animate.pl --------------------
#!/usr/local/bin/perl
# script: animated.pl
use GD;
use File::Path;
use constant START => 80;
use constant END => 200;
use constant STEP => 10;
use constant COMBINE => '/usr/local/bin/convert';
@COMBINE_OPTIONS = (-delay => 5,
-loop => 10000);
@COLORS = ([240,240,240],
[220,220,220],
[200,200,200],
[180,180,180],
[160,160,160],
[140,140,140],
[150,120,120],
[160,100,100],
[170,80,80],
[180,60,60],
[190,40,40],
[200,20,20],
[210,0,0]);
@COLORS = (@COLORS,reverse(@COLORS));
my @FILES = ();
my $dir = create_temporary_directory();
my $index = 0;
for (my $r = START; $r <= END; $r+=STEP) {
draw($r,$index,$dir);
$index++;
}
for (my $r = END; $r > START; $r-=STEP) {
draw($r,$index,$dir);
$index++;
}
# emit the GIF89a
$| = 1;
print "Content-type: image/gif\n\n";
system COMBINE,@COMBINE_OPTIONS,@FILES,"gif:-";
rmtree([$dir],0,1);
sub draw{
my ($r,$color_index,$dir) = @_;
my $im = new GD::Image(END,END);
my $white = $im->colorAllocate(255,255,255);
my $black = $im->colorAllocate(0,0,0);
my $color = $im->colorAllocate(@{$COLORS[$color_index % @COLORS]});
$im->rectangle(0,0,END,END,$white);
$im->arc(END/2,END/2,$r,$r,0,360,$black);
$im->fill(END/2,END/2,$color);
my $file = sprintf("%s/picture.%02d.gif",$dir,$color_index);
open (OUT,">$file") || die "couldn't create $file: $!";
print OUT $im->gif;
close OUT;
push(@FILES,$file);
}
sub create_temporary_directory {
my $basename = "/usr/tmp/animate$$";
my $counter=0;
while ($counter < 100) {
my $try = sprintf("$basename.%04d",$counter);
next if -e $try;
return $try if mkdir $try,0700;
} continue { $counter++; }
die "Couldn't make a temporary directory";
}
----------------------------------------------------------------------------
Скрипт II.2.1 читает файл и находит в нем 4-буквенные слова .
----------------------Script
II.2.1: naughty.pl ------------------------
#!/usr/local/bin/perl
# Script: naughty.pl
use CGI ':standard';
$file = path_translated() ||
die "must be called with additional path info";
open (FILE,$file) || die "Can't open $file: $!\n";
print header('text/plain');
while (<FILE>) {
s/\b(\w)\w{2}(\w)\b/$1**$2/g;
print;
}
close FILE;
----------------------------------------------------------------------------
Еще лучше можно сделать с помощью mod_perl.
--------------------Script
II.2.2: naughty2.pl -----------------------
#!/usr/local/bin/perl
# Script: naughty2.pl
package HTML::Parser::FixNaughty;
require HTML::Parser;
@ISA = 'HTML::Parser';
sub start {
my ($self,$tag,$attr,$attrseq,$origtext) = @_;
print $origtext;
}
sub end {
my ($self,$tag) = @_;
print "</$tag>";
}
sub text {
my ($self,$text) = @_;
$text =~ s/\b(\w)\w{2}(\w)\b/$1**$2/g;
print $text;
}
package main;
use CGI qw/header path_info redirect path_translated/;
$file = path_translated() ||
die "must be called with additional path info";
$file .= "index.html" if $file=~m!/$!;
unless ($file=~/\.html?$/) {
print redirect(path_info());
exit 0;
}
$parser = new HTML::Parser::FixNaughty;
print header();
$parser->parse_file($file);
----------------------------------------------------------------------------
Если на апаче установлен mod_perl , можно в конфиге прописать хэндлер :
<Location />
... blah blah blah other stuff
Action text/html /cgi-bin/naughty2.pl
</Location>
После этого любой HTML-документ будет обрабатываться этим скриптом .
Скрипт II.3.1 выбирает произвольную картинку из каталога
и выводит ее .
/cgi-bin/random_pict/banners/egregious_advertising
-------------------Script
II.3.1 random_pict.pl -----------------------------
#!/usr/local/bin/perl
# script: random_pict.pl
use CGI qw/:standard/;
$PICTURE_PATH = path_translated();
$PICTURE_URL = path_info();
chdir $PICTURE_PATH
or die "Couldn't chdir to pictures directory: $!";
@pictures = <*.{jpg,gif}>;
$lucky_one = $pictures[rand(@pictures)];
die "Failed to pick a picture" unless $lucky_one;
print redirect("$PICTURE_URL/$lucky_one");
---------------------------------------------------------------------
Скрипт II.4.1 читает загружаемый файл и печатает его длину
MIME тип.
----------------Script
II.4.1 upload.pl -----------------------------
#!/usr/local/bin/perl
#script: upload.pl
use CGI qw/:standard/;
print header,
start_html('file upload'),
h1('file upload');
print_form() unless param;
print_results() if param;
print end_html;
sub print_form {
print start_multipart_form(),
filefield(-name=>'upload',-size=>60),br,
submit(-label=>'Upload File'),
end_form;
}
sub print_results {
my $length;
my $file = param('upload');
if (!$file) {
print "No file uploaded.";
return;
}
print h2('File name'),$file;
print h2('File MIME type'),
uploadInfo($file)->{'Content-Type'};
while (<$file>) {
$length += length($_);
}
print h2('File length'),$length;
}
---------------------------------------------------------------------
С установленным mod_perl нет необходимости ждать , пока перловый интерпретатор
прочитает и откомпилирует скрипт.Однажды откомпилированный , скрипт хранится в памяти .
mod_perl дает доступ к Apache API и позволяет управлять его поведением.
Скрипт III.1.1 hello world .
В конфиг-файл нужно добавить следующую секцию :
<Location /hello/world>
SetHandler perl-script
PerlHandler Apache::Hello
</Location>
------------------Script
III.1.1 Apache::Hello --------------------
package Apache::Hello;
# file: Apache::Hello.pm
use strict vars;
use Apache::Constants ':common';
sub handler {
my $r = shift;
$r->content_type('text/html');
$r->send_http_header;
my $host = $r->get_remote_host;
$r->print(<<END);
<HTML>
<HEADER>
<TITLE>Hello There</TITLE>
</HEADER>
<BODY>
<H1>Hello $host</H1>
Hello to all the nice people at the Perl conference. Lincoln is
trying really hard. Be kind.
</BODY>
</HTML>
END
return OK;
}
1;
----------------------------------------------------------------
С помощью install можно инсталлировать content handler .
Скрипт III.2.1 добавляет футер в HTML файл.
Для установки хэндлера для всех файлов в каталоге в конфиге нужно прописать :
<Location /footer>
SetHandler perl-script
PerlHandler Apache::Footer
</Location>
Можно декларировать новое расширение ``.footer'' и ссылаться на него в footer module:
AddType text/html .footer
<Files ~ "\.footer$">
SetHandler perl-script
PerlHandler Apache::Footer
</Files>
------------------Script
III.2.1 Apache::Footer --------------------
package Apache::Footer;
# file Apache::Footer.pm
use strict vars;
use Apache::Constants ':common';
use IO::File;
sub handler {
my $r = shift;
return DECLINED unless $r->content_type() eq 'text/html';
my $file = $r->filename;
return DECLINED unless $fh=IO::File->new($file);
my $modtime = localtime((stat($file))[9]);
my $footer=<<END;
<hr>
© 1998 <a href="http://www.ora.com/">O\'Reilly & Associates</a><br>
<em>Last Modified: $modtime</em>
END
;
$r->send_http_header;
while (<$fh>) {
s!(</BODY>)!$footer$1!oi;
} continue {
$r->print($_);
}
return OK;
}
1;
------------------------------------------------------------------
В следующем примере мы реализуем собственную SSI-систему , которая
будет выглядеть примерно так ,
<!--#DIRECTIVE PARAM1 PARAM2 PARAM3 PARAM4...-->
Директива будет представлена функцией на перл в отдельном файле :
use POSIX 'strftime';
# insert the string "Hello World!"
sub HELLO {
my $r = shift;
"Hello World!";
}
# insert today's date possibly modified by a strftime() format
# string
sub DATE {
my ($r,$format) = @_;
return scalar(localtime) unless $format;
return strftime($format,localtime);
}
# insert the modification time of the document, possibly modified
# by a strftime() format string.
sub MODTIME {
my ($r,$format) = @_;
my $file = $r->filename;
return localtime((stat($file))[9]) unless $format;
return strftime($format,localtime((stat($file))[9]));
}
# insert a canned footer
sub FOOTER {
my $r = shift;
my $modtime = MODTIME($r);
return <<END;
<hr>
© 1998 <a href="http://www.ora.com/">O\'Reilly & Associates</a><br>
<em>Last Modified: $modtime</em>
END
;
}
# insert the named field from the incoming HTTP request
sub HEADER_FIELD {
my ($r,$h) = @_;
$r->header_in($h);
}
1;
Теперь если в HTML мы вставим код <!--#HELLO--> , будет распечатано
Hello World! . Другой пример :
<!--#HEADER User-Agent--> - распечатает версию броузера .
Обычно в конфиге используется префикс ``.ehtml'' для обозначения SSI :
<Files ~ "\.ehtml$">
SetHandler perl-script
PerlHandler Apache::ESSI
PerlSetVar ESSIDefs conf/essi.defs
</Files>
AddType text/html .ehtml
------------------Script
III.2.1 Apache::ESSI --------------------
package Apache::ESSI;
use strict vars;
use Apache::Constants ':common';
use IO::File;
my (%MODIFIED,%SUBSTITUTION);
sub handler {
my $r = shift;
$r->content_type() eq 'text/html' || return DECLINED;
my $fh=IO::File->new($r->filename)|| return DECLINED;
my $sub = read_definitions($r) || return SERVER_ERROR;
$r->send_http_header;
$r->print($sub->(<$fh>));
return OK;
}
sub read_definitions {
my $r = shift;
return undef unless my $def = $r->dir_config('ESSIDefs');
return undef unless -e ($def = $r->server_root_relative($def));
return $SUBSTITUTION{$def}
if $MODIFIED{$def} && $MODIFIED{$def} <= -M _;
my $package = "Apache::ESSI::$def";
$package=~tr/a-zA-Z0-9_/_/c;
$SUBSTITUTION{$def} = eval <<END;
package $package;
use Text::ParseWords 'quotewords';
do '$def';
sub {
# Make sure that eval() errors aren't trapped.
local \$SIG{__WARN__}= \\&CORE::warn;
local \$SIG{__DIE__} = \\&CORE::die;
my \@lines = \@_;
my \$data = join('',\@lines);
\$data =~ s/<!--\\s*\\#(\\w+) # start of a function name
\\s*(.*?) # optional parameters
\\s*--> # end of comment
/eval {&{\$1}(\$r,quotewords('[ ,]',0,\$2))}
|| "<em>[\$@]<\\/em>"/xseg;
\$data;
};
END
unless ($SUBSTITUTION{$def}) {
$r->log_error("Eval of $def did not return true: $@");
return undef;
}
$MODIFIED{$def} = -M $def; # store modification date
return $SUBSTITUTION{$def};
}
1;
-----------------------------------------------------------------------
Скрипт III.2.4 - контент-фильтр , который архивирует
с расширением gzips все файлы в каталоге и добавляет ``gzip''
Content-Encoding хидер.
В коде используется модуль Compress::Zlib . Этот код можно использовать
для криптования .
В конфигурации настраиваем каталог /compressed :
<Location /compressed>
SetHandler perl-script
PerlHandler Apache::GZip
</Location>
---------------- Script
III.2.3: Apache::GZip -------------------------
package Apache::GZip;
#File: Apache::GZip.pm
use strict vars;
use Apache::Constants ':common';
use Compress::Zlib;
use IO::File;
use constant GZIP_MAGIC => 0x1f8b;
use constant OS_MAGIC => 0x03;
sub handler {
my $r = shift;
my ($fh,$gz);
my $file = $r->filename;
return DECLINED unless $fh=IO::File->new($file);
$r->header_out('Content-Encoding'=>'gzip');
$r->send_http_header;
return OK if $r->header_only;
tie *STDOUT,'Apache::GZip',$r;
print($_) while <$fh>;
untie *STDOUT;
return OK;
}
sub TIEHANDLE {
my($class,$r) = @_;
# initialize a deflation stream
my $d = deflateInit(-WindowBits=>-MAX_WBITS()) || return undef;
# gzip header -- don't ask how I found out
$r->print(pack("nccVcc",GZIP_MAGIC,Z_DEFLATED,0,time(),0,OS_MAGIC));
return bless { r => $r,
crc => crc32(undef),
d => $d,
l => 0
},$class;
}
sub PRINT {
my $self = shift;
foreach (@_) {
# deflate the data
my $data = $self->{d}->deflate($_);
$self->{r}->print($data);
# keep track of its length and crc
$self->{l} += length($_);
$self->{crc} = crc32($_,$self->{crc});
}
}
sub DESTROY {
my $self = shift;
# flush the output buffers
my $data = $self->{d}->flush;
$self->{r}->print($data);
# print the CRC and the total length (uncompressed)
$self->{r}->print(pack("LL",@{$self}{qw/crc l/}));
}
1;
-----------------------------------------------------------------------
Под контролем доступа подразумевается аутентификация / авторизация .
О пользователе можно получить ограниченную информацию - ip,хост,тип броузера.
Скрипт III.3.1 блокирует доступ для определенного типа броузеров ..
Apache::BlockAgent читает информацию из файла ``bad agents''.
Пример agents file:
^teleport pro\/1\.28
^nicerspro
^mozilla\/3\.0 \(http engine\)
^netattache
^crescent internet toolpak http ole control v\.1\.0
^go-ahead-got-it
^wget
^devsoft's http component v1\.0
^www\.pl
^digout4uagent
Конфигурация :
<Location />
PerlAccessHandler Apache::BlockAgent
PerlSetVar BlockAgentFile /home/www/conf/bad_agents.txt
</Location>
------------------Script III.3.1: Apache::BlockAgent-------------------
package Apache::BlockAgent;
# block browsers that we don't like
use strict 'vars';
use Apache::Constants ':common';
use IO::File;
my %MATCH_CACHE;
my $DEBUG = 0;
sub handler {
my $r = shift;
return DECLINED unless my $patfile = $r->dir_config('BlockAgentFile');
return FORBIDDEN unless my $agent = $r->header_in('User-Agent');
return SERVER_ERROR unless my $sub = get_match_sub($r,$patfile);
return OK if $sub->($agent);
$r->log_reason("Access forbidden to agent $agent",$r->filename);
return FORBIDDEN;
}
# This routine creates a pattern matching subroutine from a
# list of pattern matches stored in a file.
sub get_match_sub {
my ($r,$filename) = @_;
my $mtime = -M $filename;
# try to return the sub from cache
return $MATCH_CACHE{$filename}->{'sub'} if
$MATCH_CACHE{$filename} &&
$MATCH_CACHE{$filename}->{'mod'} <= $mtime;
# if we get here, then we need to create the sub
return undef unless my $fh = new IO::File($filename);
chomp(my @pats = <$fh>); # get the patterns into an array
my $code = "sub { \$_ = shift;\n";
foreach (@pats) {
next if /^#/
$code .= "return undef if /$_/i;\n";
}
$code .= "1; }\n";
warn $code if $DEBUG;
# create the sub, cache and return it
my $sub = eval $code;
unless ($sub) {
$r->log_error($r->uri,": ",$@);
return undef;
}
@{$MATCH_CACHE{$filename}}{'sub','mod'}=($sub,$modtime);
return $MATCH_CACHE{$filename}->{'sub'};
}
1;
-----------------------------------------------------------------------
Модули DBI и DBM включают mod_perl authentication/authorization API .
Аутентификация проверяет юзерские логин с паролем .
Авторизация решает , имеет ли пользователь права на просмотр того или иного документа .
Скрипт III.4.1 показывает , как модуль Apache::AuthSystem
проверяет пользовательские имя и пароль , сравнивает с системным паролем и принимает решение .
Функция getpwnam() работает с базой данных NIS .
Конфигурация :
<Location /protected>
AuthName Test
AuthType Basic
PerlAuthenHandler Apache::AuthSystem;
require valid-user
</Location>
--------------------Script III.4.1: Apache::AuthSystem-----------------
package Apache::AuthSystem;
# authenticate users on system password database
use strict;
use Apache::Constants ':common';
sub handler {
my $r = shift;
my($res, $sent_pwd) = $r->get_basic_auth_pw;
return $res if $res != OK;
my $user = $r->connection->user;
my $reason = "";
my($name,$passwd) = getpwnam($user);
if (!$name) {
$reason = "user does not have an account on this system";
} else {
$reason = "user did not provide correct password"
unless $passwd eq crypt($sent_pwd,$passwd);
}
if($reason) {
$r->note_basic_auth_failure;
$r->log_reason($reason,$r->filename);
return AUTH_REQUIRED;
}
return OK;
}
1;
-----------------------------------------------------------------------
Here's a system that authenticates users the way anonymous
FTP does. They have to enter a name like ``Anonymous''
(configurable) and a password that looks like a valid e-mail address. The
system rejects the username and password unless they are formatted
correctly.
In a real application, you'd probably want to log the password somewhere for posterity. Script
III.4.2 shows the code for Apache::AuthAnon. To activate it, create a access.conf section like this one:
<Location /protected>
AuthName Anonymous
AuthType Basic
PerlAuthenHandler Apache::AuthAnon
require valid-user
PerlSetVar Anonymous anonymous|anybody
</Location>
---------------Script
III.4.2: Anonymous Authentication-----------------
package Apache::AuthAnon;
use strict;
use Apache::Constants ':common';
my $email_pat = '\w+\@\w+\.\w+';
my $anon_id = "anonymous";
sub handler {
my $r = shift;
my($res, $sent_pwd) = $r->get_basic_auth_pw;
return $res if $res != OK;
my $user = lc $r->connection->user;
my $reason = "";
my $check_id = $r->dir_config("Anonymous") || $anon_id;
unless($user =~ /^$check_id$/i) {
$reason = "user did not enter a valid anonymous username";
}
unless($sent_pwd =~ /$email_pat/o) {
$reason = "user did not enter an email address password";
}
if($reason) {
$r->note_basic_auth_failure;
$r->log_reason($reason,$r->filename);
return AUTH_REQUIRED;
}
$r->notes(AuthAnonPassword => $sent_pwd);
return OK;
}
1;
-----------------------------------------------------------------------
After authenticating, you can authorize. The most familiar type of
authorization checks a group database to see if the user belongs to one or
more privileged groups. But authorization can be anything you dream up.
Script
III.4.3 shows how you can authorize users by their
gender (or at least their apparent gender, by checking their names with Jon Orwant's Text::GenderFromName
module. This must be used in conjunction with an authentication module,
such as one of the standard Apache modules or a custom one.
This configuration restricts access to users with feminine names, except
for the users ``Webmaster'' and ``Jeff'', who are allowed access.
<Location /ladies_only>
AuthName "Ladies Only"
AuthType Basic
AuthUserFile /home/www/conf/users.passwd
PerlAuthzHandler Apache::AuthzGender
require gender F # allow females
require user Webmaster Jeff # allow Webmaster or Jeff
</Location>
The script uses a custom error response to explain why the user was denied
admittance. This is better than the standard ``Authorization Failed''
message.
------------------Script
III.4.3: Apache::AuthzGender---------------
package Apache::AuthzGender;
use strict;
use Text::GenderFromName;
use Apache::Constants ":common";
my %G=('M'=>"male",'F'=>"female");
sub handler {
my $r = shift;
return DECLINED unless my $requires = $r->requires;
my $user = lc($r->connection->user);
substr($user,0,1)=~tr/a-z/A-Z/;
my $guessed_gender = uc(gender($user)) || 'M';
my $explanation = <<END;
<HTML><HEAD><TITLE>Unauthorized</TITLE></HEAD><BODY>
<H1>You Are Not Authorized to Access This Page</H1>
Access to this page is limited to:
<OL>
END
foreach (@$requires) {
my ($requirement,@rest ) = split(/\s+/,$_->{requirement});
if (lc $requirement eq 'user') {
foreach (@rest) { return OK if $user eq $_; }
$explanation .= "<LI>Users @rest.\n";
} elsif (lc $requirement eq 'gender') {
foreach (@rest) { return OK if $guessed_gender eq uc $_; }
$explanation .= "<LI>People of the @G{@rest} persuasion.\n";
} elsif (lc $requirement eq 'valid-user') {
return OK;
}
}
$explanation .= "</OL></BODY></HTML>";
$r->custom_response(AUTH_REQUIRED,$explanation);
$r->note_basic_auth_failure;
$r->log_reason("user $user: not authorized",$r->filename);
return AUTH_REQUIRED;
}
1;
--------------------------------------------------------------------
mod_perl gives you access to Apache's ability to act as a Web proxy. You
can intervene at any step in the proxy transaction to modify the outgoing
request (for example, stripping off headers in order to create an
anonymizing proxy) or to modify the returned page.
Script
III.5.1 shows the code for a banner-ad blocker
written by Doug MacEachern. It intercepts all proxy requests,
substituting its own content handler for the default. The content
handler uses the LWP library to fetch the requested document. If the retrieved document is an image, and its
URL matches the pattern (ads?|advertisement|banner), then the content of the image is replaced with a dynamically-generated
GIF that reads ``Blocked Ad''. The generated
image is exactly the same size as the original, preserving the page
layout. Notice how the outgoing headers from the Apache request object
are copied to the LWP request, and how the incoming
LWP response headers are copied back to Apache. This makes the transaction nearly transparent to Apache and to the remote server.
In addition to
LWP you'll need GD.pm and Image::Size to run this
module. To activate it, add the following line to the configuration file:
PerlTransHandler Apache::AdBlocker
Then configure your browser to use the server to proxy all its
HTTP requests. Works like a charm! With a little more
work, and some help from the ImageMagick module, you could adapt this
module to quiet-down animated GIFs by stripping them of all but the very
first frame.
---------------Script
III.5.1: Apache::AdBlocker---------------------
package Apache::AdBlocker;
use strict;
use vars qw(@ISA $VERSION);
use Apache::Constants qw(:common);
use GD ();
use Image::Size qw(imgsize);
use LWP::UserAgent ();
@ISA = qw(LWP::UserAgent);
$VERSION = '1.00';
my $UA = __PACKAGE__->new;
$UA->agent(join "/", __PACKAGE__, $VERSION);
my $Ad = join "|", qw{ads? advertisement banner};
sub handler {
my($r) = @_;
return DECLINED unless $r->proxyreq;
$r->handler("perl-script"); #ok, let's do it
$r->push_handlers(PerlHandler => \&proxy_handler);
return OK;
}
sub proxy_handler {
my($r) = @_;
my $request =
--------------------------------------------------------------------
Another way of doing this module would be to scan all proxied
HTML files for
<IMG> tags containing one of the verboten URLs, then replacing the
SRC attribute with a transparent
GIF of our own. However, unless the
<IMG> tag contained
WIDTH and
HEIGHT attributes, we wouldn't be able to return a
GIF of the correct size -- unless we were to go hunting for the
GIF with
LWP, in which case we might as well do it this way.
After Apache handles a transaction, it passes all the information about the
transaction to the log handler. The default log handler writes out lines to
the log file. With mod_perl, you can install your own log handler to do
customized logging.
Script
III.6.1 installs a log handler which watches over a
page or set of pages. When someone fetches a watched page, the log handler
sends off an e-mail to notify someone (probably the owner of the page) that
the page has been read.
To activate the module, just attach a PerlLogHandler to the
<Location> or <File> you wish to watch. For example:
<Location /~lstein>
PerlLogHandler Apache::LogMail
PerlSetVar mailto lstein@cshl.org
</Location>
The ``mailto'' directive specifies the name of the
recipient(s) to notify.
-------------------Script
III.6.1: Apache::LogMail------------------
package Apache::LogMail;
use Apache::Constants ':common';
sub handler {
my $r = shift;
my $mailto = $r->dir_config('mailto');
return DECLINED unless $mailto
my $request = $r->the_request;
my $uri = $r->uri;
my $agent = $r->header_in("User-agent");
my $bytes = $r->bytes_sent;
my $remote = $r->get_remote_host;
my $status = $r->status_line;
my $date = localtime;
unless (open (MAIL,"|/usr/lib/sendmail -oi -t")) {
$r->log_error("Couldn't open mail: $!");
return DECLINED;
}
print MAIL <<END;
To: $mailto
From: Mod Perl <webmaster>
Subject: Somebody looked at $uri
At $date, a user at $remote looked at
$uri using the $agent browser.
The request was $request,
which resulted returned a code of $status.
$bytes bytes were transferred.
END
close MAIL;
return OK;
}
1;
--------------------------------------------------------------------
Coming full circle, Script
III.6.2 shows a module that writes log information into a
DBI database. The idea is similar to Script
I.1.9, but there's now no need to open a pipe to
an external process. It's also a little more efficient, because the log
data fields can be recovered directly from the Apache request object,
rather than parsed out of a line of text. Another improvement is that
we can set up the Apache configuration files so that only accesses to
certain directories are logged in this way.
To activate, add something like this to your configuration file:
PerlLogHandler Apache::LogDBI
Or, to restrict special logging to accesses of files in below the
URL ``/lincoln_logs'' add this:
<Location /lincoln_logs>
PerlLogHandler Apache::LogDBI
</Location>
-----------------Script
III.6.2: Apache::LogDBI---------------------
package Apache::LogDBI;
use Apache::Constants ':common';
use strict 'vars';
use vars qw($DB $STH);
use DBI;
use POSIX 'strftime';
use constant DSN => 'dbi:mysql:www';
use constant DB_TABLE => 'access_log';
use constant DB_USER => 'nobody';
use constant DB_PASSWD => '';
$DB = DBI->connect(DSN,DB_USER,DB_PASSWD) || die DBI->errstr;
$STH = $DB->prepare("INSERT INTO ${\DB_TABLE} VALUES(?,?,?,?,?,?,?,?,?)")
|| die $DB->errstr;
sub handler {
my $r = shift;
my $date = strftime('%Y-%m-%d %H:%M:%S',localtime);
my $host = $r->get_remote_host;
my $method = $r->method;
my $url = $r->uri;
my $user = $r->connection->user;
my $referer = $r->header_in('Referer');
my $browser = $r->header_in("User-agent");
my $status = $r->status;
my $bytes = $r->bytes_sent;
$STH->execute($date,$host,$method,$url,$user,
$browser,$referer,$status,$bytes);
return OK;
}
1;
--------------------------------------------------------------------
That's as many tricks as
I thought could squeeze into a three-hour session.
Even so, we probably didn't have time to cover them all. You'll find more
tricks in my books, articles and Web site. Here's where you can find them:
- "How to Set Up and Maintain a Web Site"
-
General introduction to Web site care and feeding, with an emphasis on
Apache. Addison-Wesley 1997.
Companion Web site at http://www.genome.wi.mit.edu/WWW/
- "Web Security, a Step-by-Step Reference Guide"
-
How to keep your Web site free from thieves, vandals, hooligans and other
yahoos. Addison-Wesley 1998.
Companion Web site at http://www.w3.org/Security/Faq/
- "The Official Guide to Programming with CGI.pm"
-
Everything
I know about CGI.pm (and some things
I don't!). John Wiley & Sons, 1998.
Companion Web site at http://www.wiley.com/compbooks/stein/
- "The Apache Module Book: Fast Dynamic Pages in Perl and C"
-
Co-authored with Doug MacEachern. Will be out sometime in the fall of 1998.
Companion Web site at http://www.modperl.com/
- WebTechniques Columns
-
I write a monthly column for WebTechniques magazine.
You can find back-issues and reprints at http://www.web-techniques.com/
- The Perl Journal Columns
-
I write a quarterly column for
TPJ. Source code listings are available at http://www.tpj.com/
Lincoln D. Stein
Cold Spring Harbor Laboratory
July 6, 1998
| 
LINUX 
Languages
