unit Http;

{==========================================================}
{                                                          }
{  unit Http                           08/01/2003          }
{                                      Verze 1.2b          }
{                                                          }
{   Knihovna implementujici kostru HTTP serveru            }
{                                                          }
{  (C)2002, SofCon, Stresovicka 49, 160 00 Praha 6         }
{           Petr Cernin                                    }
{                                                          }
{==========================================================}

{ TODO:

   [1] Zvazit: Nezmenit otevrene rozptylovani na zretezene ?
}

{ Zmeny:

   [1] 18.11.2002 Verze 1.2
       - Sjednoceni s upravami v knihovne TCP
   [2] 8.1.2003   Verze 1.2b
       - Oprava kontrol alokaci pameti
         (dusledne testovani navratovych hodnot GetMem, New)
}

interface

uses
  CoBase,
  CoInet,
  CoTcp,
  Objects;


{ Prepinace ladicich vypisu }

{ define DEBUG_HTTP_SVR}  { Ladici vypisy automatu                       }
{ define LOG_CONNRESET}   { Loguje chybu CONNRESET pri navazanem spojeni }
{ define LOG_NOTCONN}     { Loguje chybu NOTCONN pri uzavirani spojeni   }

const { Chybove kody HTTP protokolu }

  { Chybove kody neoznacene verzi protokolu odpovidaji verzi
    HTTP/1.0 (viz RFC-1945), chybove kody HTTP/1.1 lze nalezt
    v RFC-2068 }

  HTE_OK                    = 200;
  HTE_CREATED               = 201;
  HTE_ACCEPTED              = 202;
  HTE_NON_AUTH_INFORMATION  = 203; { HTTP/1.1 }
  HTE_NO_CONTENT            = 204;
  HTE_RESET_CONTENT         = 205; { HTTP/1.1 }
  HTE_PARTIAL_CONTENT       = 206; { HTTP/1.1 }

  HTE_MULTIPLE_CHOICES      = 300;
  HTE_MOVED_PERMANENTLY     = 301;
  HTE_MOVED_TEMPORARILY     = 302;
  HTE_SEE_OTHER             = 303; { HTTP/1.1 }
  HTE_NOT_MODIFIED          = 304;
  HTE_USE_PROXY             = 305; { HTTP/1.1 }

  HTE_BAD_REQUEST           = 400;
  HTE_UNAUTHORIZED          = 401;
  HTE_PAYMENT_REQURIED      = 402; { HTTP/1.1 }
  HTE_FORBIDDEN             = 403;
  HTE_NOT_FOUND             = 404;
  HTE_METHOD_NOT_ALLOWED    = 405; { HTTP/1.1 }
  HTE_NOT_ACCEPTABLE        = 406; { HTTP/1.1 }
  HTE_PROXY_AUTH_REQUIRED   = 407; { HTTP/1.1 }
  HTE_REQUEST_TIMEOUT       = 408; { HTTP/1.1 }
  HTE_CONFLICT              = 409; { HTTP/1.1 }
  HTE_GONE                  = 410; { HTTP/1.1 }
  HTE_LENGTH_REQUIRED       = 411; { HTTP/1.1 }
  HTE_PRECONDITION_FAILED   = 412; { HTTP/1.1 }
  HTE_REQ_ENTITY_TOO_LARGE  = 413; { HTTP/1.1 }
  HTE_REQ_URI_TOO_LONG      = 414; { HTTP/1.1 }
  HTE_UNSUPP_MEDIA_TYPE     = 415; { HTTP/1.1 }

  HTE_INTERNAL_SERVER_ERROR = 500;
  HTE_NOT_IMPLEMENTED       = 501;
  HTE_BAD_GATEWAY           = 502;
  HTE_SERVICE_UNAVAILABLE   = 503;
  HTE_GATEWAY_TIMEOUT       = 504; { HTTP/1.1 }
  HTE_HTTP_VERSION_NOTSUPP  = 505; { HTTP/1.1 }

  {--------------------------------------------------------------------}
  { THttpRequest                                                       }
  {--------------------------------------------------------------------}

type

  THttpMethod = (
    mtdGET,
    mtdHEAD,
    mtdPOST,
    mtdPUT,
    mtdDELETE
  );

