docs/pws2002/webserver.sdf

!init OPT_STYLE="paper"

!define DOC_NAME        "Wie ich mit Perl Apache und thttpd erschlug"
!define DOC_AUTHOR      "Marc Lehmann <pcg@goof.com>"
!build_title

H1: Ein reißerischer Titel

Ja, theatralisch war ich schon immer ;)

H2: Das Problem, das es zu lösen galt

Wie bei allen meiner Programme und Module, stand am Anfang ein
Problem: Ich hatte Festplatten. Damals grooose Festplatten
(insgesamt 320Gb). Mit Dateien drauf. Groooosen Dateien. Beliiiebten
Dateien. Filme! Animes, um genau zu sein.

Und weil man so etwas nur sehr schwer bekommt, dachte ich mir: packe sie
auf einen Webserver und bring' sie unter das Volk.

Und da fingen die Probleme an: "beliebt" ist leicht
untertrieben. Innerhalb von fünf Tagen wuchs die Zahl der gleichzeitig
offenen Verbindungen von 100 (erster Tag) auf 700. Natürlich hatte ich
da schon längst von apache auf thttpd umgestellt. Einen Prozeß (oder
Thread, was das gleiche ist) pro Verbindung war indiskutabel (das war mir
schon vorher klar), ein Webserver wie thttpd, der alle Verbindungen in
einem Prozeß bedient, ist eine Notwendigkeit.

H2: Die Probleme mit thttpd

Schon nach kurzer Zeit stellte sich dann heraus, daß thttpd Bugs,
häßliche, zerstörerische Bugs, hatte. Ein solcher Bug war, daß thttpd
zum Fileserven mmap+write benutze. Bei Dateien, die 100-700MB gross
sind, ist der virtuelle Speicher schnell aufgebraucht, so daß mmap
fehlschlägt. thttpd reagiert darauf mit einem "500 Internal Error". Und
verloren. Da er den mmap-cache auch so einfach nicht wieder hergibt, macht
thttpd seine eigene Denial-of-Service attack...

Aber, ich bin ja ein kompetenter C-Programmierer (ah, wie ich das
hasse! C!), also habe ich thttpd umgeschrieben, so daß er auf read+write
zurückfällt bei grossen Dateien.

Danach ging es, wenn man "ging" als "korrekt, aber langsam" versteht. 7
Mbit ist nicht gerade berauschend (auf einem PC, unsere SGI von 1995 mit
13x4GB SCSI-Platten brachte es auf sage und schreibe 20MBit!).

H2: Warum neuschreiben in Perl schöner war

Es sollte klar sein, daß das vertreiben dieser Filme nicht legal
ist. Tatsächlich gibt es eine Art ungeschriebene Übereinkunft zwischen
den japanischen Firmen und "Anbietern" wie mir: solange ein Film/Serie
ausserhalb Japans nicht lizensiert wurde, wird das kopieren geduldet,
da es ja einen Markt schafft (zwischen Lizensierung und Verkauf liegen
manchmal Jahre). Zudem steckt in den Untertitelungen von Fans auch viel
Arbeit (manche Firmen kaufen die Rechte der Untertitelungen von den Fans
oder schreiben mir, wenn eine Serie lizensiert wird, so daß ich sie
sperren kann).

Ich lege "ausserhalb Japans" etwas inkorrekt aus als: "wenn
in Land X keine Lizenz bekannt ist, dürfen Leute aus Land X
downloaden". Also muss ich irgendwie das Land feststellen, am besten
über whois-Anfragen. Letzteres ist ein schwieriges Problem (da ARIN, die
amerikanische IP-Addressen-"Registry", leider ein völlig chaotisches und
teilweise nicht parsebares Format hat, während RIPE (Europa) und APNIC
(Asien&Pazifik) ein standardisiertes Format verwenden) und müsste zudem
asynchron im Webserver stattfinden, etwas, was ich nicht in C machen
wollte.

Nebenbei wollte ich nicht glauben, daß der Rechner "nur" ca. 7Mbit
liefern konnte, in Perl müsste man doch mehr Leistung erreichen.

H1: Der Webserver - und Coro

"Zufällig" hatte ich eine Woche vor dieser Erkenntnis das Coro-Modul in
einer benutzbaren Form fertiggestellt. Die Stärke von Coro ist weniger
Effizienz oder Geschwindigkeit der Programme, sondern die Effizienz und
Geschwindigkeit, mit der Programme geschrieben werden können.

In weniger als einer Stunde hatte ich einen HTTP/1.0-Webserver,
der virtual hosts, nph-cgi und byte-ranges (wichtig fürs resumes)
unterstützte. In 367 Zeilen (ist als Beispiel eg/myhttpd in der
Coro-Distribution).

H1: Das Programm

Wie jeder andere "forkende" Server, erzeugt auch dieser Webserver eine Listen-Socket
und wartet auf Verbindungen:

!block perl
 my $port = new Coro::Socket
         LocalAddr => $SERVER_HOST,
         LocalPort => $SERVER_PORT,
         ReuseAddr => 1,
         Listen => 1,
    or die "unable to start server";

 my $connections = new Coro::Semaphore $MAX_CONNECTS;

 # Starte den "Accept-Prozeß"
 async {
    slog 1, "accepting connections";
    while () {
       $connections->down;
       async {
          $_[0] or return; # accept liefert manchmal undef
          eval { conn->new($_[0])->handle };
          close $_[0];
          slog 1, "$@" if $@ && !ref $@;
          $connections->up;
       } $port->accept;
    }
 };

 # Springe in die Event-Hauptschleife
 loop;
!endblock

Das Coro::Socket-Modul hat (ungefähr) die gleiche Bedienung und Semantik
wie IO::Socket::INET, der Aufruf ist also nicht neues.

