!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 meinen Programmen und Modulen stand am Anfang ein
{{}}Problem: Ich hatte Festplatten. Damals groooße Festplatten
(insgesamt 320Gb). Mit Dateien drauf. Grooooßen Dateien. Beliiiebten
Dateien. Filme! Animes, um genau zu sein.

Und weil man so etwas nur sehr schwierig 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ß er
zum Fileserven mmap+write benutze. Bei Dateien, die 100-700MB groß
sind, ist der virtuelle Speicher schnell aufgebraucht, so dass 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 erfahrener C-Programmierer (ah, wie ich es hasse! C!
wie unelegant!), 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
außerhalb 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 dass 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, da ich
für jeden Client eine eigene Coroutine benutzen kann. Dadurch wird der
Code vereinfacht, da nicht mit Callbacks sondenr mit einer "linearen"
Programmstruktur gearbeitet werden kann.

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-Prozess"
 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 der
Hauptprozess die Verbindung 'accepted', lockt er diese Semaphore. Diese
wird erst wieder freigegeben, wenn die Socket wieder geschlossen wird. Das
begrenzt 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 muss 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
Prozess, ein C<local $/> reicht also), besitzt die C<readline>-Methode ein
optionales zweites Argument - den effektiven Wert von C<$/>.

!block perl
      # Lies 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
fehlerhaften vorherigen POST-Request. Das kann ohne Keep-Alive zwar nicht
passieren (nach jedem Request wird die Verbindung geschlossen), aber es
ist immer besser man baut für die Zukunft (inzwischen wurden persistente
Verbindungen implementiert).

Bei dieser (und der folgenden) Regex wurde auf Geschwindigkeit
geachtet: Im Normalfall (kein Syntaxfehler) ist das Parsen O(n), 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]+):
               [\010\040]*
               ((?: [^\015\012]+ | \015\012[\010\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, werden 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 setzt der Parser genau dort wieder auf, 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 äquivalent zu einem Header, in dem mehrere durch
Komma getrennte Werte vorkommen. Das steht auch in C<%hdr>, mit einem ","
am Anfang, was C<substr> abschneidet.

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

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 à 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, dass Microsoft
Zugriffschecks und Ähnliches macht, {{bevor}} die URI geparsed
wird. Wären sie blind dem Standard gefolgt, 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 kompliziert:

!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 ihm herumzuexperimentieren.

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

Das ist auch logisch, wenn man es weiß: bei rund 800 gleichzeitigen
Downloads kann man sich den read-ahead sparen: er findet nicht statt
(außer in Linux, aber dazu gleich). Deshalb ist jeder
Zugriff auch mindestens ein Seek, 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 (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"

Dabei werden Lesen- und Schreibanforderungen "asynchron" in Auftrag
gegeben: C<read()> muss solange warten, bis die Daten von der Festplatte
gelesen wurden. Ein asynchrones C<read> jehrt sofort zurück und
verständigt den Server asynchron, sobald die Daten im Speicher sind.

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 als Compiler einfach gcc
voraussetzen, und dank gcc kann ich Closures benutzen, und dank Closures
kann ich errno ohne Assembler abfangen. Das Problem ist, das ich einen
zweiten Thread starte und dort C<read> (u.a.) aufrufe, dieser Aufruf aber
die globale Variable C<errno> überschreibt. Damit dies nicht passiert,
deklariere ich eine lokale Variable C<errno> und definiere dann die
Systemaufrufe innerhalb der Funktion, d.h. statt der globalen Variablen
wird die lokale Variable C<errno> gesetzt.

Wenn man diesen Horror in ein Modul packt, merkt's 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 eines:

!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> sowie den
File-Offset und eine Code-Referenz, die aufgerufen wird, wenn die Daten
gelesen wurden, es heißt ja nicht umsonst {{asynchrone}} Ein-/Ausgabe.

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 er sich 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, dass zwar ca. 5MB/s von den Festplatten
gelesen wurde, aber 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 zehn-
(oder neunmal, 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 dafür ist die VM von FreeBSD viel besser, denn dort hätte ich
wahrscheinlich nicht die großen Probleme mti dem Read-Ahead gehabt...

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äßig 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, dass 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 außerdem
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 wieder entfernt wird. Das C<weaken> (aus dem Modul
C<Convert::Scalar>, C<Scalar::Util> oder C<WeakRef>) stellt sicher, dass
die gespeicherte Referenz das Objekt nicht am DESTROY hindert.

Wenn die Funktion C<handle_file> einen potenziellen "Segmented Download"
erkennt (und zwar daran, dass 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, dass 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
Maßnahmen 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, das 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 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" eingegeben 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)