type

  PHttpRequest = ^THttpRequest;
  THttpRequest = object
  private
    State     : Byte;
    BuffStart : PChar;
    BuffSize  : Word;
    BuffPtr   : PChar;
    LinePtr   : PChar;

    ContentIncluded: Boolean;     { V zahlavi bylo klicove slovo Content }

    function  Alloc( ABuffSize: Word ): Boolean;
    procedure Free;

    procedure Reuse;
    procedure GetNextRecvBuff( var ABuffPtr: Pointer; var ABuffSize: Word );
    function  ParseBuff( ASize: Word ): Integer;
    function  ParseLine: Integer;

  public
  {--------------------------------- Command Line                      }
    Method          : THttpMethod; {                                   }
    Path            : PChar;       {                                   }
    Query           : PChar;       {                                   }
    Version         : PChar;       {                                   }
  {--------------------------------- General Header                    }
    Date            : Longint;     {                                   }
  { Connection      : PChar;       {                                   }
  {--------------------------------- Request Header                    }
  { Authorization   : PChar;       {                                   }
  { From            : PChar;       {                                   }
    Host            : PChar;       {                                   }
    IfModified      : Longint;     {                                   }
    Referer         : PChar;       {                                   }
    UserAgent       : PChar;       {                                   }
  {--------------------------------- Entity Header                     }
  { Allow           : PChar;       {                                   }
  { ContentEncoding : PChar;       {                                   }
    ContentLength   : Word;        {                                   }
    ContentType     : PChar;       {                                   }
  { Expires         : Longint;     {                                   }
  { LastModified    : Longint;     {                                   }
  {--------------------------------- Additional Header                 }
    Accept          : PChar;       {                                   }
  {--------------------------------- Entity                            }
    Content         : PChar;       {                                   }

  end;

  {--------------------------------------------------------------------}
  { THttpQueryParser                                                   }
  {--------------------------------------------------------------------}

  { THttpQueryParam }
  { Parametr dotazu }

  PHttpQueryParam = ^THttpQueryParam;
  THttpQueryParam =
  record
    Name  : PChar;  { Jmeno parametru   }
    Value : PChar;  { Hodnota parametru }
  end;

  { TAHttpQueryParam }

  PAHttpQueryParam = ^TAHttpQueryParam;
  TAHttpQueryParam = array[0..255] of THttpQueryParam;

  { THttpQueryParser }

  PHttpQueryParser = ^THttpQueryParser;
  THttpQueryParser = object( TObject )
  public
    MaxCount : Integer;           { Max. pocet parametru dotazu     }
    Count    : Integer;           { Aktualni pocet parametru dotazu }
    Params   : PAHttpQueryParam;  { Pole parametru                  }

    constructor Init( AMaxCount: Integer );
    destructor  Done; virtual;

    { Preklad dotazu THttpRequest.Query. Dotaz musi byt ve formatu
      item1=value1&item2=value2&...
      Tato metoda zmeni obsah AQuery!!! }
    procedure Parse( AQuery: PChar );

    { Hledani parametru se zadanym jmenem. Vraci jeho index, nebo -1
      pokud parametr s danym jmenem neexistueje }
    function  Find( AName: PChar ): Integer;

    { Vraci hodnotu parametru se zadanym jmenem, nebo nil, pokud
      parametr neexistuje }
    function  GetValueOf( AName: PChar ): PChar;
  end;


  {--------------------------------------------------------------------}
  { THttpResponseText                                                  }
  {--------------------------------------------------------------------}

  THttpResponseText = object
  private
    Buff     : PChar;    { Text                                         }
    BuffSize : Word;     { Maximalni velikost textu, alokovana na heapu }
    Text     : PChar;    { Ukazatel na konec textu                      }
    TextSize : Word;     { Delka textu (bez #0)                         }

    { Alokovani struktury }
    function   Alloc( ABuffSize: Word ): Boolean;

    { Uvolneni polozek struktury z pameti }
    procedure  Free;

    { Zkraceni celeho textu v bufferu na 0 znaku }
    procedure Clear;

  public
    { Test na plny buffer }
    function  BufferFull: Boolean;
    { Pocet znaku zbyvajicich do zaplneni bufferu }
    function  BufferAvail: Integer;

    { Pripojeni textu na konec textu v bufferu }
    procedure Append( AText: PChar );
    { Pripojeni textu omezeneho delku na konec textu v bufferu }
    procedure AppendBuff( ABuff: PChar; ASize: Word );
    { Pripojeni retezce na konec textu v bufferu }
    procedure AppendStr( const AStr: string );
    { Pripojeni spakovaneho casu (PackTime) na konec textu v bufferu
      Cas je ve formatu 'DDD, dd MMM yyyy hh:mm:ss GMT',
      kde DDD je (Mon, Tue, .. ), dd je den, MMM je (Jan, Feb, ... )
      yyy je rok, hh jsou hodiny, mm minuty, ss sekundy }
    procedure AppendTime( ATime: Longint );
    { Pripojeni cisla (Longint) na konec textu v bufferu }
    procedure AppendInt( AValue: Longint );
    { Pripojeni cisla (Real) na konec textu v bufferu }
    procedure AppendReal( AValue: Real; AWidth, ADecimal: Integer );

    { Pridani start znacky <ATagName> na konec textu v bufferu }
    procedure STag( ATagName: PChar );
    { Pridani ukoncovaci znacky <\ATagName> na konec text v bufferu }
    procedure ETag( ATagName: PChar );
  end;

  {--------------------------------------------------------------------}
  { THttpResponse                                                      }
  {--------------------------------------------------------------------}


  PHttpResponse = ^THttpResponse;
  THttpResponse = object
  private
    ContentLength   : PChar;       { Ukazatel na delku obsahu v textu  }
    ContentPtr      : PChar;       { Ukazatel na zacatek dat entity    }
    StatusLine      : Boolean;     { Do bufferu byla zapsana StatusLine }

    { Alokovani struktury. AMaxRespSize udava maximalni velikost
      odpovedi vcetne zahlavi. Pro zahlavi je potreba pocitat
      s cca 100-300 bajty }
    function Alloc( AMaxRespSize: Word ): Boolean;

    { Uvolneni struktury z pameti }
    procedure Free;

    { Inicializuje strukturu pro dalsi pouziti, volat i pri }
    { prvnim pouziti }
    procedure Reuse;

  public
  {--------------------------------- General Header                    }
    Pragma          : PChar;       {                                   }
  {--------------------------------- Response Header                   }
    StatusCode      : Word;        {                                   }
    ReasonString    : PChar;       {                                   }
    Location        : PChar;       {                                   }
    Server          : PChar;       {                                   }
  { WWWAuthenticate : ..           {                                   }
  { Realm           : ..           {                                   }
  {--------------------------------- Entity Header                     }
    Allow           : PChar;       {                                   }
    ContentEncoding : PChar;       {                                   }
    ContentType     : PChar;       {                                   }
  {+ContentLength   : Word;        {                                   }
  { ContentVersion  : PChar;       {                                   }
  { DerivedFrom     : PChar;       {                                   }
    Expires         : Longint;     {                                   }
    LastModified    : Longint;     {                                   }
{   Title           : PChar;       {                                   }
  {--------------------------------- Entity                            }
    Content         : THttpResponseText; {                             }


  public

    procedure AddStatusLine;

    procedure AddResponseHeader;

    { Priprava pred vyplnenim dat entity. }
    { Metoda zapise do polozky Text zahlavi odpovedi. Pred volanim }
    { teto metody muze data provider vyplnit polozky zahlavi. }
    procedure BeginEntity;

    { Ukonceni zadavani dat entity. Metoda vyplni pole Content-Len }
    { v zahlavi entity }
    procedure EndEntity;
  end;

  {--------------------------------------------------------------------}
  { THttpSession                                                       }
  {--------------------------------------------------------------------}

  PHttpSession = ^THttpSession;

  { Funkce poskytujici data relace }
  THttpDataProvider = function( ASession: PHttpSession ): Boolean;

  { Funkce reagujici na chybu relace }
  THttpErrorHandler = procedure( ASession: PHttpSession;
                        const AText: string );


  THttpAcceptFilter = function( AAdress: TTcpAddress ): Boolean;

  THttpSession = object( TObject )
  private
    NextLink     : PHttpSession;        { Dalsi relace v seznamu       }
    Socket       : PCoDevice;           { Komunikacni zasuvka          }
    State        : Byte;                { Stav automatu                }
    Overlapped   : TOverlapped;         { Overlapped struktura zasuvky }
    TxOverlapped : TOverlapped;         { Overlapped pro vysilani      }
    RecvLen      : Word;                { Delka prijatych dat          }
    StopRequest  : Boolean;             { Pozadavek na okamzite ukonceni }
    ConnTimeout  : TCoTime;             { Timeout na spojeni (ms)      }
    ExpireTime   : TCoTime;             { Cas kdy vyprsi timeout       }

    { Funkce volana v pripade chyby zasuvky }
    procedure DoSocketError( const AText: string; AStatus: TCoStatus ); virtual;
    procedure DoError( const AText: string );
    procedure DoHttpError( AStatusCode: Word );

  public {protected}

    constructor Init( AMaxReqSize, AMaxRespSize: Word );
    destructor  Done; virtual;

    procedure Reuse( ASocket: PCoDevice ); virtual;

    { Tick automatu HTTP relace. Pokud byla relace dokoncena, pak
      metoda vraci True }
    function  Tick: Boolean;

  public
    ClientAddr   : TTcpAddress;         { Adresa clienta               }
    Request      : THttpRequest;        { Struktura pozadavku          }
    Response     : THttpResponse;       { Struktura odpovedi           }
    DataProvider : THttpDataProvider;   { Funkce poskytujici data      }
    ErrorHandler : THttpErrorHandler;   { Funkce reagujici na chyby    }
    Context      : Pointer;             { Uzivatelska hodnota          }

  end;


  {--------------------------------------------------------------------}
  { THttpServer                                                        }
  {--------------------------------------------------------------------}

  PHttpServer = ^THttpServer;
  THttpServer = object( TObject )
  private
    PendingList  : PHttpSession;        { Seznam probihajicich relaci  }
    ClosedList   : PHttpSession;        { Seznam uzavrenych relaci     }
    SessionCount : Integer;             { Pocet probihajicich relaci   }

    State        : Byte;                { Stav automatu                }

    StopRequest  : Boolean;             { Pozadavek na zastaveni       }
    StartRequest : Boolean;             { Pozadavek na spusteni        }

    Socket       : PCoDevice;           { Naslouchajici zasuvka        }
    Overlapped   : TOverlapped;         { Overlapped struktura zasuvky }
    ClientSocket : PCoDevice;           { Nove vytvoreny soket         }
    ClientAddr   : TTcpAddress;         { Adresa useragenta            }


    NetStackId   : string[16];          { Idenfitikator TCP/IP zasobniku }
    MaxSessions  : Integer;             { Maximalni pocet soucasne
                                          probihajicich relaci         }

    MaxReqSize   : Word;                { Maximalni delka dotazu (B)   }
    MaxRespSize  : Word;                { Maximalni delka odpovedi (B) }

  public {protected}

    { Vytvoreni instance relace. Potomci mohou tuto metodu predefinovat
      a vracet misto instance THttpSession jejiho potomka }
    function  NewSession: PHttpSession; virtual;

    { Funkce volana v pripade chyby TCP zasuvky }
    procedure DoSocketError( const AText: string;
                AStatus: TCoStatus ); virtual;

    { Obsluha obecne chyby }
    procedure DoError( const AText: string ); virtual;

  public

    DataProvider : THttpDataProvider;   { Funkce poskytujici data      }
    ErrorHandler : THttpErrorHandler;   { Funkce reagujici na chyby    }
    AcceptFilter : THttpAcceptFilter;   { Funkce filtrujici clienty    }
    ConnTimeout  : TCoTime;             { Timeout na spojeni (ms)      }
    Port         : Word;                { Cislo portu                  }

  public

    { Inicializace instance serveru. APort udava cislo portu,
      na kterem server posloucha. (Implicitne 21) ANetStackId udava
      identifikator TCP/IP zasobniku specifikovany pri volani
      NetOpenStack }
    constructor Init( AMaxSessions: Integer; const ANetStackId: string;
                      AMaxReqSize, AMaxRespSize: Word );

    { Uvolneni instance serveru. Volat pokud mozno az tehdy, kdyz
      Tick vrati True }
    destructor  Done; virtual;

    { Zastaveni serveru. Nasledne je potreba volat metodu Tick do te doby,
      nez vrati hodnotu False }
    procedure Stop;

    { Spusteni serveru }
    procedure Start;

    { Krok automatu serveru. Pokud metoda vrati True, byl server ukoncen }
    function  Tick: Boolean;
  end;


type

  PHttpPathSegment = ^THttpPathSegment;
  THttpPathSegment =
  record
    Segment : PChar;   { Nazev slozky                                         }
    Id      : Integer; { Identifikator 0..32767, -1 oznacuje posledni polozku }
  end;


  {-----------------------------
  { HttpGetPathSegment
  {---
  { Funkce pro preklad absolutni cesty. Path je ukazatel na absolutni cestu.
  { Po uspesnem provedeni funkce je Path presunuto na zacatek zpracovaneho segmentu.
  { Table je ukazatel na pole polozek THttpPathSegment (zakoncenych
  { polozkou -1, nil).
  { Pokud funkce nalezne v seznamu Segments prislusny segment vrati jeho
  { identifikator (tj. polozku ID zaznamu THttpPathSegment) jinak vraci -1.
  { V Indexu je navracen hodnota indexovaneho segmentu, nebo -1 pokud segment
  { neni indexovan.
  {---
  { V poli Segments mohou byt nasledujici typy polozek:
  {  slozka             napr. 'text/', 'archives/'
  {  soubor             napr. 'voltage', 'pressure'
  {  indexovana polozka napr. 'archive?', 'test?A', 'test?B'
  {    (vyskyt otazniku predpoklada cislo v rozsahu 0..32767)
  }

  function HttpGetPathSegment( var APath: PChar; ATable: PHttpPathSegment;
    var AIndex: Integer ): Integer;

type


  THttpSegmentDispatcher = function( ASession: PHttpSession;
    APath: PChar; AIndex: Integer ): Boolean;


  PHttpDispatchItem = ^THttpDispatchItem;
  THttpDispatchItem =
  record
    Segment    : PChar;                    { Nazev slozky                   }
    Dispatcher : THttpSegmentDispatcher;   { Funkce poskytujici data slozky }
  end;


  function HttpDispatchSegment( APath: PChar; ATable: PHttpDispatchItem;
    ASession: PHttpSession ): Boolean;


  {-----------------------------
  { HttpGetTime
  {---
  { Vraci aktulani systemovy cas ve spakovanem tvaru
  {---
  }

  function HttpGetTime: Longint;


implementation

uses
  Strings,
  NumToStr,
  Dos;


  {$ifdef DEBUG_HTTP_SVR}
  procedure Trace( const S: String );
  begin
    WriteLn( S );
  end;
  {$endif}

const
  INVALID_LENGTH = 0;

const { Stavy automatu relace THttpSession }

  SST_REQUEST      = 0;
  SST_RECEIVE      = 1;
  SST_RECEIVE_WAIT = 2;
  SST_HANDLE       = 3;
  SST_HANDLE_WAIT  = 4;
  SST_SEND         = 5;
  SST_DISCONN      = 6;
  SST_DISCONN_WAIT = 7;
  SST_UNBIND       = 8;
  SST_UNBIND_WAIT  = 9;
  SST_CLOSED       = 10;
  SST_RESET        = 11;
  SST_RESET_WAIT   = 12;

const { Stavy automatu serveru THttpServer }

  HST_ACCEPT       = 0;
  HST_ACCEPT_WAIT  = 1;
  HST_BIND         = 2;
  HST_BIND_WAIT    = 3;
  HST_LISTEN       = 4;
  HST_LISTEN_WAIT  = 5;
  HST_UNBIND       = 6;
  HST_UNBIND_WAIT  = 7;
  HST_CLOSED       = 8;


const { Stav automatu prekladu dotazu }

  RST_TRIM_LEFT    = 0;
  RST_LINE_START   = 1;
  RST_LINE_CONT    = 2;
  RST_CONTENT      = 3;

const { Navratove kody parseru HTTP requestu }

  rstOk            = 0;
  rstError         = 1;
  rstContinue      = 2;


{-----------------------------
{ HttpGetPathSegment
{---
{ Funkce pro preklad absolutni cesty. Path je ukazatel na absolutni cestu.
{ Po uspesnem provedeni funkce je Path presunuto na zacatek zpracovaneho segmentu.
{ Segments je ukazatel na pole polozek THttpPathSegment (zakoncenych
{ polozkou -1, nil).
{ Pokud funkce nalezne v seznamu Segments prislusny segment vrati jeho
{ identifikator (tj. polozku ID zaznamu THttpPathSegment) jinak vraci -1.
{ V Indexu je navracen hodnota indexovaneho segmentu, nebo -1 pokud segment
{ neni indexovan.
{---
{ V poli Segments mohou byt nasledujici typy polozek:
{  slozka             napr. 'text/', 'archives/'
{  soubor             napr. 'voltage', 'pressure'
{  indexovana polozka napr. 'archive?', 'test?A', '?xyz'
{    (vyskyt otazniku predpoklada cislo v rozsahu 0..32767)
}

function HttpGetPathSegment( var APath: PChar; ATable: PHttpPathSegment;
  var AIndex: Integer ): Integer;
var
  P : PChar;
  F : PChar;
  Value: Integer;


  function IsMatch: Boolean;
  var
    TempVal: Word;
  begin
    IsMatch := False;

    repeat

      { Porovnavame text dokud souhlasi }

      while (P^ = F^) and (not (F^ in [#0, '/'])) do
      begin
        Inc( P );
        Inc( F );
      end;

      case F^ of

        #0:
        begin
          { Posledni polozka cesty }
          if P^ = #0 then Break else Exit;
        end;

        '/':
        begin
          { Vnitrni polozka cesty }
          if P^ = '/' then Break else Exit;
          Inc( P );
          Inc( F );
        end;


        '?':
        begin
          { Index }

          Inc( F );

          if P^ in ['0'..'9'] then
          begin
            TempVal := Ord( P^ ) - Ord( '0' );
            Inc( P );

            while P^ in ['0'..'9'] do
            begin
              if TempVal <= 3276 then
              begin
                TempVal := TempVal * 10 + Ord( P^ ) - Ord( '0' );
              end
              else
                Exit;

              Inc( P );
            end;

            if TempVal > 32767 then Exit;

            Value := TempVal;
          end
          else
            Exit;

        end;

      else
        { Neni shoda }
        Exit;
      end;

    until False;

    IsMatch := True;
  end;


begin
  P := StrScan( APath, '/' );

  if P <> nil then
  begin
    Inc( P );
    APath := P;
    Value := -1;

    while ATable^.Segment <> nil do
    begin
      P := APath;
      F := ATable^.Segment;

      if IsMatch then
      begin
        { Text souhlasi }
        AIndex := Value;
        HttpGetPathSegment := ATable^.Id;
        Exit;
      end;

      Inc( ATable );
    end;

    HttpGetPathSegment := -1;
  end
  else
    HttpGetPathSegment := -1;
end;


{-----------------------------
{ HttpDispatchSegment
{---
{ Funkce pro preklad absolutni cesty. Path je ukazatel na absolutni cestu.
{ Po uspesnem provedeni funkce je Path presunuto na zacatek zpracovaneho segmentu.
{ Segments je ukazatel na pole polozek THttpPathSegment (zakoncenych
{ polozkou -1, nil).
{ Pokud funkce nalezne v seznamu Segments prislusny segment vrati jeho
{ identifikator (tj. polozku ID zaznamu THttpPathSegment) jinak vraci -1.
{ V Indexu je navracen hodnota indexovaneho segmentu, nebo -1 pokud segment
{ neni indexovan.
{---
{ V poli Segments mohou byt nasledujici typy polozek:
{  slozka             napr. 'text/', 'archives/'
{  soubor             napr. 'voltage', 'pressure'
{  indexovana polozka napr. 'archive?', 'test?A', '?xyz'
{    (vyskyt otazniku predpoklada cislo v rozsahu 0..32767)
}

function HttpDispatchSegment( APath: PChar; ATable: PHttpDispatchItem;
  ASession: PHttpSession ): Boolean;

var
  P : PChar;
  F : PChar;
  Value: Integer;


  function IsMatch: Boolean;
  var
    TempVal: Word;
  begin
    IsMatch := False;

    repeat

      { Porovnavame text dokud souhlasi }

      while (P^ = F^) and (not (F^ in [#0, '/'])) do
      begin
        Inc( P );
        Inc( F );
      end;

      case F^ of

        #0:
        begin
          { Posledni polozka cesty }
          if P^ = #0 then Break else Exit;
        end;

        '/':
        begin
          { Vnitrni polozka cesty }
          if P^ = '/' then Break else Exit;
          Inc( P );
          Inc( F );
        end;


        '?':
        begin
          { Index }

          Inc( F );

          if P^ in ['0'..'9'] then
          begin
            TempVal := Ord( P^ ) - Ord( '0' );
            Inc( P );

            while P^ in ['0'..'9'] do
            begin
              if TempVal <= 3276 then
              begin
                TempVal := TempVal * 10 + Ord( P^ ) - Ord( '0' );
              end
              else
                Exit;

              Inc( P );
            end;

            if TempVal > 32767 then Exit;

            Value := TempVal;
          end
          else
            Exit;

        end;

      else
        { Neni shoda }
        Exit;
      end;

    until False;

    IsMatch := True;
  end;


begin
  P := StrScan( APath, '/' );

  HttpDispatchSegment := True;

  if P <> nil then
  begin
    Inc( P );
    APath := P;
    Value := -1;

    while ATable^.Segment <> nil do
    begin
      P := APath;
      F := ATable^.Segment;

      if IsMatch then Break;

      Inc( ATable );
    end;

    if Assigned( ATable^.Dispatcher ) then
    begin
      HttpDispatchSegment := ATable^.Dispatcher( ASession, APath, Value );
    end;

  end;
end;


{-----------------------------
{ HttpGetTime
{---
{ Vraci aktulani systemovy cas ve spakovanem tvaru
{---
}

function HttpGetTime: Longint;
var
  D      : DateTime;
  Temp   : Word;
  Result : Longint;
begin
  GetDate( D.Year, D.Month, D.Day, Temp );
  GetTime( D.Hour, D.Min, D.Sec, Temp );
  PackTime( D, Result );
  HttpGetTime := Result
end;


{-----------------------------
{ HttpGetResponseString
{---
{ Vraci standardni textovy retezec odpovidajici HTTP chybe
{ (viz RFC-1945 a RFC-2068)
{ Pokud k danemu cislu chyby neni standardni, pak funkce vraci nil
{---
}

function HttpGetReasonString( AStatusCode: Word ): PChar;
type
  TLookupItem = record
    S{elector} : Word;
    T{text}    : PChar;
  end;

const
  { Tabulka by mela byt serazena podle cetnosti vyskytu navratovych kodu }

  Lookup: array[0..34] of TLookupItem = (
    (S: HTE_OK                    ; T: 'OK' ),
    (S: HTE_NO_CONTENT            ; T: 'No Content' ),
    (S: HTE_NOT_FOUND             ; T: 'Not Found' ),

    (S: HTE_CREATED               ; T: 'Created' ),
    (S: HTE_ACCEPTED              ; T: 'Accepted' ),
    (S: HTE_NON_AUTH_INFORMATION  ; T: 'Non-Authoritative Information' ),
{   (S: HTE_NO_CONTENT            ; T: 'No Content' ),}
    (S: HTE_RESET_CONTENT         ; T: 'Reset Content' ),
    (S: HTE_PARTIAL_CONTENT       ; T: 'Partial Content' ),
    (S: HTE_MULTIPLE_CHOICES      ; T: 'Multiple Choices' ),
    (S: HTE_MOVED_PERMANENTLY     ; T: 'Moved Permanently' ),
    (S: HTE_MOVED_TEMPORARILY     ; T: 'Moved Temporarily' ),
    (S: HTE_SEE_OTHER             ; T: 'See Other' ),
    (S: HTE_NOT_MODIFIED          ; T: 'Not Modified' ),
    (S: HTE_USE_PROXY             ; T: 'Use Proxy' ),
    (S: HTE_BAD_REQUEST           ; T: 'Bad Request' ),
    (S: HTE_UNAUTHORIZED          ; T: 'Unauthorized' ),
    (S: HTE_PAYMENT_REQURIED      ; T: 'Payment Required' ),
    (S: HTE_FORBIDDEN             ; T: 'Forbidden' ),
{   (S: HTE_NOT_FOUND             ; T: 'Not Found' ),}
    (S: HTE_METHOD_NOT_ALLOWED    ; T: 'Method Not Allowed' ),
    (S: HTE_NOT_ACCEPTABLE        ; T: 'Not Acceptable' ),
    (S: HTE_PROXY_AUTH_REQUIRED   ; T: 'Proxy Authentication Required' ),
    (S: HTE_REQUEST_TIMEOUT       ; T: 'Request Timeout' ),
    (S: HTE_CONFLICT              ; T: 'Conflict' ),
    (S: HTE_GONE                  ; T: 'Gone' ),
    (S: HTE_LENGTH_REQUIRED       ; T: 'Length Required' ),
    (S: HTE_PRECONDITION_FAILED   ; T: 'Precondition Failed' ),
    (S: HTE_REQ_ENTITY_TOO_LARGE  ; T: 'Request Entity Too Large' ),
    (S: HTE_REQ_URI_TOO_LONG      ; T: 'Req Uri Too Long' ),
    (S: HTE_UNSUPP_MEDIA_TYPE     ; T: 'Unsupported Media Type' ),
    (S: HTE_INTERNAL_SERVER_ERROR ; T: 'Internal Server Error' ),
    (S: HTE_NOT_IMPLEMENTED       ; T: 'Not Implemented' ),
    (S: HTE_BAD_GATEWAY           ; T: 'Bad Gateway' ),
    (S: HTE_SERVICE_UNAVAILABLE   ; T: 'Service Unavailable' ),
    (S: HTE_GATEWAY_TIMEOUT       ; T: 'Gateway Timeout' ),
    (S: HTE_HTTP_VERSION_NOTSUPP  ; T: 'HTTP Version Unsupported' )
  );

var
  I : Integer;
begin
  HttpGetReasonString := nil;

  for I := 0 to High( Lookup ) do
  begin
    if Lookup[ I ].S = AStatusCode then
    begin
      HttpGetReasonString := Lookup[ I ].T;
      Break;
    end;
  end;
end;



const { Elementy HTTP parseru }

  toEOF                = Char(0);
  toInteger            = Char(1);
  toIdent              = Char(2);
  toEOL                = Char(5);
  toGET                = Char(6);
  toPOST               = Char(7);
  toHEAD               = Char(8);
  toPUT                = Char(9);
  toDELETE             = Char(10);
  toUserAgent          = Char(13);
  toAccept             = Char(14);
  toContentType        = Char(15);
  toContentLength      = Char(16);
  toReferer            = Char(17);
  toAuthorization      = Char(18);
  toCacheControl       = Char(19);
  toDate               = Char(20);
  toFrom               = Char(21);
  toHost               = Char(22);
  toIfModified         = Char(23);
  toContentEncoding    = Char(24);
  toContentVersion     = Char(25);
  toAllow              = Char(26);
{ toConnection         = Char(27);}
{ toCookie             = Char(28);}
{ toContentDisposition = Char(29);}
  toContent            = Char(30);

type


  THttpParser = object
  public
    TextPtr    : PChar;    { Ukazatel na aktualni pozici v textu     }
    Token      : Char;     { Identifikator aktualniho tokenu         }
    TokenPtr   : PChar;    { Ukazatel na aktualni token do textu     }
    TokenSize  : Word;     { Delka aktualniho token                  }

  { Inicializace a precteni prvniho tokenu }
    procedure Assign( ATextPtr: PChar );

  { Precteni dalsiho tokenu, symbol je dostupny v polozce Token, TokenPtr a
    TokenSize a take pomoci funkci TokenStr, TokenInt a TokenZStrAndParse }
    function  NextToken: Char;

  { Text tokenu }
    procedure TokenStr( var AStr: string );

  { Integer hodnota tokenu }
    function  TokenInt: Longint;

  { Text do konce radky, funkce vraci ukazatel na text zakonceny #0,
    Delku textu funkce vraci v ASize. Funkce sereze i EOL na konci radky,
    ale ten v samotnem textu neni. Nakonec funkce zparsuje i dalsi symbol na
    dalsi radce, ktery je dostuvny v polozce Token }
    function  CopyToEol( var ASize: Word ): PChar;

  { Text do konce textu, funkce vraci ukazatel na text zakonceny #0,
    delka textu je v ASize. }
    function  CopyToEof( var ASize: Word ): PChar;
  end;


{-----------------------------
{ GetHashCode
{---
{ Vypocet hash hodnoty symbolu
{ Funkce je necitliva na male a velke znaky
{---
}

function GetHashCode(Ident: PChar; Length: Integer): Word; assembler;
const

  CharValue: array[Byte] of Byte = (
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $20,$21,$22,$23,$24,$25,$26,$27,$28,$29,$2A,$2B,$2C,$2D,$2E,$2F,
    $30,$31,$32,$33,$34,$35,$36,$37,$38,$39,$3A,$3B,$3C,$3D,$3E,$3F,
    $40,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F,
    $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$5B,$5C,$5D,$5E,$5F,
    $60,$41,$42,$43,$44,$45,$46,$47,$48,$49,$4A,$4B,$4C,$4D,$4E,$4F,
    $50,$51,$52,$53,$54,$55,$56,$57,$58,$59,$5A,$7B,$7C,$7D,$7E,$7F,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
    $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);

asm
        LES  DI, Ident
        MOV  CX, Length
        MOV  BX, OFFSET CharValue
        XOR  DX, DX
@@1:
        MOV  AL, ES:[DI]
        XLAT
        ROL  DX, 5
        XOR  DL, AL
        INC  DI
        LOOP @@1

        MOV  AX, DX
end;


type

  { Polozka tabulky symbolu }

  TSymbolEntry =
  record
    Symbol   : PChar;   { Z-string symbolu      }
    Token    : Char;    { Identifikator symbolu }
  end;

var

  { Tabulka symbolu implementovana pomoci otevreneho rozptylovani }
  SymbolTable: array[0..66] of TSymbolEntry;

{-----------------------------
{ InitSymbolTable
{---
{ Inicializace tabulky symbolu
{---
}

procedure InitSymbolTable;

  procedure AddSymbol( const ASymbol: PChar; AToken: Char );
  var
    H : Word;
  begin
    H := GetHashCode( ASymbol, StrLen( ASymbol ) ) mod
         (High(SymbolTable) + 1);

    while SymbolTable[ H ].Token <> #0 do
    begin
      H := (H + 7) mod (High(SymbolTable) + 1);
    end;

    with SymbolTable[ H ] do
    begin
      Symbol := ASymbol;
      Token  := AToken;
    end;
  end;

begin
  FillChar( SymbolTable, SizeOf( SymbolTable ), 0 );

  AddSymbol( 'GET',                 toGet );
  AddSymbol( 'HEAD',                toHead );
  AddSymbol( 'POST',                toPost );
  AddSymbol( 'PUT',                 toPut );
  AddSymbol( 'DELETE',              toDelete );
  AddSymbol( 'Cache-Control',       toCacheControl );
  AddSymbol( 'Date',                toDate );
  AddSymbol( 'From',                toFrom );
  AddSymbol( 'Host',                toHost );
  AddSymbol( 'If-Modified-Since',   toIfModified );
  AddSymbol( 'Allow',               toAllow );
  AddSymbol( 'User-Agent',          toUserAgent );
  AddSymbol( 'Accept',              toAccept );
  AddSymbol( 'Content-Encoding',    toContentEncoding );
  AddSymbol( 'Content-Version',     toContentVersion );
  AddSymbol( 'Content-Type',        toContentType );
  AddSymbol( 'Content-Length',      toContentLength );
  AddSymbol( 'Referer',             toReferer );
{ AddSymbol( 'Connection',          toConnection ); }
{ AddSymbol( 'Cookie',              toCookie ); }
{ AddSymbol( 'Authorization',       toAuthorization ); }
{ AddSymbol( 'Content-Disposition', toContentDisposition );}
end;



{-----------------------------
{ LookupIdent
{---
{ Hledani v tabulce symbolu
{ Pokud je symbol nalezen, je vracen jeho identifikator toXXX, jinak
{ funkce vraci toIdent
{---
}

function LookupIdent( Text: PChar ): Char;
var
  H : Word;
begin
  H := GetHashCode( Text, StrLen( Text ) ) mod (High(SymbolTable) + 1);

  LookupIdent := toIdent;

  while True do
  begin
    with SymbolTable[ H ] do
    begin
      if Token = #0 then Break;
      if StrIComp( Symbol, Text ) = 0 then
      begin
        LookupIdent := Token;
        Break;
      end;
    end;
    H := (H + 7) mod (High(SymbolTable) + 1);
  end;

end;

{======================================================================}
{ THttpParser                                                          }
{======================================================================}

{-----------------------------
{ THttpParser.Assign
{---
{ Inicializace a precteni prvniho tokenu
{---
}

procedure THttpParser.Assign( ATextPtr: PChar );
begin
  TextPtr := ATextPtr;
  NextToken;
end;

{-----------------------------
{ THttpParser.NextToken
{---
{ Precteni dalsiho tokenu
{---
}

function  THttpParser.NextToken: Char;
var
  SaveChar: Char;
begin
  { Preskocit mezery }
  while TextPtr^ in [#8, #13, #32] do Inc( TextPtr );

  TokenPtr := TextPtr;

  case TextPtr^ of

    #10:
    begin
      Token := toEOL;
      Inc( TextPtr );
    end;

    '0'..'9':
    begin
      Inc( TextPtr );
      while TextPtr^ in ['0'..'9'] do Inc( TextPtr );
      Token := toInteger;
    end;

    'A'..'Z', 'a'..'z', '_':
    begin
      Inc( TextPtr );
      while TextPtr^ in ['A'..'Z', 'a'..'z', '_', '-'] do Inc( TextPtr );

      SaveChar := TextPtr^;
      TextPtr^ := #0;
      Token := LookupIdent( TokenPtr );
      TextPtr^ := SaveChar;
    end;

  else
    Token := TextPtr^;
    if Token <> toEOF then Inc( TextPtr );
  end;

  TokenSize := TextPtr - TokenPtr;
  NextToken := Token;
end;

{-----------------------------
{ THttpParser.TokenInt
{---
{ Integer hodnota tokenu
{---
}

function  THttpParser.TokenInt: Longint;
var
  S     : string;
  Value : Longint;
  Code  : Word;
begin
  TokenStr( S );
  Val( S, Value, Code );
  TokenInt := Value;
end;

{-----------------------------
{ THttpParser.TokenStr
{---
{ Text tokenu
{---
}

procedure THttpParser.TokenStr( var AStr: string );
var
  Size : Word;
begin
  Size := TokenSize;
  if Size > High(AStr) then Size := High(AStr);
  AStr[0] := Chr( Size );
  MemCopy( @AStr[1], TokenPtr, Size );
end;


{-----------------------------
{ THttpParser.CopyToEol
{---
{ Text do konce radky, funkce vraci ukazatel na text zakonceny #0,
{ Delku textu vraci v ASize
{---
}

function THttpParser.CopyToEol( var ASize: Word ): PChar;
begin
  CopyToEol := TextPtr;
  TokenPtr := TextPtr;

  while not (TextPtr^ in [#0, #10]) do Inc( TextPtr );

  ASize := TextPtr - TokenPtr;

  if TextPtr^ <> #0 then
  begin
    TextPtr^ := #0;
    Inc( TextPtr );
  end;

  NextToken;
end;

{-----------------------------
{ THttpParser.CopyToEof
{---
{ Text do konce textu, funkce vraci ukazatel na text zakonceny #0,
{ Delku textu vraci v ASize
{---
}

function THttpParser.CopyToEof( var ASize: Word ): PChar;
begin
  CopyToEof := TextPtr;
  TokenPtr := TextPtr;
  while TextPtr^ <> #0 do Inc( TextPtr );
  ASize := TextPtr - TokenPtr;
  NextToken;
end;


{======================================================================}
{ THttpQueryParser                                                     }
{======================================================================}

{-----------------------------
{ THttpQueryParser.Init
{---
{ Inicializace parseru parametru
{ AMaxCount udava maximalni pocet parametru dotazu
{---
}

constructor THttpQueryParser.Init( AMaxCount: Integer );
var
  P : PAHttpQueryParam;
begin
  inherited Init;

  GetMem( Params, AMaxCount * SizeOf( THttpQueryParam ) );

  if Params = nil then Fail;

  MaxCount := AMaxCount;
  Count := 0;
end;

{-----------------------------
{ THttpQueryParser.Done
{---
{ Uvolneni instance parseru parametru
{---
}

destructor THttpQueryParser.Done;
begin
  if Params <> nil then
  begin
    FreeMem( Params, MaxCount * SizeOf( THttpQueryParam ) );
  end;

  inherited Done;
end;


{-----------------------------
{ THttpQueryParser.Init
{---
{ Hledani parametru s danym jmenem
{ Funkce rozlisuje male a velke znaky
{ Vraci index parametru, nebo -1 v pripade, ze dane jmeno neexistuje
{---
}

function THttpQueryParser.Find( AName: PChar ): Integer;
var
  I : Integer;
  P : PHttpQueryParam;
begin
  I := Count - 1;
  P := @Params^[0];
  while I >= 0 do
  begin
    if StrComp( AName, P^.Name ) = 0 then Break;
    Inc( P );
    Dec( I );
  end;
  Find := I;
end;


{-----------------------------
{ THttpQueryParser.GetValueOf
{---
{ Funkce vraci hodnotu parametru. Pokud dany parametr neexistuje
{ pak vraci nil
{---
}

function THttpQueryParser.GetValueOf( AName: PChar ): PChar;
var
  I : Integer;
begin
  I := Find( AName );

  if I >= 0 then
    GetValueOf := Params^[I].Value
  else
    GetValueOf := nil;
end;


{-----------------------------
{ THttpQueryParser.Parse
{---
{ Funkce prelozi parametry za URL. Parametry jsou ve formatu:
{ item1=value1&item2=value2&..
{---
}

{ Funkce znici obsah Query }
procedure THttpQueryParser.Parse( AQuery: PChar );
var
  Param : PHttpQueryParam;

  procedure SubstChars( P: PChar );
  var
    W : PChar;

    function Nibble( Ch: Char ): Byte;
    begin
      case Ch of
        '0'..'9': Nibble := Ord( Ch ) - Ord( '0' );
        'A'..'F': Nibble := Ord( Ch ) - Ord( 'A' ) + 10;
        'a'..'f': Nibble := Ord( Ch ) - Ord( 'a' ) + 10;
      else
        Nibble := $2; { proste neco }
      end;
    end;

  begin

    W := P;

    repeat

      while not (P^ in [#0, '%', '+']) do
      begin
        W^ := P^;
        Inc( P );
        Inc( W );
      end;

      case P^ of

        '+':
        begin
          W^ := ' ';
          Inc( W );
          Inc( P );
        end;

        '%':
        begin
          Inc( P );
          W^ := Char( Nibble( P^ ) shl 4 + Nibble( (P + 1)^ ) );
          Inc( P, 2 );
          Inc( W );
        end;

        #0:
        begin
          Break;
        end;

      end;

    until False;

    W^ := #0;

  end;

begin

  Count := 0;
  Param := @Params^[0];

  while Count < MaxCount do
  begin
    Param^.Name := AQuery;

    AQuery := StrScan( AQuery, '=' );
    if AQuery = nil then Break;

    AQuery^ := #0;
    Inc( AQuery );

    SubstChars( Param^.Name );

    Param^.Value := AQuery;

    Inc( Count );

    AQuery := StrScan( AQuery, '&' );
    if AQuery = nil then
    begin
      SubstChars( Param^.Value );
      Break;
    end;

    AQuery^ := #0;
    Inc( AQuery );

    SubstChars( Param^.Value );

    Inc( Param );
  end;

end;


{======================================================================}
{ THttpRequest                                                         }
{======================================================================}


{-----------------------------
{ THttpRequest.Alloc
{---
{ Alokovani struktury pozadavku
{---
{ V pripade nedostatku pameti pro strukturu pozadavku vraci False
}

function THttpRequest.Alloc( ABuffSize: Word ): Boolean;
begin
  BuffSize := ABuffSize;
  GetMem( BuffStart, ABuffSize );

  if BuffStart <> nil then
  begin
    Reuse;
    Alloc := True;
  end
  else
    Alloc := False;
end;

{-----------------------------
{ THttpRequest.Free
{---
{ Uvolneni struktury pozadavku
{---
}

procedure THttpRequest.Free;
begin
  if BuffStart <> nil then FreeMem( BuffStart, BuffSize );
end;

{-----------------------------
{ THttpRequest.Reuse
{---
{ Inicializace struktury
{---
}

procedure THttpRequest.Reuse;
begin
  BuffPtr := BuffStart;
  BuffPtr^ := #0;
  State := RST_TRIM_LEFT;

  { Implicitni hodnody polozek zahlavi }

  Path := nil;
  Query := nil;
  Version := nil;
  UserAgent := nil;
  Referer := nil;
{ Cookie := nil;}
  Host := nil;
{ Authorization := nil; }
{ Connection := nil; }
  ContentType := nil;
  ContentLength := INVALID_LENGTH;
  Content := nil;
  ContentIncluded := False;
  Accept := nil;
  Date := 0;
  IfModified := 0;
end;


{-----------------------------
{ THttpRequest.GetNextRecvBuff
{---
{ Vraci buffer do ktereho lze zapsat dalsi data pozadavku
{---
}

procedure THttpRequest.GetNextRecvBuff(
  var ABuffPtr: Pointer; var ABuffSize: Word );
begin
  ABuffPtr := BuffPtr;
  ABuffSize := BuffSize - (BuffPtr - BuffStart) - 1;
  { -1 .. aby se nam tam jeste vesla #0 }
end;


{-----------------------------
{ THttpRequest.GetNextRecvBuff
{---
{ Preklad casti nebo celeho dotazu. ASize je delka nactenych dat.
{ V pripade, ze funkce ocekava dalsi data vrati pstContinue.
{ V pripade nejake syntakticke chyby vraci pstError.
{ V pripade, ze pozadavek byl uspesne nacten vraci pstDone.
{---
}

function THttpRequest.ParseBuff( ASize: Word ): Integer;
label
  L_RST_TRIM_LEFT,
  L_RST_LINE_START,
  L_RST_CONTENT;

var
  Status  : Integer;
  BuffEnd : PChar;
begin

  BuffEnd := BuffPtr + ASize;
  BuffEnd^ := #0;

  case State of

  {---------------------------------------------}
    RST_TRIM_LEFT:
  L_RST_TRIM_LEFT:
    begin
      while BuffPtr^ in [#8, #20, #13] do Inc( BuffPtr );
      if BuffPtr^ = #0 then
      begin
        ParseBuff := rstContinue;
      end
      else begin
        LinePtr := BuffPtr;
        State := RST_LINE_START;
        goto L_RST_LINE_START;
      end;
    end;


    RST_LINE_START:
  L_RST_LINE_START:
    begin
      while not (BuffPtr^ in [#0, #10]) do Inc( BuffPtr );

      if BuffPtr^ = #10 then
      begin
        if LinePtr < BuffPtr then
        begin
          Inc( BuffPtr );
          { Na radce neco je }

          Status := ParseLine;

          if Status = rstOk then
          begin
            State := RST_TRIM_LEFT;
            goto L_RST_TRIM_LEFT;
          end
          else
            ParseBuff := Status;
        end
        else begin
          { Radka je prazdna, zacinaji data entity }
          Inc( BuffPtr );

          if ContentIncluded then
          begin
            Content := BuffPtr;
            State := RST_CONTENT;
            goto L_RST_CONTENT;
          end
          else begin
            ParseBuff := rstOk;
          end;

        end;

      end
      else begin
        ParseBuff := rstContinue;
        State := RST_LINE_CONT;
      end;

    end;

  {---------------------------------------------}
    RST_LINE_CONT:
    begin
      while not (BuffPtr^ in [#0, #10]) do Inc( BuffPtr );

      if BuffPtr^ = #10 then
      begin
        Inc( BuffPtr );

        Status := ParseLine;

        if Status = rstOk then
        begin
          State := RST_TRIM_LEFT;
          goto L_RST_TRIM_LEFT;
        end
        else
          ParseBuff := Status;

      end
      else begin
        ParseBuff := rstContinue;
      end;

    end;

  {---------------------------------------------}
    RST_CONTENT:
  L_RST_CONTENT:
    begin
      if BuffEnd - Content < ContentLength then
      begin
        BuffPtr := BuffEnd;
        ParseBuff := rstContinue;
      end
      else begin
        (Content + ContentLength)^ := #0;
        ParseBuff := rstOk;
      end;
    end;

  end;

end;


{-----------------------------
{ THttpRequest.ParseLine
{---
{ Priradi text a provede preklad dotazu
{ V pripade syntakticke chyby vraci cislo radky, ve ktere nastala chyba
{ jinak vraci 0
{---
}

function  THttpRequest.ParseLine: Integer;
var
  Parser : THttpParser;


  { Method, URL, Path, Query, Version }

  function TrimLeft( P: PChar ): PChar;
  begin
    while P^ in [#1..#9, #11..#32] do Inc( P );
    TrimLeft := P;
  end;

  function CopyToEolAndTrim: PChar;
  var
    Size : Word;
    S    : PChar;
    E    : PChar;
  begin
    S := Parser.CopyToEol( Size );
    E := S + Size - 1;
    while S^ in [#8, #13, #32] do Inc( S );
    while E^ in [#8, #13, #32] do Dec( E );
    (E + 1)^ := #0;
    CopyToEolAndTrim := S;
  end;

  {------------------------------------}

  function ParseCommand: Boolean;
  begin
    case Parser.Token of
      toGET:    Method := mtdGET;
      toPOST:   Method := mtdPOST;
      toHEAD:   Method := mtdHEAD;
      toPUT:    Method := mtdPUT;
      toDELETE: Method := mtdDELETE;
    else
      ParseLine := rstError;
      Exit;
    end;

    Path := CopyToEolAndTrim;

    Version := StrRScan( Path, ' ' );

    if Version <> nil then
    begin
      Version^ := #0;
      Inc( Version );
    end
    else begin
      ParseLine := rstError;
      Exit;
    end;

    Query := StrScan( Path, '?' );

    if Query <> nil then
    begin
      Query^ := #0;
      Inc( Query );
    end;

  end;

  procedure ParseDate( var ADateTime: DateTime );
  var
    Month, Day, Year, Hour, Minute, Sec: Integer;

    function GetMonth: Boolean;
    const
      Months: array[1..12] of PChar =
        ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
          'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
    begin
      Month := 1;

      while (Month < 13) and
            (StrIComp( Parser.TokenPtr, Months[ Month ] ) <> 0) do
      begin
        Inc( Month );
      end;

      GetMonth := Month < 13;
    end;

    procedure GetTime;
    begin
      with Parser do
      begin
        Hour := TokenInt;
        NextToken;
        if Token = ':' then NextToken;
        Minute := TokenInt;
        NextToken;
        if Token = ':' then NextToken;
        Sec := TokenInt;
        NextToken;
      end;
    end;

  begin

    with Parser do
    begin
      NextToken;
      if Token = ':' then NextToken;
      NextToken;
      if Token = ',' then NextToken;

      if GetMonth then
      begin
        NextToken;
        Day := TokenInt;
        NextToken;
        GetTime;
        Year := TokenInt;
      end else
      begin
        Day := TokenInt;
        NextToken;
        if Token = '-' then NextToken;
        GetMonth;
        NextToken;
        if Token = '-' then NextToken;
        Year := TokenInt;
        if Year < 100 then Inc(Year, 1900);
        NextToken;
        GetTime;
      end;

      ADateTime.Year  := Year;
      ADateTime.Month := Month;
      ADateTime.Day   := Day;
      ADateTime.Hour  := Hour;
      ADateTime.Min   := Minute;
      ADateTime.Sec   := Sec;
    end;
  end;


  {------------------------------------}

  procedure ParseUserAgent;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if UserAgent = nil then
    begin
      UserAgent := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;

  {------------------------------------}

{  procedure ParseConnection;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if Connection = nil then
    begin
      Connection := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;}

  {------------------------------------}

{  procedure ParseCookie;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if Cookie = nil then
    begin
      Cookie := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;}

  {------------------------------------}

  procedure ParseContentType;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if ContentType = nil then
    begin
      ContentType := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;

  {------------------------------------}

  procedure ParseHost;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if Host = nil then
    begin
      Host := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;

  {------------------------------------}

  procedure ParseReferer;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if Referer = nil then
    begin
      Referer := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;

  {------------------------------------}

  procedure ParseContentLen;
  var
    Temp : Word;
    L    : Longint;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    Parser.NextToken;

    if Parser.Token = toInteger then
    begin
      L := Parser.TokenInt;
      if L > 65535 then L := 65535;
      { Test < 65535 -- asi neni potreba..chybu generujeme
        pri zaplneni bufferu }
      ContentLength := L;

      if ContentLength > 0 then ContentIncluded := True;
    end
    else begin
      ParseLine := rstError;
      Exit;
    end;

    Parser.CopyToEol( Temp );
  end;

  procedure ParseContent;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    ContentIncluded := True;

    Parser.CopyToEol( Temp );
  end;

  {------------------------------------}

  procedure ParseDateField;
  var
    D : DateTime;
  begin
    ParseDate( D );
    PackTime( D, Date );
  end;

  {------------------------------------}

  procedure ParseIfModified;
  var
    D : DateTime;
  begin
    ParseDate( D );
    PackTime( D, IfModified );
  end;

  {------------------------------------}

  procedure ParseAccept;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if Accept = nil then
    begin
      Accept := CopyToEolAndTrim;
    end
    else begin
      { !!! pokud Entity header obsahuje vice nez jeden Accept,
        pak bychom jej meli napojit za posledni accept
        Accept := Accept + TrimLeft( Parser.CopyToEol( Temp ) );
        to ovsem zatim nejde...takze dalsi accept zahodime }
      Parser.CopyToEol( Temp );
    end;
  end;

  {------------------------------------}

{ procedure ParseAuthorization;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    if    = nil then
    begin
        := CopyToEolAndTrim;
    end
    else
      Parser.CopyToEol( Temp );
  end;}

  {------------------------------------}

  procedure AddExtHeader;
  var
    Temp : Word;
  begin
    Parser.NextToken;

    if Parser.Token <> ':' then
    begin
      ParseLine := rstError;
      Exit;
    end;

    { Zatim neimplementovano }
    Parser.CopyToEol( Temp );
  end;


begin
  Parser.Assign( LinePtr );

  ParseLine := rstOk;

{ Polozky case by mely byt razeny nejlepe podle cetnosti pouziti }

  case Parser.Token of
    toGET,
    toHEAD,
    toPUT,
    toDELETE,
    toPOST:          ParseCommand;

    toContent:       ParseContent;
    toDate:          ParseDateField;
    toIfModified:    ParseIfModified;
    toAccept:        ParseAccept;
    toUserAgent:     ParseUserAgent;
    toContentType:   ParseContentType;
    toContentLength: ParseContentLen;
    toReferer:       ParseReferer;
{   toAuthorization: ParseAuthorization;}
    toHost:          ParseHost;
{   toConnection:    ParseConnection;}

{   toCookie:        ParseCookie;}
  else
    AddExtHeader;
  end;

end;


{======================================================================}
{ THttpResponseText                                                    }
{======================================================================}

{-----------------------------
{ THttpResponseText.Init
{---
{ Inicalizace instance
{---
{ V pripade nedostatku pameti pro strukturu odpovedi vraci False
}

function THttpResponseText.Alloc( ABuffSize: Word ): Boolean;
begin
  BuffSize := ABuffSize;
  GetMem( Buff, ABuffSize );

  if Buff <> nil then
  begin
    Clear;
    Alloc := True;
  end
  else
    Alloc := False;
end;

{-----------------------------
{ THttpResponseText.Done
{---
{ Uvolneni pameti instance
{---
}

procedure THttpResponseText.Free;
begin
  if Buff <> nil then FreeMem( Buff, BuffSize );
end;


{-----------------------------
{ THttpResponseText.Clear
{---
{ Zkraceni celeho textu na 0 znaku
{---
}

procedure THttpResponseText.Clear;
begin
  Text := Buff;
  Text^ := #0;
  TextSize := 0;
end;

{-----------------------------
{ THttpResponseText.Append
{---
{ Pripojeni textu na konec
{---
}

procedure THttpResponseText.Append( AText: PChar ); assembler;
asm
        PUSH DS
        LDS  SI, Self
        MOV  CX, [SI].BuffSize
        SUB  CX, [SI].TextSize
        DEC  CX
        JCXZ @@3                   { CX .. kolik znaku muzeme jeste zapsat }
        LES  DI, [SI].Text         { ES:DI .. kam budeme zapisovat }
        LDS  SI, AText             { DS:SI .. odkud }
        MOV  BX, DS
        OR   BX, SI
        JZ   @@3                   { AText je nil }
        MOV  BX, DI                { Zapamatujeme si offset }
@@1:
        LODSB                      { Kopirovani az do znaku #0 }
        OR   AL, AL
        JZ   @@2
        STOSB
        LOOP @@1
@@2:
        XOR  AL, AL
        MOV  ES:[DI], AL
        LDS  SI, Self              { Uprava ukazovatek }
        MOV  WORD PTR [SI].Text, DI
        SUB  DI, BX
        ADD  [SI].TextSize, DI
@@3:
        POP  DS
end;


{-----------------------------
{ THttpResponseText.AppendBuff
{---
{ Pripojeni textu omezeneho delku na konec
{---
}

procedure THttpResponseText.AppendBuff( ABuff: PChar; ASize: Word ); assembler;
asm
        PUSH DS
        LDS  SI, Self
        MOV  CX, [SI].BuffSize
        SUB  CX, [SI].TextSize
        DEC  CX
        JCXZ @@3
        MOV  AX, ASize
        CMP  AX, CX
        JAE  @@1
        MOV  CX, AX
@@1:
        LES  DI, [SI].Text         { ES:DI .. kam budeme zapisovat }
        LDS  SI, ABuff             { DS:SI .. odkud }
        MOV  BX, DI                { Zapamatujeme si offset }

        REP  MOVSB

        XOR  AL, AL
        MOV  ES:[DI], AL
        LDS  SI, Self              { Uprava ukazovatek }
        MOV  WORD PTR [SI].Text, DI
        SUB  DI, BX
        ADD  [SI].TextSize, DI
@@3:
        POP  DS
end;

{-----------------------------
{ THttpResponseText.AppendStr
{---
{ Pripojeni retezce na konec textu v bufferu
{---
}


procedure THttpResponseText.AppendStr( const AStr: string );
begin
  AppendBuff( @AStr[1], Length( AStr ) );
end;


{-----------------------------
{ THttpResponseText.AppendTime
{---
{ Pripojeni casu ve formatu DDD, dd mmm yyyy hh:mm:ss GMT
{ na konec textu v bufferu
{---
}

procedure THttpResponseText.AppendTime( ATime: Longint );
const
  Days: array[0..6, 0..3] of Char =
    ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' );

  Months: array[1..12, 0..3] of Char =
    ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
      'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
var
  D : DateTime;
  R : array[0..28] of Char;
  S : string[5];

begin
      { 0         1         2 }
      { 01234567890123456789012345678 }
  R := 'DDD, 00 MMM YYYY 00:00:00 GMT';

  UnpackTime( ATime, D );

  MemCopy( @R[0], @Days[ GetDayOfWeek( D )], 3 );
  MemCopy( @R[8], @Months[ D.Month ], 3 );

  Str( D.Day : 2, S );
  if S[1] = ' ' then S[1] := '0';
  MemCopy( @R[5], @S[1], 2 );

  Str( D.Year : 4, S );
  MemCopy( @R[12], @S[1], 4 );

  Str( D.Hour : 2, S );
  if S[1] = ' ' then S[1] := '0';
  MemCopy( @R[17], @S[1], 2 );

  Str( D.Min : 2, S );
  if S[1] = ' ' then S[1] := '0';
  MemCopy( @R[20], @S[1], 2 );

  Str( D.Sec : 2, S );
  if S[1] = ' ' then S[1] := '0';
  MemCopy( @R[23], @S[1], 2 );

  AppendBuff( R, SizeOf( R ) );
end;

{-----------------------------
{ THttpResponseText.AppendInt
{---
{ Pripojeni cisla (Longint) na konec textu v bufferu
{---
}

procedure THttpResponseText.AppendInt( AValue: Longint );
var
  S : string[11];
begin
  Str( AValue, S );
  AppendBuff( @S[1], Length( S ) );
end;

{-----------------------------
{ THttpResponseText.AppendReal
{---
{ Pripojeni cisla (Real) na konec textu v bufferu
{---
}

procedure THttpResponseText.AppendReal( AValue: Real;
  AWidth, ADecimal: Integer );
var
  S : string[20];
begin
  Str( AValue:AWidth:ADecimal, S );
  AppendBuff( @S[1], Length( S ) );
end;


{-----------------------------
{ THttpResponseText.BufferFull
{---
{ Test na plny buffer
{---
}

function THttpResponseText.BufferFull: Boolean;
begin
  BufferFull := TextSize >= BuffSize - 1;
end;

{-----------------------------
{ THttpResponseText.BufferAvail
{---
{ Pocet znaku zbyvajicich do konce bufferu
{---
}

function THttpResponseText.BufferAvail: Integer;
begin
  BufferAvail := BuffSize - TextSize - 1;
end;

{-----------------------------
{ THttpResponseText.STag
{---
{ Pridani start znacky <ATagName> na konec
{---
}

procedure THttpResponseText.STag( ATagName: PChar );
begin
  Append( '<' );
  Append( ATagName );
  Append( '>' );
end;

{-----------------------------
{ THttpResponseText.ETag
{---
{ Pridani ukoncovaci znacky <\ATagName> na konec
{---
}

{ Pridani ukoncovaci znacky na konec }
procedure THttpResponseText.ETag( ATagName: PChar );
begin
  Append( '<\' );
  Append( ATagName );
  Append( '>' );
end;


{======================================================================}
{ THttpResponse                                                        }
{======================================================================}

{-----------------------------
{ THttpResponse.Alloc
{---
{ Alokovani struktury odpovedi
{---
{ V pripade nedostatku pameti pro strukturu odpovedi vraci False
}

function  THttpResponse.Alloc( AMaxRespSize: Word ): Boolean;
begin
  Alloc := Content.Alloc( AMaxRespSize );
end;

{-----------------------------
{ THttpResponse.Free
{---
{ Uvolneni struktury odpovedi
{---
}

procedure THttpResponse.Free;
begin
  Content.Free;
end;

{-----------------------------
{ THttpResponse.Reuse
{---
{ Inicializuje strukturu pro dalsi pouziti, volat i pri
{ prvnim pouziti
{---
}

procedure THttpResponse.Reuse;
begin
{  Version := $0100;}
  StatusCode := HTE_NOT_FOUND;
  ReasonString := nil;
  Location := nil;
  Server := nil;
{  WWWAuthenticate := nil; }
{  Realm := nil; }
  Allow := nil;
  ContentEncoding := nil;
  Pragma := 'no-cache';
  ContentType := 'text/html';
{  ContentVersion := nil;}
  Expires := 0;
  LastModified := 0;
{ Title := nil;}
  StatusLine := False;
  ContentPtr := nil;
  ContentLength := nil;
end;

{-----------------------------
{ THttpResponse.AddResponseHeader
{---
{ Metoda zapise do bufferu radku se statusem.
{---
}

procedure THttpResponse.AddStatusLine;
begin
  Content.Clear;

  { Status Line }

  Content.Append( 'HTTP/1.0 ' );

  Content.AppendInt( StatusCode );

  if ReasonString = nil then
  begin
    ReasonString := HttpGetReasonString( StatusCode );
  end;

  if ReasonString <> nil then
  begin
    Content.Append( ' ' );
    Content.Append( ReasonString );
  end;

  Content.Append( #13#10 );

  StatusLine := True;
end;

{-----------------------------
{ THttpResponse.AddResponseHeader
{---
{ Metoda zapise do bufferu zahlavi odpovedi
{---
}

procedure THttpResponse.AddResponseHeader;
begin
  if not StatusLine then AddStatusLine;

  if Pragma <> nil then
  begin
    Content.Append( 'Pragma: ' );
    Content.Append( Pragma );
    Content.Append( #13#10 );
  end;

  { Location }

  if Location <> nil then
  begin
    Content.Append( 'Location: ' );
    Content.Append( Location );
    Content.Append( #13#10 );
  end;

  { Server }

  if Server <> nil then
  begin
    Content.Append( 'Server: ' );
    Content.Append( Server );
    Content.Append( #13#10 );
  end;
end;

{-----------------------------
{ THttpResponse.BeginEntity
{---
{ Metoda zapise do bufferu zahlavi entity. Po volani teto metody muze
{ aplikace vyplnit telo entity a pote musi zavolat metodu EndEntity
{---
}

procedure THttpResponse.BeginEntity;
begin
  if not StatusLine then AddResponseHeader;

  { Allow }

  if Allow <> nil then
  begin
    Content.Append( 'Allow: ' );
    Content.Append( Allow );
    Content.Append( #13#10 );
  end;

  { Content-Encoding }

  if ContentEncoding <> nil then
  begin
    Content.Append( 'Content-Encoding: ' );
    Content.Append( ContentEncoding );
    Content.Append( #13#10 );
  end;

  { Content-Type }

  if ContentType <> nil then
  begin
    Content.Append( 'Content-Type: ' );
    Content.Append( ContentType );
    Content.Append( #13#10 );
  end;

  { Content-Version }

{  if ContentVersion <> nil then
  begin
    Content.Append( 'Content-Version: ' );
    Content.Append( ContentVersion );
    Content.Append( #13#10 );
  end;}

  { Expires }

  if Expires <> 0 then
  begin
    Content.Append( 'Expires:' );
    Content.AppendTime( Expires );
    Content.Append( #13#10 );
  end;

  { Last-Modified }

  if LastModified <> 0 then
  begin
    Content.Append( 'Last-Modified:' );
    Content.AppendTime( LastModified );
    Content.Append( #13#10 );
  end;

  { Title }

{  if Title <> nil then
  begin
    Content.Append( 'Title: ' );
    Content.Append( Title );
    Content.Append( #13#10 );
  end;}

  { Content-Length }

  Content.Append( 'Content-Length: ' );
  ContentLength := Content.Text;
  Content.Append( '     '#13#10 ); { Mezera na delku obsahu - vyplni EndEntity }

  { Content }

  Content.Append( 'Content: '#13#10#13#10 );
  ContentPtr := Content.Text;

end;


{-----------------------------
{ THttpResponse.EndEntity
{---
{ Zakonceni dat entity. Metoda vyplni polozku ContentLength
{ v zahlavi entity.
{---
}

procedure THttpResponse.EndEntity;
var
  Size     : Word;
  SizeStr  : string[5];
begin
  if ContentPtr <> nil then
  begin
    { Vypoceteme kolik bylo zapsano znaku od volani metody BeginEntity }
    Size := Content.Text - ContentPtr;
    Str( Size, SizeStr );
    MemCopy( ContentLength, @SizeStr[1], Length( SizeStr ) );
  end;
end;


{======================================================================}
{ THttpSession                                                         }
{======================================================================}

{-----------------------------
{ THttpSession.Init
{---
{ Inicializace objektu
{---
}

constructor THttpSession.Init( AMaxReqSize, AMaxRespSize: Word );
begin
  inherited Init;

  if not Request.Alloc( AMaxReqSize ) then Fail;
  if not Response.Alloc( AMaxRespSize ) then Fail;

  State := SST_CLOSED;
end;

{-----------------------------
{ THttpSession.Done
{---
{ Uvolneni instance objektu
{---
}

destructor THttpSession.Done;
begin
  if Socket <> nil then Socket^.Release;

  Request.Free;
  Response.Free;

  inherited Done;
end;

{-----------------------------
{ THttpSession.Reuse
{---
{ Inicializace instance pro nove pouziti
{---
}

procedure THttpSession.Reuse( ASocket: PCoDevice );
begin
  Socket := ASocket;
  FillChar( TxOverlapped, SizeOf( TxOverlapped ), 0 );
  DataProvider := nil;
  ErrorHandler := nil;
  State := SST_REQUEST;
  StopRequest := False;
  Context := nil;
end;

{-----------------------------
{ THttpSession.DoSocketError
{---
{ Obsluha chyby zasuvky
{---
}

procedure THttpSession.DoSocketError( const AText: string;
  AStatus: TCoStatus );
begin
  {$ifndef LOG_CONNRESET }
  if AStatus and 255 = CST_TCP_ERR_CONNRESET then Exit;
  {$endif}

  if Socket <> nil then
  begin
    DoError( AText + ': ' + Socket^.CoStatusToStr( AStatus ) );
  end
  else
    DoError( AText + ': ' + CoStatusToStr( AStatus ) );
end;

{-----------------------------
{ THttpSession.DoHttpError
{---
{ Obsluha HTTP chyby
{---
}

procedure THttpSession.DoHttpError( AStatusCode: Word );
var
  Err: string[5];
begin
  Str( AStatusCode, Err );
  DoError( 'HTTP Error: ' + Err );
end;


{-----------------------------
{ THttpSession.DoError
{---
{ Obsluha obecne chyby
{---
}

procedure THttpSession.DoError( const AText: string );
begin
  if Assigned( ErrorHandler ) then
  begin
    ErrorHandler( @Self, AText );
  end;
end;

{-----------------------------
{ THttpSession.Tick
{---
{ Krok automatu HTTP relace
{---
}

function THttpSession.Tick: Boolean;
label
  L_SST_REQUEST,
  L_SST_RECEIVE,
  L_SST_HANDLE,
  L_SST_SEND,
  L_SST_DISCONN,
  L_SST_UNBIND,
  L_SST_CLOSED,
  L_SST_RESET;

  procedure PrepareErrorResponse( AStatusCode: Word );
  begin
    with Response do
    begin
      Reuse;
      StatusCode   := AStatusCode;
      AddStatusLine;
    end;
  end;

var
  Status  : TCoStatus;
  ErrLine : Integer;
  Buff    : Pointer;
  Size    : Word;
begin
  Tick := False;

  case State of

    SST_REQUEST:
  L_SST_REQUEST:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_REQUEST )' );
      {$ENDIF}

      Request.Reuse;
      State := SST_RECEIVE;

      { Ulozime cas, pri kterem nasilne ukoncime relaci }
      ExpireTime := CoGetTimeEx( ConnTimeout );

      goto L_SST_RECEIVE;
    end;

  {---------------------------------------------}
    SST_RECEIVE:
  L_SST_RECEIVE:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_RECEIVE )' );
      {$ENDIF}

      Request.GetNextRecvBuff( Buff, Size );

      if Size > 0 then
      begin

        Status := Socket^.CoRecvBuffer( Buff, Size, @RecvLen, 0, @Overlapped );
        case Status of

          CST_SUCCESS:
          begin

            case Request.ParseBuff( RecvLen ) of

              rstOk:
              begin
                { Dotaz byl uspesne nacten a prelozen }
                State := SST_HANDLE;
                goto L_SST_HANDLE;
              end;

              rstContinue:
              begin
                goto L_SST_RECEIVE;
              end

            else { Chyba }

              DoHttpError( HTE_BAD_REQUEST );

              PrepareErrorResponse( HTE_BAD_REQUEST );
              State := SST_SEND;
              goto L_SST_SEND;
            end;

          end;

          CST_PENDING:
          begin
            State := SST_RECEIVE_WAIT;
          end;

        else
          { Chyba }

          DoSocketError( 'CoRecvBuffer() failed', Status );

          State := SST_DISCONN;
        end;

      end
      else begin

        { Pozadavek nebyl nacten cely, protoze v bufferu jiz neni misto }

      end;
    end;

  {---------------------------------------------}
    SST_RECEIVE_WAIT:
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );
      case Status of

        CST_SUCCESS:
        begin

          case Request.ParseBuff( RecvLen ) of

            rstOk:
            begin
              { Dotaz byl uspesne nacten a prelozen }
              State := SST_HANDLE;
              goto L_SST_HANDLE;
            end;

            rstContinue:
            begin
              { Jeste nebyl nacten cely dotaz }
              goto L_SST_RECEIVE;
            end

          else { Chyba }

            DoHttpError( HTE_BAD_REQUEST );

            PrepareErrorResponse( HTE_BAD_REQUEST );
            State := SST_SEND;
            goto L_SST_SEND;
          end;

        end;

        CST_PENDING:
        begin

          if (ConnTimeout > 0) and CoTimeLT( ExpireTime, CoGetTime ) then
          begin
            DoError( 'Connection timeout' );
            State := SST_RESET;
            goto L_SST_RESET;
          end;

          { Cekame na prijem }
        end;

      else
        { Chyba }

        DoSocketError( 'CoRecvBuffer() failed', Status );

        State := SST_DISCONN;
      end;


    end;

  {---------------------------------------------}
    SST_HANDLE:
  L_SST_HANDLE:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_HANDLE )' );
      {$ENDIF}

      if Request.ContentIncluded and
         (Request.ContentLength = INVALID_LENGTH) then
      begin

        DoHttpError( HTE_LENGTH_REQUIRED );
        PrepareErrorResponse( HTE_LENGTH_REQUIRED );

        State := SST_SEND;
        goto L_SST_SEND;

      end
      else if StrLIComp( Request.Version, 'HTTP/1.', 7 ) <> 0 then
      begin
        { Nesouhlasi verze protokolu }

        DoHttpError( HTE_HTTP_VERSION_NOTSUPP );
        PrepareErrorResponse( HTE_HTTP_VERSION_NOTSUPP );

        State := SST_SEND;
        goto L_SST_SEND;

      end
      else begin

        { Inicializace struktury odpovedi }
        Response.Reuse;

        if (not Assigned(DataProvider)) or DataProvider( @Self ) then
        begin
          State := SST_SEND;
          goto L_SST_SEND;
        end
        else
          State := SST_HANDLE_WAIT;

      end;
    end;

  {---------------------------------------------}
    SST_HANDLE_WAIT:
    begin

      { Cekame v tomto stavu tak dlouho dokud DataProvider
        nepripravi data }

      if (not Assigned(DataProvider)) or DataProvider( @Self ) then
      begin
        State := SST_SEND;
        goto L_SST_SEND;
      end;
    end;

  {---------------------------------------------}
    SST_SEND: { Odeslani dat }
  L_SST_SEND:
    begin
      Status := Socket^.CoGetIOResult( @TxOverlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin

          {$IFDEF DEBUG_HTTP_SVR}
          Trace( 'THttpSession.Tick( SST_SEND )' );
          {$ENDIF}

          if not Response.StatusLine then Response.AddStatusLine;

          { Pokud odpoved neobsahuje entitu, pak doplnime CR,LF }
    {      if Response.ContentPtr = nil then
          begin
            Response.Text.Append( #13#10 );
          end;}

          if Response.Content.BufferFull then
          begin
            { Buffer je plny.. ukoncime spojeni a hlasime chybu }
            DoError( 'Response buffer full, closing connection...');
            State := SST_DISCONN;
            goto L_SST_DISCONN;
          end;

          Status := Socket^.CoSendBuffer( Response.Content.Buff,
            Response.Content.TextSize, 0, @TxOverlapped );

          case Status of

            CST_SUCCESS,
            CST_PENDING:
            begin
              { Data byla uspesne odeslana }

              { Zjistime zda mame spojeni zachovat, nebo ukoncit }

              if True {!@# keep-alive..zatim nepodporujememe} then
              begin
                State := SST_DISCONN;
                goto L_SST_DISCONN;
              end
              else begin
                State := SST_REQUEST;
                goto L_SST_REQUEST;
              end;
            end;

          else
            { Chyba }

            DoSocketError( 'CoSend() failed', Status );

            State := SST_DISCONN;
          end;


        end;

        CST_PENDING:
        begin
          { Cekame na odeslani dat }
        end;

      else
        { Chyba }
        DoSocketError( 'CoSendBuffer() failed', Status );

        State := SST_DISCONN;
      end;

    end;

  {---------------------------------------------}
    SST_DISCONN: { Ukonceni spojeni }
  L_SST_DISCONN:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_DISCONN )' );
      {$ENDIF}


      Status := Socket^.CoDisconnect( 0, @Overlapped );

      case Status of

        CST_SUCCESS:
        begin
          State := SST_UNBIND;
          goto L_SST_UNBIND;
        end;

        CST_PENDING:
        begin
          State := SST_DISCONN_WAIT;
        end;

      else
        { Chyba }

        {$ifndef LOG_NOTCONN }
        if Status and 255 <> CST_ERR_NOTCONN then
        {$endif}
          DoSocketError( 'CoDisconnect() failed', Status );

        State := SST_UNBIND;
      end;
    end;


  {---------------------------------------------}
    SST_DISCONN_WAIT: { Cekani na potvrzeni ukonceni spojeni }
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin
          State := SST_UNBIND;
          goto L_SST_UNBIND;
        end;

        CST_PENDING:
        begin

          if (ConnTimeout > 0) and CoTimeLT( ExpireTime, CoGetTime ) then
          begin
            DoError( 'Connection timeout' );
            State := SST_RESET;
            goto L_SST_RESET;
          end;

          { Zustaneme v tomto stavu }
        end;

      else
        { Chyba }

        {$ifndef LOG_NOTCONN }
        if Status and 255 <> CST_ERR_NOTCONN then
        {$endif}
          DoSocketError( 'CoDisconnect() failed', Status );

        State := SST_UNBIND;
      end;

    end;


  {---------------------------------------------}
    SST_UNBIND:
  L_SST_UNBIND:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_UNBIND )' );
      {$ENDIF}


      Status := Socket^.CoUnbind( 0, @Overlapped );

      case Status of

        CST_SUCCESS:
        begin
          { Uvolneni zasuvky z pameti }
          Socket^.Release;
          Socket := nil;

          State := SST_CLOSED;
          goto L_SST_CLOSED;
        end;

        CST_PENDING:
        begin
          State := SST_UNBIND_WAIT;
        end;

      else
        { Chyba }

        DoSocketError( 'CoDisconnect() failed', Status );

        State := SST_CLOSED;
      end;

    end;

  {---------------------------------------------}
    SST_UNBIND_WAIT:
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin
          { Uvoleni zasuvky z pameti }
          Socket^.Release;
          Socket := nil;

          State := SST_CLOSED;
          goto L_SST_CLOSED;
        end;

        CST_PENDING:
        begin
          { Zustaneme v tomto stavu }
        end;

      else
        { Chyba }

        DoSocketError( 'CoUnbind() failed', Status );

        State := SST_CLOSED;
      end;

    end;

  {---------------------------------------------}
    SST_CLOSED:
  L_SST_CLOSED:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_CLOSED )' );
      {$ENDIF}

      Tick := True;
    end;

  {---------------------------------------------}
    SST_RESET:
  L_SST_RESET:
    begin
      {$IFDEF DEBUG_HTTP_SVR}
      Trace( 'THttpSession.Tick( SST_RESET )' );
      {$ENDIF}

      Socket^.CoCancelIO( @Overlapped, 0 );
      State := SST_RESET_WAIT;
    end;

  {---------------------------------------------}
    SST_RESET_WAIT:
    begin
      if Socket^.CoGetIOResult( @Overlapped, 0 ) <> CST_PENDING then
      begin
        State := SST_UNBIND;
        Goto L_SST_UNBIND;
      end;
    end;

  end;

end;



{======================================================================}
{ THttpServer                                                          }
{======================================================================}

{-----------------------------
{ THttpServer.Init
{---
{---
}

constructor THttpServer.Init( AMaxSessions: Integer;
  const ANetStackId: string; AMaxReqSize, AMaxRespSize: Word );
begin
  inherited Init;
  State := HST_CLOSED;
  NetStackId := ANetStackId;
  MaxSessions := AMaxSessions;
  MaxReqSize := AMaxReqSize;
  MaxRespSize := AMaxRespSize;
  ConnTimeout := 10000; {10s - na spojeni}
  StartRequest := True;
  Port := 80;
end;


{-----------------------------
{ THttpServer.Done
{---
{ Uvolneni instance serveru
{---
}

destructor THttpServer.Done;
var
  P : PHttpSession;
begin

  if Socket <> nil then NetCloseSocket( Socket );

  { Pri normalnim ukonceni by PendingList a ClosedList
    mely byt prazdne }

  while ClosedList <> nil do
  begin
    P := ClosedList;
    ClosedList := P^.NextLink;
    P^.Free;
  end;

  while PendingList <> nil do
  begin
    P := PendingList;
    PendingList := P^.NextLink;
    P^.Free;
  end;

  inherited Done;
end;

{-----------------------------
{ THttpServer.NewSession
{---
{ Vytvoreni nove HTTP relace
{ Tuto virtualni metodu mohou potomci HTTP serveru predefinovat
{ a vracet potomka THttpSession
{---
}

function  THttpServer.NewSession: PHttpSession;
begin
  NewSession := New( PHttpSession, Init( MaxReqSize, MaxRespSize ) );
end;

{-----------------------------
{ THttpServer.Tick
{---
{ Krok automatu HTPP serveru
{---
}

function THttpServer.Tick: Boolean;
label
  L_HST_ACCEPT,
  L_HST_BIND,
  L_HST_LISTEN,
  L_HST_UNBIND,
  L_HST_CLOSED;

var
  Status  : TCoStatus;
  PortStr : string[5];  { Cislo portu }


  { Prijmuti spojeni a vytvoreni nove relace }

  procedure Accept;
  var
    P : PHttpSession;
  begin
    if ClosedList = nil then
    begin
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick: Creating new session' );
      {$endif}

      { Closed list je prazdny, vytvorime novou relaci }
      P := NewSession;
    end
    else begin
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick: Reusing session' );
      {$endif}

      { V Closed List uz nejaka relace je.. tak ji pouzijeme }
      P := ClosedList;
      ClosedList := P^.NextLink;
    end;

    if P <> nil then
    begin
      { Zarazeni relace do pending listu }

      Inc( SessionCount );
      P^.NextLink := PendingList;
      PendingList := P;

      { Inicializace relace }
      P^.Reuse( ClientSocket );
      CoCopyAddress( @P^.ClientAddr, @ClientAddr );
      P^.DataProvider := DataProvider;
      P^.ErrorHandler := ErrorHandler;
      P^.ConnTimeout  := ConnTimeout;

    end
    else begin
      { Neni dostatek pameti pro alokovani relace }
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick: Accept, Memory overflow';
      {$endif}

      DoError( 'Accept: Memory overflow' );

      { Unbind nebudeme provadet, protoze by nejspise zpusobil dalsi
        chybu kvuli nedostatku pameti... }

      NetCloseSocket( ClientSocket );
    end;
  end;

  { Obsluha tiku jednotlivych relaci }

  procedure HandleSessions;
  var
    Prev : PHttpSession;
    Next : PHttpSession;
    P    : PHttpSession;
  begin
    Prev := nil;
    P := PendingList;

    while P <> nil do
    begin

      if P^.Tick then
      begin

        {$ifdef DEBUG_HTTP_SVR}
        Trace( 'THttpServer.Tick: Closing session' );
        {$endif}

        { Relace dobehla... }

        if Prev = nil then
        begin
          PendingList := P^.NextLink;
        end
        else begin
          Prev^.NextLink := P^.NextLink;
        end;

        Next := P^.NextLink;

        { P je uvolneno ze seznamu PendingList }

        Dec( SessionCount );


        { !@# tady by slo kontrolovat, kolik relaci budeme
          udrzovat v cache ClosedList. Bez teto upravy je to
          vzdycky MaxSessions }

        if {!@#} False then
        begin
          P^.Free;
        end
        else begin
          { Vlozime P do ClosedListu }
          P^.NextLink := ClosedList;
          ClosedList := P;
        end;

        P := Next;
      end
      else begin
        Prev := P;
        P := P^.NextLink;
      end;
    end;
  end;

begin
  { Nasloucha na portu, vytvari spojeni a s nim souvisejici relaci.. }
  { Pravidelne tika s relacema v seznamu. pokud tik relace vrati
    True, pak server relaci uvolni ... }

  { Udrzovat seznam uzavrenych relaci, aby se pri kazdem dotazu
    nealokovala zbytecne pamet.. tento seznam omezit na urcity pocet }

  Tick := False;

  { Obsluha automatu HTTP relaci }
  HandleSessions;

  { Hlavni automat }
  case State of

  {---------------------------------------------}
    HST_ACCEPT:
  L_HST_ACCEPT:
    begin

      if StopRequest then
      begin
        State := HST_UNBIND
      end
      else begin

        if SessionCount < MaxSessions then
        begin

          Status := Socket^.CoAccept( @ClientAddr, ClientSocket,
                      TCoAcceptFilterProc( AcceptFilter ), 0, @Overlapped );

          case Status of

            CST_SUCCESS:
            begin
              Accept;
            end;

            CST_PENDING:
            begin
              State := HST_ACCEPT_WAIT;
            end;

          else
            { Chyba }
            StartRequest := True;

            DoSocketError( 'CoAccept() failed', Status );

            { Provedeme Unbind, Bind a znovu Accept }

            State := HST_UNBIND;
          end;

        end;

      end;

    end;

  {---------------------------------------------}
    HST_ACCEPT_WAIT:
    begin
      if StopRequest then Socket^.CoCancelIO( @Overlapped, 0 );

      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin
          Accept;
          State := HST_ACCEPT;
        end;

        CST_PENDING:
        begin
          { Zustavame v tomto stavu }
        end;

      else
        { Chyba }

        if Status and 255 <> CST_ERR_ABORTED then
        begin
          StartRequest := True;
          DoSocketError( 'CoAccept() failed', Status );
        end;

        { Provedeme Unbind, Bind a znovu Accept }

        State := HST_UNBIND;
        goto L_HST_UNBIND;
      end;

    end;


  {---------------------------------------------}
    HST_BIND:
  L_HST_BIND:
    begin
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick( HST_BIND )' );
      {$endif}

      Status := Socket^.CoBind( nil, COF_PROPAGATE, @Overlapped );

      case Status of

        CST_SUCCESS:
        begin
          State := HST_ACCEPT;
          goto L_HST_ACCEPT;
        end;

        CST_PENDING:
        begin
          State := HST_BIND_WAIT;
        end;

      else
        { Chyba }
        DoSocketError( 'CoBind() failed', Status );

        State := HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_BIND_WAIT:
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin
          State := HST_LISTEN;
          goto L_HST_LISTEN;
        end;

        CST_PENDING:
        begin
          { Cekame na bind }
        end;

      else
        { Chyba }
        DoSocketError( 'CoBind() failed', Status );

        State := HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_LISTEN:
  L_HST_LISTEN:
    begin
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick( HST_LISTEN )' );
      {$endif}

      Status := Socket^.CoListen( {!@#-jakou hodnotu?} 3, 0, @Overlapped );

      case Status of

        CST_SUCCESS:
        begin
          State := HST_ACCEPT;
          goto L_HST_ACCEPT;
        end;

        CST_PENDING:
        begin
          State := HST_LISTEN_WAIT;
        end;

      else
        { Chyba }
        DoSocketError( 'CoListen() failed', Status );

        State := HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_LISTEN_WAIT:
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of

        CST_SUCCESS:
        begin
          State := HST_ACCEPT;
          goto L_HST_ACCEPT;
        end;

        CST_PENDING:
        begin
          { Cekame na listen }
        end;

      else
        { Chyba }
        DoSocketError( 'CoListen() failed', Status );

        State := HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_UNBIND:
  L_HST_UNBIND:
    begin
      {$ifdef DEBUG_HTTP_SVR}
      Trace( 'THttpServer.Tick( HST_UNBIND )' );
      {$endif}

      Status := Socket^.CoUnBind( 0, @Overlapped );

      case Status of
        CST_SUCCESS:
        begin
          State := HST_CLOSED;
          goto L_HST_CLOSED;
        end;

        CST_PENDING:
        begin
          State := HST_BIND_WAIT;
        end;

      else
        { Chyba }
        DoSocketError( 'CoUnbind() failed', Status );

        State := HST_CLOSED;
        goto  L_HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_UNBIND_WAIT:
    begin
      Status := Socket^.CoGetIOResult( @Overlapped, 0 );

      case Status of
        CST_SUCCESS:
        begin
          State := HST_CLOSED;
          goto L_HST_CLOSED;
        end;

        CST_PENDING:
        begin
          { Zustavame v tomto stavu }
        end;

      else
        { Chyba }
        DoSocketError( 'CoUnbind() failed', Status );

        State := HST_CLOSED;
        goto  L_HST_CLOSED;
      end;
    end;

  {---------------------------------------------}
    HST_CLOSED:
  L_HST_CLOSED:
    begin
      if StartRequest then
      begin
        StopRequest := False;
        StartRequest := False;

        if Socket = nil then
        begin
          Str( Port, PortStr );
          Status := NetOpenSocket( 'TCP', 'LPORT=' + PortStr,
                      NetStackId, Socket );
        end
        else
          Status := CST_SUCCESS;

        if Status = CST_SUCCESS then
        begin
          State := HST_BIND;
        end
        else begin
          DoSocketError( 'NetOpenSocket() failed', Status );
          Tick := True;
        end;
      end
      else if StopRequest and (PendingList = nil) then
      begin
        StopRequest := False;

        {$ifdef DEBUG_HTTP_SVR}
        Trace( 'THttpServer.Tick( HST_CLOSED ) = True' );
        {$endif}

        { Pozadavek na zastaveni a uz neexistuje zadna relace... }
        Tick := True;
      end
      else
        Tick := True; { Zustavame ve stavu HST_CLOSED }
    end;

  end;

end;


{-----------------------------
{ THttpServer.Stop
{---
{ Zastaveni serveru
{---
}

procedure THttpServer.Stop;
begin
  {$ifdef DEBUG_HTTP_SVR}
  Trace( 'THttpServer.Stop() called' );
  {$endif}
  StopRequest := True;
end;


{-----------------------------
{ THttpServer.Start
{---
{ Spusteni serveru
{---
}

procedure THttpServer.Start;
begin
  {$ifdef DEBUG_HTTP_SVR}
  Trace( 'THttpServer.Start() called' );
  {$endif}
  StartRequest := True;
end;

{-----------------------------
{ THttpServer.DoSocketError
{---
{ Funkce volana v pripade chyby TCP zasuvky
{---
}

procedure THttpServer.DoSocketError( const AText: string; AStatus: TCoStatus );
begin
  if Socket <> nil then
  begin
    DoError( AText + ': ' + Socket^.CoStatusToStr( AStatus ) );
  end
  else
    DoError( AText + ': ' + CoStatusToStr( AStatus ) );
end;

{-----------------------------
{ THttpServer.DoError
{---
{ Funkce volana v pripade chyby TCP zasuvky
{---
}

procedure THttpServer.DoError( const AText: string );
begin
  if Assigned( ErrorHandler ) then
  begin
    ErrorHandler( nil, AText );
  end;
end;


begin
  { Inicializace tabulky symbolu parseru HTTP requestu }
  InitSymbolTable;
end.