Der nächste Abschnitt erzeugt eine Coro::Semaphore. Jedesmal, bevor eine
Verbindung 'accepted' wird, wird diese Semaphore gelockt und erst wieder
freigegeben, wenn die Socket wieder geschlossen wird. Dadurch wird die
Zahl der offenen Filehandles effektiv begrenzt, was, zumindest bei meinem
Server, dringend notwendig war (1000-2000 Verbindungen).

Die Schleife um den C<accept>-Aufruf besteht im wesentlichen aus:

!block perl
 async {
    eval { ... Verbindung behandeln ...};
 } $port->accept;
!endblock

Das muß man rückwärts lesen, denn der Aufruf von C<async> kann erst
stattfinden, wenn alle Argumente vollständig sind, und C<$port->accept>
kann eine sehr lange Zeit dauern, wenn keine Verbindungen aufgebaut
werden. Wenn C<accept> zurückkehrt, wird eine neue Coroutine erzeugt.

Die Klasse C<conn> implementiert ein "Verbindungsobjekt", C<handle>
verarbeitet die Anfragen.

H2: Lesen des HTTP-Headers

Ein HTTP-Header besteht aus mehreren (nichtleeren) Zeilen, gefolgt von
einer leeren Zeile. Ein idealer Job für C<$/>, aber in Programmen mit
Coroutinen ist C<$/> gefährlich, da die Variable von allen Coroutinen
gemeinsam benutzt wird.

Da dies nur problematisch bei Coro::Handle ist (normaler I/O blockiert den
Prozeß, ein C<local $/> reicht also), besitzt die C<readline>-Methode ein
optionales zweites Argument - den effektiven Wert von C<$/>.

!block perl
      # Lese den HTTP-Request
      $fh->timeout($::REQ_TIMEOUT);
      my $req = $fh->readline("\015\012\015\012");
      $fh->timeout($::RES_TIMEOUT);
   
      defined $req or
         $self->err(408, "request timeout");

      $req =~ /^(?:\015\012)?
                (GET|HEAD) \040+
                ([^\040]+) \040+
                HTTP\/([0-9]+\.[0-9]+)
                \015\012/gx
         or $self->err(403, "method not allowed", { Allow => "GET,HEAD" });
      
      $2 >= 2
         or $self->err(506, "http protocol version not supported");

      $self->{method} = $1;
      $self->{uri} = $2;
!endblock

C<readline> liefert den {{ganzen}} Request-Header, die Regex parsed
nur die erste Zeile (eine Leerzeile am Anfang stammt evt. noch von
einem kaputten vorherigen POST-Request. Kann ohne Keep-Alive zwar nicht
passieren, aber falls persistente Connections jemals implementiert werden
(sie wurden es), ist es besser, wenn der Rest damit klarkommt).

Bei dieser (und der folgenden) Regex wurde auf Geschwindigkeit
geachtet: Im Normalfall (kein Syntaxfehler) ist das Parsen linear, d.h.
keine komplizierten Alternativen, kein non-greedy-modifier (?).

Die Methode C<err> (um etwas abzuschweifen) ist der General-Abbruch. Sie gibt
eine absolut primitive Fehlerseite aus und ruft dann:

!block perl
   die bless {}, err::;
!endblock

... auf. C<err> ist eine echte Exception-Klasse, nur eben vollkommen leer ;) Dadurch wird
auch die folgende Zeile im Hauptprogramm klar:

!block perl
   slog 1, "$@" if $@ && !ref $@;
!endblock

Zurück zum Header-Parsen:

!block perl
   # Parse die Header
   {
      my (%hdr, $h, $v);

      $hdr{lc $1} .= ",$2"
         while $req =~ /\G
               ([^:\000-\040]+):
               [\008\040]*
               ((?: [^\015\012]+ | \015\012[\008\040] )*)
               \015\012
            /gxc;

      $req =~ /\G\015\012$/
         or $self->err(400, "bad request");

      $self->{h}{$h} = substr $v, 1
         while ($h, $v) = each %hdr;
   }

   $self->{server_port} = $self->{h}{host} =~ s/:([0-9]+)$// ? $1 : 80;
!endblock

Da HTTP-Header case-insensitive sind, Perl das von Haus aus aber
nicht unterstützt, wird alle Header (z.B. "Content-Length") in
Kleinbuchstaben gespeichert ("content-length"). Die Regex in der Schleife
ist meines Wissens nach vollkommen korrekt und ließe sich auch auf
andere RFC-2822-Header anwenden (News, Mail, ...). Auch hier wurde auf
Geschwindgkeit geachtet.

Der einfache (aber falsche) Weg wäre, den Kopf in Zeilen zu zerlegen
und jede Zeile als Header betrachten. RFC2822-Header sind jedoch
mehrzeilig. Für Perl jedoch kein Problem: durch den g und den c-Modifier
und das \G am Anfang der Regex parsed Perl genau dort weiter, wo die
vorherige Regex aufgehört hat.

Die while-Schleife hört auf, sobald der Header zu Ende ist oder ein
illegaler Header auftaucht. Das prüft die nächste Zeile, denn nach dem
Header sollte eine einzelne, leere Zeile folgen.

Die folgende Schleife kopiert den Header in den Hash C<$self->{h}>.

Hier würde ich mich Fragen, was denn das C<.= ",$2"> und das C<substr $v,
1> da zu suchen haben. Nun, manche Header können mehrfach vorkommen (tun
dies auch), und das ist so ungefähr gleichwertig mit einem Header, in dem
mehrere durch Komma getrennte Werte vorkommen. Das steht auch in C<%hdr>,
mit einem "," am Anfang, was vom C<substr> weggeschnitten wird.

In neueren Perl-Versionen (5.8 ;) geht das (dank Value-Sharing) mit einem:

!block perl
   $_ = substr $_, 1 for values %hdr;
!endblock

Aber ich bin ja portabel...

Jetzt muß der Request bearbeitet werden:

!block perl
   $self->map_uri;
   $self->respond;
!endblock

Ok, nicht sehr beeindruckend. Hier das wichtigste von C<map_uri>:

!block perl
   my $uri = $self->{uri};

   # mach aus der uri was pfad-ähnliches
   $uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
   $uri =~ s%//+%/%g;
   $uri =~ s%/\.(?=/|$)%%g;
   1 while $uri =~ s%/[^/]+/\.\.(?=/|$)%%;

   $uri =~ m%^/?\.\.(?=/|$)%
      and $self->err(400, "bad request");

   $self->{name} = $uri;

   # now do the path mapping
   $self->{path} = "$::DOCROOT/$host$uri";
!endblock

Die vielen Regexes dienen dazu, "%xx", ".." und ähnliches in der URI aufzulösen. Am Ende sollte
nirgendwo mehr ein ".." vorkommen, sonst haben wir ein Problem a'la Microsoft:

!block perl
213.114.180.157 - - [11/Dec/2001:04:44:44 +0100] "GET /msadc/..%255c../..%255c../..%255c/..%c1%1c../..%c1%1c../..%c1%1c../winnt/system32/cmd.exe?/c+dir HTTP/1.0" 404 265
213.114.180.157 - - [11/Dec/2001:04:44:44 +0100] "GET /scripts/..%c1%1c../winnt/system32/cmd.exe?/c+dir HTTP/1.0" 404 231
!endblock

(ein tail -f auf ein beliebiges accesslog zu einer beliebigen Zeit
reicht vollkommen aus, um sowas zu finden. Man beachte, daß Microsoft
Zugriffschecks und ähnliches macht, {{bevor}} die URI geparsed
wird. Hätten sie es blind nach Standard gemacht, wäre der Code
sicherlich einfacher. Ach ja, der Hack hätte auch nicht funktioniert,
aber Microsoft macht's gerne etwas besser als es im Standard steht. Das
nennt man dann "Feature", glaube ich).

C<respond> ist auch nicht weiter interessant:

!block perl
   my $path = $self->{path};
   
   stat $path
      or $self->err(404, "not found");
      
   # ich glaube nicht, daß ich mir den nächsten Kommentar
   # hätte verkneifen können ;)
   # idiotic netscape sends idiotic headers AGAIN
   my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
             ? str2time $1 : 0;

  if (-d _ && -r _) {
      # Verzeichnis
      if ($path !~ /\/$/) {
         # Redirect erzeugen, um einen "/" am Ende zu bekommen
         # (macht sich besser ;)
         $self->err(301, "moved permanently", { Location =>  "http://".$self->server_hostport."$self->{uri}/" });
      } else {
         ... verzeichnis anzeigen
      }
   } elsif (-f _ && -r _) {
      -x _ and $self->err(403, "forbidden");

      $self->handle_file($queue_file);
   } else {
      $self->err(404, "not found");
   }
!endblock

H1: Asynchrone Ein-/Ausgabe, und warum Linux Müll ist

Eigentlich wäre jetzt C<handle_file> an der Reihe (oder die Werbepause,
machen wir zuerst die Werbepause).

Ich habe den Server geschrieben, um mehr Möglichkeiten und mehr
Freiheiten zu erhalten, mit dem Server herumzuexperimentieren.

Er war nicht schneller als thttpd. Ein C<strace> (ist fast immer sehr
lehrreich) zeigte, daß der Serevr (wie thttpd) ca 90% der Realzeit im
C<read>-syscall steckte.

Das ist auch logisch, wenn mans weiß: bei, sagen wir, 800 gleichzeitigen
Downloads kann man sich den read-ahead sonstwo hinstecken: er findet nicht
statt (außer in Linux, aber damit rechne ich gleich ab). Deshalb ist
jeder Zugriff auch ein Seek (minimum), und dauert somit mindestens 0.01s,
manchmal auch doppelt oder dreimal so lang. Und in 0.01s könnte ich schon
mehr als 100kb/s ins Internet blasen (100Mbit Netzwerkkarte).

Leider kann der Webserver in dieser Zeit auch nichts anderes tun, er steht
ja und wartet auf die Platte, obwohl er doch so viele andere Filehandles
zu bedienen hätte.

Viele Threads würden hier helfen (nein, falsch, aber dazu komme ich
gleich), und viele Java-Anhänger kennen nur den einen Weg (klar, die
Sprache {{kann}} es ja auch nicht anders, und wenn man nur einen Hammer
hat, sieht eben alles wie ein Nagel aus), aber die wahre Lösung heißt:

"Asynchrone Ein-/Ausgabe"

Natürlich kann Linux das nicht. Noch nicht. Aber man hat ja Threads, was
ja (Java zeigt es uns!) dasselbe ist, aber Perl kann leider keine Threads
(nein, wirklich, Perl kann keine Threads).

Also muss XS her. Dank Linux kann ich auch einfach gcc verlangen, und dank gcc
kann ich closures benutzen, und dank closures kann ich errno ohne Assembler
abfangen, und wenn man diesen Horror in ein Modul packt, merkts auch keiner:

!block perl
   #undef errno
   #include <asm/unistd.h>

   static int
   aio_proc(void *thr_arg)
   {
     aio_thread *thr = thr_arg;
     aio_req req;
     int errno;

     /* we rely on gcc's ability to create closures. */
     _syscall3(int,lseek,int,fd,off_t,offset,int,whence)
     _syscall3(int,read,int,fd,char *,buf,off_t,count)
     _syscall3(int,write,int,fd,char *,buf,off_t,count)
     _syscall3(int,open,char *,pathname,int,flags,mode_t,mode)
     _syscall1(int,close,int,fd)

     sigprocmask (SIG_SETMASK, &fullsigset, 0);

     /* then loop */
     while (read (reqpipe[0], (void *)&req, sizeof (req)) == sizeof (req))
       {
         req->thread = thr;
         errno = 0;

         if (req->type == REQ_READ || req->type == REQ_WRITE)
           {
             if (lseek (req->fd, req->offset, SEEK_SET) == req->offset)
               {
                 if (req->type == REQ_READ)
                   req->result = read (req->fd, req->dataptr, req->length);
                 else
                   req->result = write(req->fd, req->dataptr, req->length);
               }
           }
         else if (req->type == REQ_OPEN)
           ...

         req->errorno = errno;
         write (respipe[1], (void *)&req, sizeof (req));
       }

     return 0;
   }
!endblock

Ja, dies ist kein Perl, sondern C (aber nicht ANSI), aber dieses Jahr soll
auf dem Perl-Workshop ja mehr praktisches gezeigt werden und, so leid es
mir tut, hier kommt die Wirklichkeit angerollt.

Aber etwas langsamer: Das Linux-AIO-Modul ist relativ klein (C ist eben
umständlich). Es startet im wesentlichen einen (oder mehrere) Thread(s),
die in einer Schleife auf Anfragen (von Perl) warten, diese abarbeiten und
das Ergebnis zurückmelden. Da dies in einem Thread passiert, kann der
eigentliche Webserver weiterarbeiten.

Als Anfragen kann man read() und write() stellen, aber auch open(), denn
open kann sehr lange dauern. Eigentlich sollte man auch stat() einbauen,
aber dazu bin ich noch nicht gekommen.

Die Anwendung ist recht einfach, statt einem:

!block perl
   sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
      or last;
!endblock

(C<last> springt aus einer hier nicht gezeigten Schleife), schreibt man "einfach":

!block perl
   my $current = $Coro::current;
   my $r;

   aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),
            $buf, 0, sub {
               $r = $_[0];
               $current->ready;
            });
   &Coro::schedule;
   last unless $r;
!endblock

Ok, gelogen, es sieht umständlich und langsam aus. Es ist auch
umständlich und langsam. Es ist genau so, wie ich es damals zum
Testen geschrieben hatte, ohne Abstraktion (IO::Handle => Coro::Handle
=> Linux::AIO::Handle??). Es sieht auch heute noch so aus, denn es
funktioniert und war bisher nicht das (gedankliche) Nadelöhr.

C<aio_read> besitzt die gleichen Argumente wie C<sysread> und dann noch
eins (den File-Offset) und dann noch eins (eine Code-Referenz, die
aufgerufen wird, wenn die Daten gelesen wurden, es heißt ja nicht umsonst
{{asynchrone}} Ein-/Ausgabe) und dann war's das aber.

Nachdem der Lesevorgang "in Auftrag" gegeben wurde, legt sich die
Coroutine schlafen: C<schedule> kehrt nicht von sich aus zurück.

Der Callback speichert die Anzahl der gelesenen Byte ($! ist übrigens
korrekt gesetzt) in C<$r> und weckt die Coroutine wieder auf, die -
früher oder später - nach C<schedule> weiterläuft ($! ist dann
natürlich nicht mehr korrekt ;).

H2: Linux...

Jetzt kommts. AIO brachte den Webserver sofort auf 20Mbit. Toll, so schnell war
er noch nie. Aber irgendwie... irgendwie... war das wenig, denn über "Kunden"
konnte sich der Webserver nicht beklagen.

Was habe ich nach der Ursache gesucht.

Und gesucht.

Naja, vielleicht ist IDE/ATA/PC-Hardware einfach Müll, dachte ich....

Und schließlich habe ich bemerkt, daß zwar ca. 5MB/s von den Festplatten
gelesen wurde, aber irgendwie nur wenig mehr als 2MB/s im Netz landeten.
Merkwürdig.

Nach über einer Woche(!) Diskussion auf der Kernel-Liste war das Problem
gefunden:  Read-Ahead. Was normalerweise absolut notwendig ist, war hier
Fatal: der Webserver liest (sagen wir mal) 256Kbyte, der Kernel hängt
128Kbyte Read-Ahead dran und 600 Filehandles später wird der Speicher
knapp und der Kernel schmeißt weg - genau, die Read-Ahead-Daten.

Gut, es ließ sich fixen (falls man "abschalten des Read-Ahead" so nennen
mag). Ich hatte noch ein anderes Problem: Zehn parallele Threads (und
damit ca. 10 parallele Read-Requests) sollten es dem Kernel erlauben,
wesentlich effizienter über die Plattenoberfläche zu Rasen als
einer. Leider braucht ein einzelner Read-Request, dann nicht 10 (oder
9 mal, wie ich gehofft hätte) so lange, wie bei einem Thread sondern
schlichtweg 80 oder 90 mal so lange. In Mbit: 7. Irgendwie ging dieses
Problem auf der Kernel-Liste unter, und ergo benutze ich nur einen
Thread. Sieht im Prozesslisting eh' viel hübscher aus, und ich predige ja
sowieso, das Threads böse sind.

Und wenn die FreeBSD-Leute sich jetzt toll fühlen: wenn ich unter FreeBSD
auf einen Event (kqueue) warte, bleiben alle Threads stehen. Yeah ;)

(Aber die VM von FreeBSD ist geil!)

H1: Back to the roots...

... Perl!

Gut. Ich war schließlich bei ca. 70Mbit (immer pro Sekunde, übrigens ;)
angekommen. Die restlichen 10Mbit (am Wochenende sogar 20!) waren ganz
einfach zu erreichen: Diesmal waren es {{wirklich}} die Festplatten: Wer
viel Platz braucht (und kein Geld dafür ausgeben will) landet
zwangsläufig bei 80GB-Maxtor-Platten. Genau, die langsamen.

Eine Beschränkung auf (willkürliche) 400 Datenverbindungen gleichzeitig
(also eine Art "Download-Queue") brachte diesen erhofften Durchbruch - in
nur zwei Zeilen:

!block perl
 # Am Programmanfang
 my $transfers = new Coro::Semaphore 400;

 # In handle_file, nach dem der HTTP-Response-Header
 # geschickt wurde:
 my $guard = $transfers->guard;
!endblock

C<guard> ist ähnlich wie C<down>, liefert aber ein Objekt, das in der
C<DESTROY>-Methode ein C<up> macht - also sobald sicht die Funktion
beendet, abgebrochen wird, abstürzt....

H2: Ach ja, C<handle_file> und die bösen Windows-User

Nun war der Server schnell und es wurde Zeit, den Missbrauch zu
bekämpfen. Missbrauch hauptsächlich in Form von Windows. Bei 400
Download-Slots ist man manchmal schon überrascht, daß 60 davon nicht
nur dieselbe Datei herunterladen, sondern auch noch von derselben
IP-Addresse stammen! Gut, 60 ist eher selten, aber Downloadmanager (für
nicht-Windows-User: sowas wie wget), die standardmässig 4 (8, 10)
Verbindungen aufmachen und dies noch nicht einmal abschalten können, sind
unter Windows sehr verbreitet. Wozu Hirn, wenn man dafür Windows hat ;)

Nun denn, bei anderen Servern mag das egal sein (dafür gibts bei Apache
ja MaxClients, am besten gleich auf 10000 setzen...), aber Bandbreite ist
kostbar, und die sollte gerecht verteilt werden.

Was für ein Glück, daß ich einen Single-Process-Webserver geschrieben habe,
denn um sogenannte "Segmented Downloads" zu verbieten, muss ich mir nur am
Anfang jedes Requests die URI merken:

!block perl
   weaken (local $uri{$self->{remote_id}}{$self->{uri}}{$self*1} = $self);
!endblock

Das sieht kompliziert aus, ist es aber nicht. Wenn man für
C<$self->{remote_id}> "Client-ID" schreibt, für C<$self->{uri}> URI,
sieht es so aus (C<$self*1> verbraucht etwas weniger Speicherplatz als
C<$self>).

!block perl
   weaken (
      local $uri{Client-ID} {URI} {$self} = $self
   );
!endblock

Die Client-ID ist normalerweise die IP-Addresse (bei Proxies ausserdem
die "dahinterliegende"). In C<%uri> wird also jede Verbindung unter ihrer
Client-ID und URI gespeichert. Das C<local> sorgt dafür, daß dieser
Vermerk beim Request-Ende wird entfernt wird. Das C<weaken> (aus dem Modul
C<Convert::Scalar>, C<Scalar::Util> oder C<WeakRef>) stellt sicher, daß
die gespeicherte Referenz das Objekt nicht am DESTROY hindert.

Wenn die Funktion C<handle_file> einen potentiellen "Segmented Download"
erkennt (und zwar daran, daß nur ein Teil der Datei übertragen werden
soll) überprüft sie die Zahl der vorhandenen Verbindungen:

!block perl
   if (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
      # fehler
!endblock

Eine Zeitlang (perl-5.7.2 bis 5.7.2-devel-10000irgendwas) ging das
sogar ohne C<keys>, aber das alte (nutzlose) Verhalten von Hashes im
skalaren Kontext wurde anscheinend doch irgendwo benutzt und wurde wieder
hergestellt.

In der Praxis kann es passieren, daß ein Download abgebrochen wurde und der
Retry-Request am Server ankommt, bevor der alte Request beendet wurde. Um
falsches Alarmschlagen zu verhindern, wartet der Server ca. 15s, bevor er
Massnahmen ergreift:

!block perl
   # check for segmented downloads
   if ($l && $::NO_SEGMENTED) {
      my $timeout = $::NOW + 15;
      while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
         if ($timeout <= $::NOW) {
            $self->block($::BLOCKTIME, "segmented downloads are forbidden");
         } else {
            $httpevent->wait;
         }
      }
   }
!endblock

Die Methode C<block> macht sich ein kleines Vermerkle, daß für die
nächsten zwei Stunden (z.B.) jeden Download verhindert - eine sehr
effektive Erziehungsmethode, wenn man sich das leisten kann...

H2: Eine Shell zum Debuggen - und mehr

Ein Webserver, in den man "hineintelnetten" kann und während der Laufzeit
debuggen - das ist schon was feines. Normalerweise ist sowas zu aufwendig,
aber in Perl:

!block perl
   my $port = new Coro::Socket LocalPort => $CMDSHELL_PORT, ReuseAddr => 1, Listen => 1
      or die "unable to bind cmdshell port: $!"; 
         
   async {  
      async \&shell, scalar $port->accept
         while 1;
   };       
!endblock

So einfach kann es sein, einen Server zu programmieren: Listening-Port
erzeugen und bei jedem C<accept> eine Coroutine starten:

!block perl
   sub shell { 
      my $fh = shift;
      while (defined (print $fh "cmd> "), $_ = <$fh>) {
         s/\015?\012$//;
            if ($cmd eq "quit") {
               print $fh "bye bye.\n";#d#
               last;
            } elsif ($cmd eq "squit") {
               print $fh "server quit.\n";#d#
               Event::unloop;
               last;
            } elsif ($cmd eq "print") { 
               my @res = eval $_;
               print $fh "eval: $@\n" if $@;
               print $fh "RES = ", (join " : ", @res), "\n";
            } els....
            }
      }
   }
!endblock

Das liest so lange Kommandos, bis der Client die Verbindung dichtmacht
({{C:<$fh>}} liefert C<undef>), der Server beendet wird (C<Event::unloop>
spricht aus der Hauptschleife), oder "quit" eingegegen wird.

Das wichtigste Komamndo ist C<print>. Damit führe ich häufig
Server-Upgrades im Betrieb durch:

!block perl
cmd> print do 'access.pl'
RES = 1
cmd> print $VERSION = 0.711
RES = 1
!endblock

Dies ist das - für mich - beeindruckendste an diesem Webserver.

H1: PÖRL

Wenn es in den Tagungsband passt, so ist hier der Quellcode von
C<httpd.pl>, der den Kern des Webservers implementiert. Dem Coro-Modul
selbst liegt eine ältere "general purpose"-Version als C<eg/myhttpd> bei.

!block perl
use Coro;
use Coro::Semaphore;
use Coro::Event;
use Coro::Socket;
use Coro::Signal;

use HTTP::Date;
use POSIX ();

no utf8;
use bytes;

# at least on my machine, this thingy serves files
# quite a bit faster than apache, ;)
# and quite a bit slower than thttpd :(

$SIG{PIPE} = 'IGNORE';

our $accesslog;
our $errorlog;

our $NOW;
our $HTTP_NOW;

Event->timer(interval => 1, hard => 1, cb => sub {
   $NOW = time;
   $HTTP_NOW = time2str $NOW;
})->now;

if ($ERROR_LOG) {
   use IO::Handle;
   open $errorlog, ">>$ERROR_LOG"
     or die "$ERROR_LOG: $!";
   $errorlog->autoflush(1);
}

if ($ACCESS_LOG) {
   use IO::Handle;
   open $accesslog, ">>$ACCESS_LOG"
     or die "$ACCESS_LOG: $!";
   $accesslog->autoflush(1);
}

sub slog {
   my $level = shift;
   my $format = shift;
   my $NOW = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $::NOW);
   printf "$NOW: $format\n", @_;
   printf $errorlog "$NOW: $format\n", @_ if $errorlog;
}

our $connections = new Coro::Semaphore $MAX_CONNECTS || 250;
our $httpevent   = new Coro::Signal;

our $queue_file  = new transferqueue $MAX_TRANSFERS;
our $queue_index = new transferqueue 10;

my @newcons;
my @pool;

# one "execution thread"
sub handler {
   while () {
      if (@newcons) {
         eval {
            conn->new(@{pop @newcons})->handle;
         };
         slog 1, "$@" if $@ && !ref $@;

         $httpevent->broadcast; # only for testing, but doesn't matter much

         $connections->up;
      } else {
         last if @pool >= $MAX_POOL;
         push @pool, $Coro::current;
         schedule;
      }
   }
}

sub listen_on {
   my $listen = $_[0];

   push @listen_sockets, $listen;

   # the "main thread"
   async {
      slog 1, "accepting connections";
      while () {
         $connections->down;
         push @newcons, [$listen->accept];
         #slog 3, "accepted @$connections ".scalar(@pool);
         if (@pool) {
            (pop @pool)->ready;
         } else {
            async \&handler;
         }

      }
   };
}

my $http_port = new Coro::Socket
        LocalAddr => $SERVER_HOST,
        LocalPort => $SERVER_PORT,
        ReuseAddr => 1,
        Listen => 50,
   or die "unable to start server";

listen_on $http_port;

if ($SERVER_PORT2) {
   my $http_port = new Coro::Socket
           LocalAddr => $SERVER_HOST,
           LocalPort => $SERVER_PORT2,
           ReuseAddr => 1,
           Listen => 50,
      or die "unable to start server";

   listen_on $http_port;
}

package conn;

use Socket;
use HTTP::Date;
use Convert::Scalar 'weaken';
use Linux::AIO;

Linux::AIO::min_parallel $::AIO_PARALLEL;

Event->io(fd => Linux::AIO::poll_fileno,
          poll => 'r', async => 1,
          cb => \&Linux::AIO::poll_cb);

our %conn; # $conn{ip}{self} => connobj
our %uri;  # $uri{ip}{uri}{self}
our %blocked;
our %mimetype;

sub read_mimetypes {
   local *M;
   if (open M, "<mime_types") {
      while (<M>) {
         if (/^([^#]\S+)\t+(\S+)$/) {
            $mimetype{lc $1} = $2;
         }
      }
   } else {
      print "cannot open mime_types\n";
   }
}

read_mimetypes;

sub new {
   my $class = shift;
   my $fh = shift;
   my $peername = shift;
   my $self = bless { fh => $fh }, $class;
   my (undef, $iaddr) = unpack_sockaddr_in $peername
      or $self->err(500, "unable to decode peername");

   $self->{remote_addr} =
      $self->{remote_id} = inet_ntoa $iaddr;

   $self->{time} = $::NOW;

   weaken ($Coro::current->{conn} = $self);

   $::conns++;
   $::maxconns = $::conns if $::conns > $::maxconns;

   $self;
}

sub DESTROY {
   #my $self = shift;
   $::conns--;
}

sub slog {
   my $self = shift;
   main::slog($_[0], "$self->{remote_id}> $_[1]");
}

sub response {
   my ($self, $code, $msg, $hdr, $content) = @_;
   my $res = "HTTP/1.1 $code $msg\015\012";

   if (exists $hdr->{Connection}) {
      if ($hdr->{Connection} =~ /close/) {
         $self->{h}{connection} = "close"
      }
   } else {
      if ($self->{version} < 1.1) {
         if ($self->{h}{connection} =~ /keep-alive/i) {
            $hdr->{Connection} = "Keep-Alive";
         } else {
            $self->{h}{connection} = "close"
         }
      }
   }

   $res .= "Date: $HTTP_NOW\015\012";

   while (my ($h, $v) = each %$hdr) {
      $res .= "$h: $v\015\012"
   }
   $res .= "\015\012";

   $res .= $content if defined $content and $self->{method} ne "HEAD";

   my $log = (POSIX::strftime "%Y-%m-%d %H:%M:%S", gmtime $NOW).
             " $self->{remote_id} \"$self->{uri}\" $code ".$hdr->{"Content-Length"}.
             " \"$self->{h}{referer}\"\n";

   print $accesslog $log if $accesslog;
   print STDERR $log;

   $self->{written} +=
      print {$self->{fh}} $res;
}

sub err {
   my $self = shift;
   my ($code, $msg, $hdr, $content) = @_;

   unless (defined $content) {
      $content = "$code $msg\n";
      $hdr->{"Content-Type"} = "text/plain";
      $hdr->{"Content-Length"} = length $content;
   }
   $hdr->{"Connection"} = "close";

   $self->response($code, $msg, $hdr, $content);

   die bless {}, err::;
}

sub handle {
   my $self = shift;
   my $fh = $self->{fh};

   my $host;

   $fh->timeout($::REQ_TIMEOUT);
   while() {
      $self->{reqs}++;

      # read request and parse first line
      my $req = $fh->readline("\015\012\015\012");

      unless (defined $req) {
         if (exists $self->{version}) {
            last;
         } else {
            $self->err(408, "request timeout");
         }
      }

      $self->{h} = {};

      $fh->timeout($::RES_TIMEOUT);

      $req =~ /^(?:\015\012)?
                (GET|HEAD) \040+
                ([^\040]+) \040+
                HTTP\/([0-9]+\.[0-9]+)
                \015\012/gx
         or $self->err(405, "method not allowed", { Allow => "GET,HEAD" });

      $self->{method} = $1;
      $self->{uri} = $2;
      $self->{version} = $3;

      $3 =~ /^1\./
         or $self->err(506, "http protocol version $3 not supported");

      # parse headers
      {
         my (%hdr, $h, $v);

         $hdr{lc $1} .= ",$2"
            while $req =~ /\G
                  ([^:\000-\040]+):
                  [\008\040]*
                  ((?: [^\015\012]+ | \015\012[\008\040] )*)
                  \015\012
               /gxc;

         $req =~ /\G\015\012$/
            or $self->err(400, "bad request");

         $self->{h}{$h} = substr $v, 1
            while ($h, $v) = each %hdr;
      }

      # remote id should be unique per user
      my $id = $self->{remote_addr};

      if (exists $self->{h}{"client-ip"}) {
         $id .= "[".$self->{h}{"client-ip"}."]";
      } elsif (exists $self->{h}{"x-forwarded-for"}) {
         $id .= "[".$self->{h}{"x-forwarded-for"}."]";
      }

      $self->{remote_id} = $id;

      weaken (local $conn{$id}{$self*1} = $self);

      if ($blocked{$id}) {
         $self->err_blocked
            if $blocked{$id}[0] > $::NOW;

         delete $blocked{$id};
      }

      # find out server name and port
      if ($self->{uri} =~ s/^http:\/\/([^\/?#]*)//i) {
         $host = $1;
      } else {
         $host = $self->{h}{host};
      }

      if (defined $host) {
         $self->{server_port} = $host =~ s/:([0-9]+)$// ? $1 : 80;
      } else {
         ($self->{server_port}, $host)
            = unpack_sockaddr_in $self->{fh}->sockname
               or $self->err(500, "unable to get socket name");
         $host = inet_ntoa $host;
      }

      $self->{server_name} = $host;

      weaken (local $uri{$id}{$self->{uri}}{$self*1} = $self);

      eval {
         $self->map_uri;
         $self->respond;
      };

      die if $@ && !ref $@;

      last if $self->{h}{connection} =~ /close/i;

      $httpevent->broadcast;

      $fh->timeout($::PER_TIMEOUT);
   }
}

sub block {
   my $self = shift;

   $blocked{$self->{remote_id}} = [$::NOW + $_[0], $_[1]];
   $self->slog(2, "blocked ip $self->{remote_id}");
   $self->err_blocked;
}

# uri => path mapping
sub map_uri {
   my $self = shift;
   my $host = $self->{server_name};
   my $uri = $self->{uri};

   # some massaging, also makes it more secure
   $uri =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr hex $1/ge;
   $uri =~ s%//+%/%g;
   $uri =~ s%/\.(?=/|$)%%g;
   1 while $uri =~ s%/[^/]+/\.\.(?=/|$)%%;

   $uri =~ m%^/?\.\.(?=/|$)%
      and $self->err(400, "bad request");

   $self->{name} = $uri;

   # now do the path mapping
   $self->{path} = "$::DOCROOT/$host$uri";

   $self->access_check;
}

sub _cgi {
   my $self = shift;
   my $path = shift;
   my $fh;

   # no two-way xxx supported
   if (0 == fork) {
      open STDOUT, ">&".fileno($self->{fh});
      if (chdir $::DOCROOT) {
         $ENV{SERVER_SOFTWARE} = "thttpd-myhttpd"; # we are thttpd-alike
         $ENV{HTTP_HOST}       = $self->{server_name};
         $ENV{HTTP_PORT}       = $self->{server_port};
         $ENV{SCRIPT_NAME}     = $self->{name};
         exec $path;
      }
      Coro::State::_exit(0);
   } else {
      die;
   }
}

sub server_hostport {
   $_[0]{server_port} == 80
      ? $_[0]{server_name}
      : "$_[0]{server_name}:$_[0]{server_port}";
}

sub respond {
   my $self = shift;
   my $path = $self->{path};

   if ($self->{name} =~ s%^/internal/([^/]+)%%) {
      if ($::internal{$1}) {
         $::internal{$1}->($self);
      } else {
         $self->err(404, "not found");
      }
   } else {

      stat $path
         or $self->err(404, "not found");

      $self->{stat} = [stat _];

      # idiotic netscape sends idiotic headers AGAIN
      my $ims = $self->{h}{"if-modified-since"} =~ /^([^;]+)/
                ? str2time $1 : 0;

      if (-d _ && -r _) {
         # directory
         if ($path !~ /\/$/) {
            # create a redirect to get the trailing "/"
            # we don't try to avoid the :80
            $self->err(301, "moved permanently", { Location =>  "http://".$self->server_hostport."$self->{uri}/" });
         } else {
            $ims < $self->{stat}[9]
               or $self->err(304, "not modified");

            if (-r "$path/index.html") {
               # replace directory "size" by index.html filesize
               $self->{stat} = [stat ($self->{path} .= "/index.html")];
               $self->handle_file($queue_index);
            } else {
               $self->handle_dir;
            }
         }
      } elsif (-f _ && -r _) {
         -x _ and $self->err(403, "forbidden");

         if (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
            my $timeout = $::NOW + 10;
            while (keys %{$conn{$self->{remote_id}}} > $::MAX_TRANSFERS_IP) {
               if ($timeout < $::NOW) {
                  $self->block($::BLOCKTIME, "too many connections");
               } else {
                  $httpevent->wait;
               }
            }
         }

         $self->handle_file($queue_file);
      } else {
         $self->err(404, "not found");
      }
   }
}

sub handle_dir {
   my $self = shift;
   my $idx = $self->diridx;

   $self->response(200, "ok",
         {
            "Content-Type"   => "text/html",
            "Content-Length" => length $idx,
            "Last-Modified"  => time2str ($self->{stat}[9]),
         },
         $idx);
}

sub handle_file {
   my ($self, $queue) = @_;
   my $length = $self->{stat}[7];
   my $hdr = {
      "Last-Modified"  => time2str ((stat _)[9]),
   };

   my @code = (200, "ok");
   my ($l, $h);

   if ($self->{h}{range} =~ /^bytes=(.*)$/) {
      for (split /,/, $1) {
         if (/^-(\d+)$/) {
            ($l, $h) = ($length - $1, $length - 1);
         } elsif (/^(\d+)-(\d*)$/) {
            ($l, $h) = ($1, ($2 ne "" || $2 >= $length) ? $2 : $length - 1);
         } else {
            ($l, $h) = (0, $length - 1);
            goto ignore;
         }
         goto satisfiable if $l >= 0 && $l < $length && $h >= 0 && $h >= $l;
      }
      $hdr->{"Content-Range"} = "bytes */$length";
      $hdr->{"Content-Length"} = $length;
      $self->err(416, "not satisfiable", $hdr, "");

satisfiable:
      # check for segmented downloads
      if ($l && $::NO_SEGMENTED) {
         my $timeout = $::NOW + 15;
         while (keys %{$uri{$self->{remote_id}}{$self->{uri}}} > 1) {
            if ($timeout <= $::NOW) {
               $self->block($::BLOCKTIME, "segmented downloads are forbidden");
               #$self->err_segmented_download;
            } else {
               $httpevent->wait;
            }
         }
      }

      $hdr->{"Content-Range"} = "bytes $l-$h/$length";
      @code = (206, "partial content");
      $length = $h - $l + 1;

ignore:
   } else {
      ($l, $h) = (0, $length - 1);
   }

   $self->{path} =~ /\.([^.]+)$/;
   $hdr->{"Content-Type"} = $mimetype{lc $1} || "application/octet-stream";
   $hdr->{"Content-Length"} = $length;

   $self->response(@code, $hdr, "");

   if ($self->{method} eq "GET") {
      $self->{time} = $::NOW;

      my $current = $Coro::current;

      my ($fh, $buf, $r);

      open $fh, "<", $self->{path}
         or die "$self->{path}: late open failure ($!)";

      $h -= $l - 1;

      if (0) { # !AIO
         if ($l) {
            sysseek $fh, $l, 0;
         }
      }
      
      my $transfer = $queue->start_transfer($h);
      my $locked;
      my $bufsize = $::WAIT_BUFSIZE; # initial buffer size

      while ($h > 0) {
         unless ($locked) {
            if ($locked ||= $transfer->try($::WAIT_INTERVAL)) {
               $bufsize = $::BUFSIZE;
               $self->{time} = $::NOW;
            }
         }

         if ($blocked{$self->{remote_id}}) {
            $self->{h}{connection} = "close";
            die bless {}, err::;
         }

         if (0) { # !AIO
            sysread $fh, $buf, $h > $bufsize ? $bufsize : $h
               or last;
         } else {
            aio_read($fh, $l, ($h > $bufsize ? $bufsize : $h),
                     $buf, 0, sub {
                        $r = $_[0];
                        Coro::ready($current);
                     });
            &Coro::schedule;
            last unless $r;
         }
         my $w = syswrite $self->{fh}, $buf
            or last;
         $::written += $w;
         $self->{written} += $w;
         $l += $r;
      }

      close $fh;
   }
}

1;
!endblock perl

A1: Module

- Coro (Coroutinen)
- Event (der Event-Standard, nur leider unmaintained)
- Linux::AIO (asynchrone Ein-/Ausgabe)
- Convert::Scalar (für C<weaken>)
- HTTP::Date (code-reuse made easy with CPAN, hat mir sicherlich 5 Minuten gespart)
- Date::Parse (siehe HTTP::Date, ich liebe CPAN ;)
- BerkeleyDB (Caching der Directory-Listings und WHOIS-Requests)


Revision:	1.2
Committed:	Wed Dec 26 13:47:07 2001 UTC (24 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.1:	+759 -21 lines
Log Message:	* empty log message *