pascal
/
fpc
mirror of https://gitlab.com/freepascal.org/fpc/source.git


			
							12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270
							{ HTTP server and client components

  Copyright (C) 2006-2007 Micha Nelissen

  This library is Free software; you can redistribute it and/or modify it
  under the terms of the GNU Library General Public License as published by
  the Free Software Foundation; either version 2 of the License, or (at your
  option) any later version.

  This program is distributed in the hope that it will be useful, but WITHOUT
  ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
  for more details.

  You should have received a Copy of the GNU Library General Public License
  along with This library; if not, Write to the Free Software Foundation,
  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  
  This license has been modified. See file LICENSE.ADDON for more information.
  Should you find these sources without a LICENSE File, please contact
  me at [email protected]
}

unit lhttp;

{$mode objfpc}{$h+}
{$inline on}

interface

uses
  classes, sysutils, lnet, levents, lhttputil, lstrbuffer;

type
  TLHTTPMethod = (hmHead, hmGet, hmPost, hmUnknown);
  TLHTTPMethods = set of TLHTTPMethod;
  TLHTTPParameter = (hpConnection, hpContentLength, hpContentType,
    hpAccept, hpAcceptCharset, hpAcceptEncoding, hpAcceptLanguage, hpHost,
    hpFrom, hpReferer, hpUserAgent, hpRange, hpTransferEncoding,
    hpIfModifiedSince, hpIfUnmodifiedSince, hpCookie);
  TLHTTPStatus = (hsUnknown, hsOK, hsNoContent, hsMovedPermanently, hsFound, hsNotModified, 
    hsBadRequest, hsForbidden, hsNotFound, hsPreconditionFailed, hsRequestTooLong,
    hsInternalError, hsNotImplemented, hsNotAllowed);
  TLHTTPTransferEncoding = (teIdentity, teChunked);
  TLHTTPClientError = (ceNone, ceMalformedStatusLine, ceVersionNotSupported,
    ceUnsupportedEncoding);

const
  HTTPDisconnectStatuses = [hsBadRequest, hsRequestTooLong, hsForbidden, 
    hsInternalError, hsNotAllowed];
  HTTPMethodStrings: array[TLHTTPMethod] of string =
    ('HEAD', 'GET', 'POST', '');
  HTTPParameterStrings: array[TLHTTPParameter] of string =
    ('CONNECTION', 'CONTENT-LENGTH', 'CONTENT-TYPE', 'ACCEPT', 
     'ACCEPT-CHARSET', 'ACCEPT-ENCODING', 'ACCEPT-LANGUAGE', 'HOST',
     'FROM', 'REFERER', 'USER-AGENT', 'RANGE', 'TRANSFER-ENCODING',
     'IF-MODIFIED-SINCE', 'IF-UNMODIFIED-SINCE', 'COOKIE');
  HTTPStatusCodes: array[TLHTTPStatus] of dword =
    (0, 200, 204, 301, 302, 304, 400, 403, 404, 412, 414, 500, 501, 504);
  HTTPTexts: array[TLHTTPStatus] of string = 
    ('', 'OK', 'No Content', 'Moved Permanently', 'Found', 'Not Modified', 'Bad Request', 'Forbidden', 
     'Not Found', 'Precondition Failed', 'Request Too Long', 'Internal Error',
     'Method Not Implemented', 'Method Not Allowed');
  HTTPDescriptions: array[TLHTTPStatus] of string = (
      { hsUnknown }
    '',
      { hsOK }
    '',
      { hsNoContent }
    '',
      { hsMovedPermanently }
    '',
      { hsFound }
    '',
      { hsNotModified }
    '',
      { hsBadRequest }
    '<html><head><title>400 Bad Request</title></head><body>'+#10+
    '<h1>Bad Request</h1>'+#10+
    '<p>Your browser did a request this server did not understand.</p>'+#10+
    '</body></html>'+#10,
      { hsForbidden }
    '<html><head><title>403 Forbidden</title></head><body>'+#10+
    '<h1>Forbidden</h1>'+#10+
    '<p>You do not have permission to access this resource.</p>'+#10+
    '</body></html>'+#10,
      { hsNotFound }
    '<html><head><title>404 Not Found</title></head><body>'+#10+
    '<h1>Not Found</h1>'+#10+
    '<p>The requested URL was not found on this server.</p>'+#10+
    '</body></html>'+#10,
      { hsPreconditionFailed }
    '<html><head><title>412 Precondition Failed</title></head><body>'+#10+
    '<h1>Precondition Failed</h1>'+#10+
    '<p>The precondition on the request evaluated to false.</p>'+#10+
    '</body></html>'+#10,
      { hsRequestTooLong }
    '<html><head><title>414 Request Too Long</title></head><body>'+#10+
    '<h1>Bad Request</h1>'+#10+
    '<p>Your browser did a request that was too long for this server to parse.</p>'+#10+
    '</body></html>'+#10,
      { hsInternalError }
    '<html><head><title>500 Internal Error</title></head><body>'+#10+
    '<h1>Internal Error</h1>'+#10+
    '<p>An error occurred while generating the content for this request.</p>'+#10+
    '</body></html>'+#10,
      { hsNotImplemented }
    '<html><head><title>501 Method Not Implemented</title></head><body>'+#10+
    '<h1>Method Not Implemented</h1>'+#10+
    '<p>The method used in the request is invalid.</p>'+#10+
    '</body></html>'+#10,
      { hsNotAllowed }
    '<html><head><title>504 Method Not Allowed</title></head><body>'+#10+
    '<h1>Method Not Allowed</h1>'+#10+
    '<p>The method used in the request is not allowed on the resource specified in the URL.</p>'+#10+
    '</body></html>'+#10);


type
  TLHTTPSocket = class;
  TLHTTPConnection = class;
  TLHTTPClientSocket = class;
  
  PRequestInfo = ^TRequestInfo;
  TRequestInfo = record
    RequestType: TLHTTPMethod;
    DateTime: TDateTime;
    Method: pchar;
    Argument: pchar;
    QueryParams: pchar;
    VersionStr: pchar;
    Version: dword;
  end;

  PClientRequest = ^TClientRequest;
  TClientRequest = record
    Method: TLHTTPMethod;
    URI: string;
    QueryParams: string;
    RangeStart: qword;
    RangeEnd: qword;
  end;

  PClientResponse = ^TClientResponse;
  TClientResponse = record
    Status: TLHTTPStatus;
    Version: dword;
    Reason: string;
  end;

  PHeaderOutInfo = ^THeaderOutInfo;
  THeaderOutInfo = record
    ContentLength: integer;
    TransferEncoding: TLHTTPTransferEncoding;
    ExtraHeaders: TStringBuffer;
    Version: dword;
  end;

  PResponseInfo = ^TResponseInfo;
  TResponseInfo = record
    Status: TLHTTPStatus;
    ContentType: string;
    ContentCharset: string;
    LastModified: TDateTime;
  end;

  TWriteBlockStatus = (wsPendingData, wsWaitingData, wsDone);
  TWriteBlockMethod = function: TWriteBlockStatus of object;

  TOutputItem = class(TObject)
  protected
    FBuffer: pchar;
    FBufferPos: integer;
    FBufferSize: integer;
    FBufferOffset: integer;
    FOutputPending: boolean;
    FEof: boolean;
    FPrev: TOutputItem;
    FNext: TOutputItem;
    FPrevDelayFree: TOutputItem;
    FNextDelayFree: TOutputItem;
    FSocket: TLHTTPSocket;
    FWriteBlock: TWriteBlockMethod;

    procedure DoneInput; virtual;
    function  HandleInput(ABuffer: pchar; ASize: integer): integer; virtual;
    function  WriteBlock: TWriteBlockStatus; virtual;
  public
    constructor Create(ASocket: TLHTTPSocket);
    destructor Destroy; override;

    procedure LogError(const AMessage: string);

    property Socket: TLHTTPSocket read FSocket;
  end;

  TProcMethod = procedure of object;

  TBufferOutput = class(TOutputItem)
  protected
    FPrepareBuffer: TProcMethod;
    FFinishBuffer: TProcMethod;
    FBufferMemSize: integer;

    procedure PrepareBuffer;
    procedure PrepareChunk;
    procedure FinishBuffer;
    procedure FinishChunk;
    procedure SelectChunked;
    procedure SelectBuffered;
    procedure SelectPlain;
    procedure PrependBufferOutput(MinBufferSize: integer);
    procedure PrependStreamOutput(AStream: TStream; AFree: boolean);
    function FillBuffer: TWriteBlockStatus; virtual; abstract;
    function WriteChunk: TWriteBlockStatus;
    function WriteBuffer: TWriteBlockStatus;
    function WritePlain: TWriteBlockStatus;
    function WriteBlock: TWriteBlockStatus; override;
  public
    constructor Create(ASocket: TLHTTPSocket);
    destructor Destroy; override;

    procedure Add(ABuf: pointer; ASize: integer);
    procedure Add(const AStr: string);
    procedure Add(AStream: TStream; AQueue: boolean = false; AFree: boolean = true);
  end;

  TMemoryOutput = class(TOutputItem)
  protected
    FFreeBuffer: boolean;
  public
    constructor Create(ASocket: TLHTTPSocket; ABuffer: pointer; 
      ABufferOffset, ABufferSize: integer; AFreeBuffer: boolean);
    destructor Destroy; override;
  end;

  TStreamOutput = class(TBufferOutput)
  protected
    FStream: TStream;
    FFreeStream: boolean;
    FStreamSize: integer;

    function FillBuffer: TWriteBlockStatus; override;
  public
    constructor Create(ASocket: TLHTTPSocket; AStream: TStream; AFreeStream: boolean);
    destructor Destroy; override;
  end;
  
  TMemoryStreamOutput = class(TOutputItem)
  protected
    FFreeStream: boolean;
    FStream: TMemoryStream;

    function WriteBlock: TWriteBlockStatus; override;
  public
    constructor Create(ASocket: TLHTTPSocket; AStream: TMemoryStream; AFreeStream: boolean);
    destructor Destroy; override;
  end;

  TChunkState = (csInitial, csData, csDataEnd, csTrailer, csFinished);
  TLHTTPParameterArray = array[TLHTTPParameter] of pchar;
  
  TParseBufferMethod = function: boolean of object;
  TLInputEvent = function(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer of object;
  TLCanWriteEvent = procedure(ASocket: TLHTTPClientSocket; var OutputEof: TWriteBlockStatus) of object;
  TLHTTPClientEvent = procedure(ASocket: TLHTTPClientSocket) of object;

  TLHTTPConnection = class(TLTcp)
  protected
    procedure CanSendEvent(aSocket: TLHandle); override;
    procedure LogAccess(const AMessage: string); virtual;
    procedure ReceiveEvent(aSocket: TLHandle); override;
  public
    destructor Destroy; override;
  end;

  TLHTTPSocket = class(TLSocket)
  protected
    FBuffer: pchar;
    FBufferPos: pchar;
    FBufferEnd: pchar;
    FBufferSize: integer;
    FRequestBuffer: pchar;
    FRequestPos: pchar;
    FRequestInputDone: boolean;
    FRequestHeaderDone: boolean;
    FOutputDone: boolean;
    FInputRemaining: integer;
    FChunkState: TChunkState;
    FCurrentInput: TOutputItem;
    FCurrentOutput: TOutputItem;
    FLastOutput: TOutputItem;
    FKeepAlive: boolean;
    FParseBuffer: TParseBufferMethod;
    FParameters: TLHTTPParameterArray;
    FDelayFreeItems: TOutputItem;

    procedure AddContentLength(ALength: integer); virtual; abstract;
    function  CalcAvailableBufferSpace: integer;
    procedure DelayFree(AOutputItem: TOutputItem);
    procedure Disconnect; override;
    procedure DoneBuffer(AOutput: TBufferOutput); virtual;
    procedure FreeDelayFreeItems;
    procedure LogAccess(const AMessage: string); virtual;
    procedure LogMessage; virtual;
    procedure FlushRequest; virtual;
    procedure PackRequestBuffer;
    procedure PackInputBuffer;
    function  ParseRequest: boolean;
    function  ParseEntityPlain: boolean;
    function  ParseEntityChunked: boolean;
    procedure ParseLine(pLineEnd: pchar); virtual;
    procedure ParseParameterLine(pLineEnd: pchar);
    function  ProcessEncoding: boolean;
    procedure ProcessHeaders; virtual; abstract;
    procedure RelocateVariable(var AVar: pchar);
    procedure RelocateVariables; virtual;
    procedure ResetDefaults; virtual;
    function  SetupEncoding(AOutputItem: TBufferOutput; AHeaderOut: PHeaderOutInfo): boolean;
    procedure WriteError(AStatus: TLHTTPStatus); virtual;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure AddToOutput(AOutputItem: TOutputItem);
    procedure PrependOutput(ANewItem, AItem: TOutputItem);
    procedure RemoveOutput(AOutputItem: TOutputItem);
    procedure HandleReceive;
    function  ParseBuffer: boolean;
    procedure WriteBlock;
    
    property Parameters: TLHTTPParameterArray read FParameters;
  end;

  { http server }

  TSetupEncodingState = (seNone, seWaitHeaders, seStartHeaders);
  
  TLHTTPServerSocket = class(TLHTTPSocket)
  protected
    FLogMessage: TStringBuffer;
    FSetupEncodingState: TSetupEncodingState;

    procedure AddContentLength(ALength: integer); override;
    procedure DoneBuffer(AOutput: TBufferOutput); override;
    procedure FlushRequest; override;
    function  HandleURI: TOutputItem; virtual;
    procedure LogAccess(const AMessage: string); override;
    procedure LogMessage; override;
    procedure RelocateVariables; override;
    procedure ResetDefaults; override;
    procedure ParseLine(pLineEnd: pchar); override;
    procedure ParseRequestLine(pLineEnd: pchar);
    function  PrepareResponse(AOutputItem: TOutputItem; ACustomErrorMessage: boolean): boolean;
    procedure ProcessHeaders; override;
    procedure WriteError(AStatus: TLHTTPStatus); override;
    procedure WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem);
  public
    FHeaderOut: THeaderOutInfo;
    FRequestInfo: TRequestInfo;
    FResponseInfo: TResponseInfo;

    constructor Create; override;
    destructor Destroy; override;

    function  SetupEncoding(AOutputItem: TBufferOutput): boolean;
    procedure StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false);
    procedure StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false);
  end;
  
  TURIHandler = class(TObject)
  private
    FNext: TURIHandler;
    FMethods: TLHTTPMethods;
  protected
    function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; virtual; abstract;
    procedure RegisterWithEventer(AEventer: TLEventer); virtual;
  public
    constructor Create;

    property Methods: TLHTTPMethods read FMethods write FMethods;
  end;

  TLAccessEvent = procedure(AMessage: string) of object;

  TLHTTPServer = class(TLHTTPConnection)
  protected
    FHandlerList: TURIHandler;
    FLogMessageTZString: string;
    FServerSoftware: string;
    FOnAccess: TLAccessEvent;

    function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem;
  protected
    procedure LogAccess(const AMessage: string); override;
    procedure RegisterWithEventer; override;
  public
    constructor Create(AOwner: TComponent); override;

    procedure RegisterHandler(AHandler: TURIHandler);

    property ServerSoftware: string read FServerSoftware write FServerSoftware;
    property OnAccess: TLAccessEvent read FOnAccess write FOnAccess;
  end;

  { http client }

  TLHTTPClientSocket = class(TLHTTPSocket)
  protected
    FRequest: PClientRequest;
    FResponse: PClientResponse;
    FHeaderOut: PHeaderOutInfo;
    FError: TLHTTPClientError;
    
    procedure AddContentLength(ALength: integer); override;
    function  GetResponseReason: string;
    function  GetResponseStatus: TLHTTPStatus;
    procedure Cancel(AError: TLHTTPClientError);
    procedure ParseLine(pLineEnd: pchar); override;
    procedure ParseStatusLine(pLineEnd: pchar);
    procedure ProcessHeaders; override;
    procedure ResetDefaults; override;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure SendRequest;

    property Error: TLHTTPClientError read FError write FError;
    property Response: PClientResponse read FResponse;
    property ResponseReason: string read GetResponseReason;
    property ResponseStatus: TLHTTPStatus read GetResponseStatus;
  end;

  TLHTTPClientState = (hcsIdle, hcsWaiting, hcsReceiving);

  TLHTTPClient = class(TLHTTPConnection)
  protected
    FRequest: TClientRequest;
    FResponse: TClientResponse;
    FHeaderOut: THeaderOutInfo;
    FState: TLHTTPClientState;
    FPendingResponses: integer;
    FOutputEof: boolean;
    FOnCanWrite: TLCanWriteEvent;
    FOnDoneInput: TLHTTPClientEvent;
    FOnInput: TLInputEvent;
    FOnProcessHeaders: TLHTTPClientEvent;
    
    procedure ConnectEvent(aSocket: TLHandle); override;
    procedure DoDoneInput(ASocket: TLHTTPClientSocket);
    function  DoHandleInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer;
    procedure DoProcessHeaders(ASocket: TLHTTPClientSocket);
    function  DoWriteBlock(ASocket: TLHTTPClientSocket): TWriteBlockStatus;
    function  InitSocket(aSocket: TLSocket): TLSocket; override;
    procedure InternalSendRequest;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure AddExtraHeader(const AHeader: string);
    procedure ResetRange;
    procedure SendRequest;

    property ContentLength: integer read FHeaderOut.ContentLength write FHeaderOut.ContentLength;
    property Method: TLHTTPMethod read FRequest.Method write FRequest.Method;
    property PendingResponses: integer read FPendingResponses;
    property RangeStart: qword read FRequest.RangeStart write FRequest.RangeStart;
    property RangeEnd: qword read FRequest.RangeEnd write FRequest.RangeEnd;
    property Request: TClientRequest read FRequest;
    property State: TLHTTPClientState read FState;
    property URI: string read FRequest.URI write FRequest.URI;
    property Response: TClientResponse read FResponse;
    property OnCanWrite: TLCanWriteEvent read FOnCanWrite write FOnCanWrite;
    property OnDoneInput: TLHTTPClientEvent read FOnDoneInput write FOnDoneInput;
    property OnInput: TLInputEvent read FOnInput write FOnInput;
    property OnProcessHeaders: TLHTTPClientEvent read FOnProcessHeaders write FOnProcessHeaders;
  end;

implementation

uses
  lCommon;

const
  RequestBufferSize = 1024;
  DataBufferSize = 16*1024;

  BufferEmptyToWriteStatus: array[boolean] of TWriteBlockStatus =
    (wsPendingData, wsDone);
  EofToWriteStatus: array[boolean] of TWriteBlockStatus =
    (wsWaitingData, wsDone);

{ helper functions }

function TrySingleDigit(ADigit: char; out OutDigit: byte): boolean;
begin
  Result := (ord(ADigit) >= ord('0')) and (ord(ADigit) <= ord('9'));
  if not Result then exit;
  OutDigit := ord(ADigit) - ord('0');
end;

function HTTPVersionCheck(AStr, AStrEnd: pchar; out AVersion: dword): boolean;
var
  lMajorVersion, lMinorVersion: byte;
begin
  Result := ((AStrEnd-AStr) = 8) 
    and CompareMem(AStr, pchar('HTTP/'), 5)
    and TrySingleDigit(AStr[5], lMajorVersion) 
    and (AStr[6] = '.')
    and TrySingleDigit(AStr[7], lMinorVersion);
  AVersion := lMajorVersion * 10 + lMinorVersion;
end;

function CodeToHTTPStatus(ACode: dword): TLHTTPStatus;
begin
  for Result := Low(TLHTTPStatus) to High(TLHTTPStatus) do
    if HTTPStatusCodes[Result] = ACode then exit;
  Result := hsUnknown;
end;

const
   HexDigits: array[0..15] of char = '0123456789ABCDEF';

function HexReverse(AValue: dword; ABuffer: pchar): integer;
begin
  Result := 0;
  repeat
    ABuffer^ := HexDigits[AValue and $F];
    AValue := AValue shr 4;
    Dec(ABuffer);
    Inc(Result);
  until AValue = 0;
end;

procedure HexToInt(ABuffer: pchar; out AValue: dword; out ACode: integer);
var
  Val, Incr: dword;
  Start: pchar;
begin
  Val := 0;
  ACode := 0;
  Start := ABuffer;
  while ABuffer^ <> #0 do
  begin
    if (ABuffer^ >= '0') and (ABuffer^ <= '9') then
      Incr := ord(ABuffer^) - ord('0')
    else if (ABuffer^ >= 'A') and (ABuffer^ <= 'F') then
      Incr := ord(ABuffer^) - ord('A') + 10
    else if (ABuffer^ >= 'a') and (ABuffer^ <= 'f') then
      Incr := ord(ABuffer^) - ord('a') + 10
    else begin
      ACode := ABuffer - Start + 1;
      break;
    end;
    Val := (Val shl 4) + Incr;
    Inc(ABuffer);
  end;
  AValue := Val;
end;

{ TURIHandler }

constructor TURIHandler.Create;
begin
  FMethods := [hmHead, hmGet, hmPost];
end;

procedure TURIHandler.RegisterWithEventer(AEventer: TLEventer);
begin
end;

{ TOutputItem }

constructor TOutputItem.Create(ASocket: TLHTTPSocket);
begin
  FSocket := ASocket;
  inherited Create;
end;

destructor TOutputItem.Destroy;
begin
  if FSocket.FCurrentInput = Self then
    FSocket.FCurrentInput := nil;
    
  if FPrevDelayFree = nil then
    FSocket.FDelayFreeItems := FNextDelayFree
  else
    FPrevDelayFree.FNextDelayFree := FNextDelayFree;
  if FNextDelayFree <> nil then
    FNextDelayFree.FPrevDelayFree := FPrevDelayFree;

  inherited;
end;

procedure TOutputItem.DoneInput;
begin
end;

function TOutputItem.HandleInput(ABuffer: pchar; ASize: integer): integer;
begin
  { discard input }
  Result := ASize;
end;

procedure TOutputItem.LogError(const AMessage: string);
begin
  FSocket.LogError(AMessage, 0);
end;

function TOutputItem.WriteBlock: TWriteBlockStatus;
var
  lWritten: integer;
begin
  if FOutputPending then
  begin
    if FBufferSize > FBufferPos then
    begin
      lWritten := FSocket.Send(FBuffer[FBufferPos], FBufferSize-FBufferPos);
      Inc(FBufferPos, lWritten);
    end;
    FOutputPending := FBufferPos < FBufferSize;
    Result := BufferEmptyToWriteStatus[not FOutputPending];
  end else
    Result := EofToWriteStatus[FEof];
end;

const
  ReserveChunkBytes = 12;

constructor TBufferOutput.Create(ASocket: TLHTTPSocket);
begin
  inherited;
  GetMem(FBuffer, DataBufferSize);
  FWriteBlock := @WritePlain;
  FPrepareBuffer := @PrepareBuffer;
  FFinishBuffer := @FinishBuffer;
  FBufferMemSize := DataBufferSize;
end;

destructor TBufferOutput.Destroy;
begin
  inherited;
  FreeMem(FBuffer);
end;

procedure TBufferOutput.Add(ABuf: pointer; ASize: integer);
var
  copySize: integer;
begin
  repeat
    copySize := FBufferSize-FBufferPos;
    if copySize > ASize then
      copySize := ASize;
    Move(ABuf^, FBuffer[FBufferPos], copySize);
    Inc(FBufferPos, copySize);
    Dec(ASize, copySize);
    if ASize = 0 then
      break;
    PrependBufferOutput(ASize);
  until false;
end;

procedure TBufferOutput.Add(const AStr: string);
begin
  Add(PChar(AStr), Length(AStr));
end;

procedure TBufferOutput.PrependStreamOutput(AStream: TStream; AFree: boolean);
begin
  if AStream is TMemoryStream then
    FSocket.PrependOutput(TMemoryStreamOutput.Create(FSocket, TMemoryStream(AStream), AFree), Self)
  else
    FSocket.PrependOutput(TStreamOutput.Create(FSocket, AStream, AFree), Self);
end;

procedure TBufferOutput.Add(AStream: TStream; AQueue: boolean = false; 
  AFree: boolean = true);
var
  size, copySize: integer;
begin
  size := AStream.Size - AStream.Position;
  repeat
    copySize := FBufferSize-FBufferPos;
    if copySize > size then
      copySize := size;
    AStream.Read(FBuffer[FBufferPos], copySize);
    Inc(FBufferPos, copySize);
    Dec(size, copySize);
    if size = 0 then
      break;
    if AQueue then
    begin
      PrependBufferOutput(0);
      PrependStreamOutput(AStream, AFree);
    end else begin
      PrependBufferOutput(size);
    end;
  until false;
end;

procedure TBufferOutput.PrepareChunk;
begin
  { 12 bytes for starting space, 7 bytes to end: <CR><LF>0<CR><LF><CR><LF> }
  FBufferPos := ReserveChunkBytes;
  FBufferOffset := FBufferPos;
  FBufferSize := FBufferMemSize-7;
end;

procedure TBufferOutput.FinishChunk;
var
  lOffset: integer;
begin
  lOffset := HexReverse(FBufferPos-FBufferOffset, FBuffer+FBufferOffset-3);
  FBuffer[FBufferOffset-2] := #13;
  FBuffer[FBufferOffset-1] := #10;
  FBuffer[FBufferPos] := #13;
  FBuffer[FBufferPos+1] := #10;
  FBufferSize := FBufferPos+2;
  FBufferPos := FBufferOffset-lOffset-2;
end;

procedure TBufferOutput.PrepareBuffer;
  { also for "plain" encoding }
begin
  FBufferPos := 0;
  FBufferOffset := 0;
  FBufferSize := FBufferMemSize;
end;

procedure TBufferOutput.FinishBuffer;
begin
  { nothing to do }
end;

procedure TBufferOutput.PrependBufferOutput(MinBufferSize: integer);
begin
  FFinishBuffer();
  FSocket.PrependOutput(TMemoryOutput.Create(FSocket, FBuffer, FBufferOffset,
    FBufferPos, true), Self);
  FBufferMemSize := MinBufferSize;
  if FBufferMemSize < DataBufferSize then
    FBufferMemSize := DataBufferSize;
  FBuffer := GetMem(FBufferMemSize);
  FPrepareBuffer();
end;

function TBufferOutput.WriteChunk: TWriteBlockStatus;
begin
  if not FOutputPending and not FEof then
  begin
    Result := FillBuffer;
    FEof := Result = wsDone;
    FOutputPending := FBufferPos > FBufferOffset;
    if FOutputPending then
      FinishChunk;
    if FEof then
    begin
      if not FOutputPending then
      begin
        { FBufferPos/Size still in "fill mode" }
        FBufferSize := 0;
        FBufferPos := 0;
        FOutputPending := true;
      end;
      FBuffer[FBufferSize] := '0';
      FBuffer[FBufferSize+1] := #13;
      FBuffer[FBufferSize+2] := #10;
      { no trailer }
      FBuffer[FBufferSize+3] := #13;
      FBuffer[FBufferSize+4] := #10;
      inc(FBufferSize, 5);
    end;
  end else   
    Result := EofToWriteStatus[FEof];
  if FOutputPending then
  begin
    Result := inherited WriteBlock;
    if (Result = wsDone) and not FEof then
    begin
      Result := wsPendingData;
      PrepareChunk;
    end;
  end;
end;
  
function TBufferOutput.WriteBuffer: TWriteBlockStatus;
begin
  if not FOutputPending then
  begin
    Result := FillBuffer;
    FEof := Result = wsDone;
    FOutputPending := FEof;
    if FOutputPending or (FBufferPos = FBufferSize) then
    begin
      if FBufferPos > FBufferOffset then
      begin
        FSocket.AddContentLength(FBufferPos-FBufferOffset);
        if not FEof then
          PrependBufferOutput(0)
        else begin
          FBufferSize := FBufferPos;
          FBufferPos := FBufferOffset;
        end;
      end else begin
        FBufferPos := 0;
        FBufferSize := 0;
      end;
      if FEof then
        FSocket.DoneBuffer(Self);
    end;
  end else
    Result := EofToWriteStatus[FEof];
  if Result = wsDone then
    Result := inherited WriteBlock;
end;

function TBufferOutput.WritePlain: TWriteBlockStatus;
begin
  if not FOutputPending then
  begin
    Result := FillBuffer;
    FEof := Result = wsDone;
    if FBufferPos > FBufferOffset then
    begin
      FOutputPending := true;
      FBufferSize := FBufferPos;
      FBufferPos := FBufferOffset;
    end else begin
      FBufferSize := 0;
      FBufferPos := 0;
    end;
  end;
  Result := inherited WriteBlock;
  if Result <> wsPendingData then
  begin
    PrepareBuffer;
    if not FEof then
      Result := wsPendingData;
  end;
end;

function TBufferOutput.WriteBlock: TWriteBlockStatus;
begin
  Result := FWriteBlock();
end;

procedure TBufferOutput.SelectChunked;
begin
  FPrepareBuffer := @PrepareChunk;
  FWriteBlock := @WriteChunk;
  FFinishBuffer := @FinishChunk;
  PrepareChunk;
end;
  
procedure TBufferOutput.SelectBuffered;
begin
  FPrepareBuffer := @PrepareBuffer;
  FWriteBlock := @WriteBuffer;
  FFinishBuffer := @FinishBuffer;
  PrepareBuffer;
end;
  
procedure TBufferOutput.SelectPlain;
begin
  FPrepareBuffer := @PrepareBuffer;
  FWriteBlock := @WritePlain;
  FFinishBuffer := @FinishBuffer;
  PrepareBuffer;
end;

{ TMemoryOutput }

constructor TMemoryOutput.Create(ASocket: TLHTTPSocket; ABuffer: pointer; 
  ABufferOffset, ABufferSize: integer; AFreeBuffer: boolean);
begin
  inherited Create(ASocket);

  FBuffer := ABuffer;
  FBufferPos := ABufferOffset;
  FBufferSize := ABufferSize;
  FFreeBuffer := AFreeBuffer;
  FOutputPending := true;
end;

destructor TMemoryOutput.Destroy;
begin
  inherited;
  if FFreeBuffer then
    FreeMem(FBuffer);
end;

{ TStreamOutput }

constructor TStreamOutput.Create(ASocket: TLHTTPSocket; AStream: TStream; AFreeStream: boolean);
begin
  inherited Create(ASocket);
  FStream := AStream;
  FFreeStream := AFreeStream;
  FStreamSize := AStream.Size;
end;

destructor TStreamOutput.Destroy;
begin
  if FFreeStream then
    FStream.Free;
  inherited;
end;

function TStreamOutput.FillBuffer: TWriteBlockStatus;
var
  lRead: integer;
begin
  lRead := FStream.Read(FBuffer[FBufferPos], FBufferSize-FBufferPos);
  Inc(FBufferPos, lRead);
  Result := BufferEmptyToWriteStatus[FStream.Position >= FStreamSize];
end;

{ TMemoryStreamOutput }

constructor TMemoryStreamOutput.Create(ASocket: TLHTTPSocket; AStream: TMemoryStream; 
  AFreeStream: boolean);
begin
  inherited Create(ASocket);
  FStream := AStream;
  FFreeStream := AFreeStream;
  FOutputPending := true;
end;

destructor TMemoryStreamOutput.Destroy;
begin
  if FFreeStream then
    FStream.Free;
  inherited;
end;

function TMemoryStreamOutput.WriteBlock: TWriteBlockStatus;
var
  lWritten: integer;
begin
  if not FOutputPending then
    exit(wsDone);

  lWritten := FSocket.Send(PByte(FStream.Memory)[FStream.Position], FStream.Size-FStream.Position);
  FStream.Position := FStream.Position + lWritten;
  FOutputPending := FStream.Position < FStream.Size;
  FEof := not FOutputPending;
  Result := EofToWriteStatus[FEof];
end;

{ TLHTTPSocket }

constructor TLHTTPSocket.Create;
begin
  inherited;

  FBuffer := GetMem(RequestBufferSize);
  FBufferSize := RequestBufferSize;
  FBufferPos := FBuffer;
  FBufferEnd := FBufferPos;
  FBuffer[0] := #0;
  FKeepAlive := true;
end;

destructor TLHTTPSocket.Destroy;
begin
  FreeDelayFreeItems;
  inherited;
  FreeMem(FBuffer);
end;

procedure TLHTTPSocket.Disconnect;
var
  lOutput: TOutputItem;
begin
  inherited Disconnect;
  while FCurrentOutput <> nil do
  begin
    lOutput := FCurrentOutput;
    FCurrentOutput := FCurrentOutput.FNext;
    lOutput.Free;
  end;
  if FCurrentInput <> nil then
    FreeAndNil(FCurrentInput);
end;

procedure TLHTTPSocket.FreeDelayFreeItems;
var
  lItem: TOutputItem;
begin
  while FDelayFreeItems <> nil do
  begin
    lItem := FDelayFreeItems;
    FDelayFreeItems := FDelayFreeItems.FNextDelayFree;
    lItem.Free;
  end;
end;

procedure TLHTTPSocket.DelayFree(AOutputItem: TOutputItem);
begin
  if AOutputItem = nil then exit;
  if FDelayFreeItems <> nil then
    FDelayFreeItems.FPrevDelayFree := AOutputItem;
  AOutputItem.FNextDelayFree := FDelayFreeItems;
  FDelayFreeItems := AOutputItem;
end;

procedure TLHTTPSocket.DoneBuffer(AOutput: TBufferOutput);
begin
end;

procedure TLHTTPSocket.LogMessage;
begin
end;

procedure TLHTTPSocket.LogAccess(const AMessage: string);
begin
end;

procedure TLHTTPSocket.WriteError(AStatus: TLHTTPStatus);
begin
end;

procedure TLHTTPSocket.AddToOutput(AOutputItem: TOutputItem);
begin
  AOutputItem.FPrev := FLastOutput;
  if FLastOutput <> nil then
  begin
    FLastOutput.FNext := AOutputItem;
  end else begin
    FCurrentOutput := AOutputItem;
  end;
  FLastOutput := AOutputItem;
end;

procedure TLHTTPSocket.PrependOutput(ANewItem, AItem: TOutputItem);
begin
  ANewItem.FPrev := AItem.FPrev;
  ANewItem.FNext := AItem;
  AItem.FPrev := ANewItem;
  if FCurrentOutput = AItem then
    FCurrentOutput := ANewItem;
end;

procedure TLHTTPSocket.RemoveOutput(AOutputItem: TOutputItem);
begin
  if AOutputItem.FPrev <> nil then
    AOutputItem.FPrev.FNext := AOutputItem.FNext;
  if AOutputItem.FNext <> nil then
    AOutputItem.FNext.FPrev := AOutputItem.FPrev;
  if FLastOutput = AOutputItem then
    FLastOutput := AOutputItem.FPrev;
  if FCurrentOutput = AOutputItem then
    FCurrentOutput := AOutputItem.FNext;
  AOutputItem.FPrev := nil;
  AOutputItem.FNext := nil;
end;

procedure TLHTTPSocket.ResetDefaults;
begin
  FParseBuffer := @ParseRequest;
end;

procedure TLHTTPSocket.FlushRequest;
begin
  FillDWord(FParameters, sizeof(FParameters) div 4, 0);
  ResetDefaults;
end;

function TLHTTPSocket.CalcAvailableBufferSpace: integer;
begin
  Result := FBufferSize-(FBufferEnd-FBuffer)-1;
end;

procedure TLHTTPSocket.HandleReceive;
var
  lRead: integer;
begin
  if FRequestInputDone then 
  begin
    IgnoreRead := true;
    exit;
  end;

  lRead := CalcAvailableBufferSpace;
  { if buffer has filled up, keep ignoring and continue parsing requests }
  if lRead > 0 then
  begin
    IgnoreRead := false;
    lRead := Get(FBufferEnd^, lRead);
    if lRead = 0 then exit;
    Inc(FBufferEnd, lRead);
    FBufferEnd^ := #0;
  end;
  ParseBuffer;

  if FIgnoreWrite then
    WriteBlock;
end;

procedure TLHTTPSocket.RelocateVariable(var AVar: pchar);
begin
  if AVar = nil then exit;
  AVar := FBuffer + (AVar - FRequestPos);
end;

procedure TLHTTPSocket.RelocateVariables;
var
  I: TLHTTPParameter;
begin
  for I := Low(TLHTTPParameter) to High(TLHTTPParameter) do
    RelocateVariable(FParameters[I]);
end;

procedure TLHTTPSocket.PackRequestBuffer;
var
  lBytesLeft: integer;
  lFreeBuffer: pchar;
begin
  if (FRequestBuffer <> nil) and (FBufferEnd-FBufferPos <= RequestBufferSize) then
  begin
    { switch back to normal size buffer }
    lFreeBuffer := FBuffer;
    FBuffer := FRequestBuffer;
    FBufferSize := RequestBufferSize;
    FRequestBuffer := nil;
  end else
    lFreeBuffer := nil;
  if FRequestPos <> nil then
  begin
    lBytesLeft := FBufferEnd-FRequestPos;
    FBufferEnd := FBuffer+lBytesLeft;
    RelocateVariable(FBufferPos);
    RelocateVariables;
    { include null-terminator, where FBufferEnd is pointing at }
    Move(FRequestPos^, FBuffer^, lBytesLeft+1);
    FRequestPos := nil;
  end;
  if lFreeBuffer <> nil then
    FreeMem(lFreeBuffer);
end;

procedure TLHTTPSocket.PackInputBuffer;
var
  lBytesLeft: integer;
begin
  { use bigger buffer for more speed }
  if FRequestBuffer = nil then
  begin
    FRequestBuffer := FBuffer;
    FBuffer := GetMem(DataBufferSize);
    FBufferSize := DataBufferSize;
    FRequestPos := nil;
  end;
  lBytesLeft := FBufferEnd-FBufferPos;
  Move(FBufferPos^, FBuffer^, lBytesLeft);
  FBufferEnd := FBuffer+lBytesLeft;
  FBufferPos := FBuffer;
end;

function TLHTTPSocket.ParseEntityPlain: boolean;
var
  lNumBytes: integer;
begin
  lNumBytes := FBufferEnd - FBufferPos;
  if lNumBytes > FInputRemaining then
    lNumBytes := FInputRemaining;
  { if no output item to feed into, discard }
  if FCurrentInput <> nil then
    lNumBytes := FCurrentInput.HandleInput(FBufferPos, lNumBytes);
  inc(FBufferPos, lNumBytes);
  dec(FInputRemaining, lNumBytes);
  Result := FInputRemaining > 0;
  { prepare for more data, if more data coming }
  if Result and (FBufferPos+FInputRemaining > FBuffer+FBufferSize) then
    PackInputBuffer;
end;

function TLHTTPSocket.ParseEntityChunked: boolean;
var
  lLineEnd, lNextLine: pchar;
  lCode: integer;
begin
  repeat
    if FChunkState = csFinished then
      exit(false);
    if FChunkState = csData then
      if ParseEntityPlain then 
        exit(true)
      else
        FChunkState := csDataEnd;
    
    lLineEnd := StrScan(FBufferPos, #10);
    if lLineEnd = nil then
      exit(true);
    
    lNextLine := lLineEnd+1;
    if (lLineEnd > FBufferPos) and ((lLineEnd-1)^ = #13) then
      dec(lLineEnd);
    case FChunkState of 
      csInitial:
      begin
        lLineEnd^ := #0;
        HexToInt(FBufferPos, dword(FInputRemaining), lCode);
        if lCode = 1 then
        begin
          FChunkState := csFinished;
          Disconnect;
          exit(false);
        end;
        if FInputRemaining = 0 then
          FChunkState := csTrailer
        else
          FChunkState := csData;
      end;
      csDataEnd:
      begin
        { skip empty line }
        FChunkState := csInitial;
      end;
      csTrailer:
      begin
        { trailer is optional, empty line indicates end }
        if lLineEnd = FBufferPos then
          FChunkState := csFinished
        else
          ParseParameterLine(lLineEnd);
      end;
    end;
    FBufferPos := lNextLine;
  until false;
end;

function TLHTTPSocket.ParseRequest: boolean;
var
  pNextLine, pLineEnd: pchar;
begin
  if FRequestHeaderDone then exit(not FRequestInputDone);
  repeat
    pLineEnd := StrScan(FBufferPos, #10);
    if pLineEnd = nil then
    begin
      if (FRequestBuffer <> nil) or (FRequestPos <> nil) then
        PackRequestBuffer
      else if CalcAvailableBufferSpace = 0 then
        WriteError(hsRequestTooLong);
      exit(true);
    end;
  
    pNextLine := pLineEnd+1;
    if (pLineEnd > FBufferPos) and ((pLineEnd-1)^ = #13) then
      dec(pLineEnd);
    pLineEnd^ := #0;
    ParseLine(pLineEnd);
    FBufferPos := pNextLine;
    if FRequestHeaderDone then
      exit(not FRequestInputDone);
  until false;
end;

procedure TLHTTPSocket.ParseParameterLine(pLineEnd: pchar);
var
  lPos: pchar;
  I: TLHTTPParameter;
  lLen: integer;
begin
  lPos := StrScan(FBufferPos, ' ');
  if (lPos = nil) or (lPos = FBufferPos) or ((lPos-1)^ <> ':') then
  begin
    WriteError(hsBadRequest);
    exit;
  end;

  { null-terminate at colon }
  (lPos-1)^ := #0;
  StrUpper(FBufferPos);
  lLen := lPos-FBufferPos-1;
  for I := Low(TLHTTPParameter) to High(TLHTTPParameter) do
    if (Length(HTTPParameterStrings[I]) = lLen)
    and CompareMem(FBufferPos, PChar(HTTPParameterStrings[I]), lLen) then
    begin
      repeat
        inc(lPos);
      until lPos^ <> ' ';
      FParameters[I] := lPos;
      break;
    end;
end;

procedure TLHTTPSocket.ParseLine(pLineEnd: pchar);
begin
  if FBufferPos[0] = #0 then
  begin
    FRequestHeaderDone := true;
    ProcessHeaders;
  end else
    ParseParameterLine(pLineEnd);
end;
        
function TLHTTPSocket.ParseBuffer: boolean;
var
  lParseFunc: TParseBufferMethod;
begin
  repeat
    lParseFunc := FParseBuffer;
    Result := FParseBuffer();
    if not Result and not FRequestInputDone then
    begin
      FRequestInputDone := true;
      if FCurrentInput <> nil then
        FCurrentInput.DoneInput;
    end;
    { if parse func changed mid-run, then we should continue calling the new 
      one: header + data }
  until (lParseFunc = FParseBuffer) or not Result;
end;

function TLHTTPSocket.ProcessEncoding: boolean;
var
  lCode: integer;
begin
  Result := true;
  if FParameters[hpContentLength] <> nil then
  begin
    FParseBuffer := @ParseEntityPlain;
    Val(FParameters[hpContentLength], FInputRemaining, lCode);
    if lCode <> 0 then
    begin
      WriteError(hsBadRequest);
      exit;
    end;
  end else 
  if FParameters[hpTransferEncoding] <> nil then
  begin
    if (StrIComp(FParameters[hpTransferEncoding], 'chunked') = 0) then
    begin
      FParseBuffer := @ParseEntityChunked;
      FChunkState := csInitial;
    end else begin
      Result := false;
    end;
  end else begin
    FRequestInputDone := true;
  end;
end;

function TLHTTPSocket.SetupEncoding(AOutputItem: TBufferOutput; AHeaderOut: PHeaderOutInfo): boolean;
begin
  if AHeaderOut^.ContentLength = 0 then
  begin
    if AHeaderOut^.Version >= 11 then
    begin
      { we can use chunked encoding }
      AHeaderOut^.TransferEncoding := teChunked;
      AOutputItem.SelectChunked;
    end else begin
      { we need to buffer the response to find its length }
      AHeaderOut^.TransferEncoding := teIdentity;
      AOutputItem.SelectBuffered;
      { need to accumulate data before starting header output }
      AddToOutput(AOutputItem);
      exit(false);
    end;
  end else begin
    AHeaderOut^.TransferEncoding := teIdentity;
    AOutputItem.SelectPlain;
  end;
  Result := true;
end;

procedure TLHTTPSocket.WriteBlock;
begin
  while true do
  begin
    if FCurrentOutput = nil then
    begin
      if not FOutputDone or (not FRequestInputDone and FKeepAlive) then
        break;

      if not FKeepAlive then
      begin
        Disconnect;
        exit;
      end;

      { next request }
      FRequestInputDone := false;
      FRequestHeaderDone := false;
      FOutputDone := false;
      FRequestPos := FBufferPos;
      FlushRequest;
      { rewind buffer pointers if at end of buffer anyway }
      if FBufferPos = FBufferEnd then
        PackRequestBuffer;

      if ParseBuffer and IgnoreRead then 
      begin
        { end of input buffer reached, try reading more }
        HandleReceive;
      end;

      if FCurrentOutput = nil then 
        break;
    end;

    { if we cannot send, then the send buffer is full }
    if not FCanSend or not FConnected then
      break;

    case FCurrentOutput.WriteBlock of
      wsDone:
      begin
        if FCurrentOutput = FLastOutput then
          FLastOutput := nil;
        { some output items may trigger this parse/write loop }
        DelayFree(FCurrentOutput);
        FCurrentOutput := FCurrentOutput.FNext;
      end;
      wsWaitingData:
      begin
        { wait for more data from external source }
        break;
      end;
    end;
    { nothing left to write, request was busy and now completed }
    if FCurrentOutput = nil then
    begin
      LogMessage;
      FOutputDone := true;
    end;
  end;
end;

{ TLHTTPServerSocket }

constructor TLHTTPServerSocket.Create;
begin
  inherited;

  FLogMessage := InitStringBuffer(256);
  FHeaderOut.ExtraHeaders := InitStringBuffer(256);
  ResetDefaults;
end;

destructor TLHTTPServerSocket.Destroy;
begin
  FreeMem(FLogMessage.Memory);
  FreeMem(FHeaderOut.ExtraHeaders.Memory);
  inherited;
end;

procedure TLHTTPServerSocket.AddContentLength(ALength: integer);
begin
  Inc(FHeaderOut.ContentLength, ALength);
end;

procedure TLHTTPServerSocket.DoneBuffer(AOutput: TBufferOutput);
begin
  if FCurrentOutput <> AOutput then
  begin
    RemoveOutput(AOutput);
    AOutput.FNext := FCurrentOutput;
    FCurrentOutput := AOutput;
  end;
  WriteHeaders(AOutput, nil);
end;

procedure TLHTTPServerSocket.LogAccess(const AMessage: string);
begin
  TLHTTPConnection(FCreator).LogAccess(AMessage);
end;

procedure TLHTTPServerSocket.LogMessage;
begin
  { log a message about this request, 
    '<StatusCode> <Length> "<Referer>" "<User-Agent>"' }
  AppendString(FLogMessage, IntToStr(HTTPStatusCodes[FResponseInfo.Status]));
  AppendChar(FLogMessage, ' ');
  AppendString(FLogMessage, IntToStr(FHeaderOut.ContentLength));
  AppendString(FLogMessage, ' "');
  AppendString(FLogMessage, FParameters[hpReferer]);
  AppendString(FLogMessage, '" "');
  AppendString(FLogMessage, FParameters[hpUserAgent]);
  AppendChar(FLogMessage, '"');
  AppendChar(FLogMessage, #0);
  LogAccess(FLogMessage.Memory);
end;

procedure TLHTTPServerSocket.ResetDefaults;
begin
  inherited;
  FRequestInfo.RequestType := hmUnknown;
  FSetupEncodingState := seNone;
  with FResponseInfo do
  begin
    Status := hsOK;
    ContentType := 'application/octet-stream';
    ContentCharset := '';
    LastModified := 0.0;
  end;
end;

procedure TLHTTPServerSocket.FlushRequest;
  { reset structure to zero, not called from constructor }
begin
  with FRequestInfo do
  begin
    { request }
    Argument := nil;
    QueryParams := nil;
    Version := 0;
  end;
  with FHeaderOut do
  begin
    ContentLength := 0;
    TransferEncoding := teIdentity;
    ExtraHeaders.Pos := ExtraHeaders.Memory;
    Version := 0;
  end;
  inherited;
end;
  
procedure TLHTTPServerSocket.RelocateVariables;
begin
  RelocateVariable(FRequestInfo.Method);
  RelocateVariable(FRequestInfo.Argument);
  RelocateVariable(FRequestInfo.QueryParams);
  RelocateVariable(FRequestInfo.VersionStr);
  inherited;
end;

procedure TLHTTPServerSocket.ParseLine(pLineEnd: pchar);
begin
  if FRequestInfo.RequestType = hmUnknown then
  begin
    ParseRequestLine(pLineEnd);
    exit;
  end;

  inherited;
end;

procedure TLHTTPServerSocket.ParseRequestLine(pLineEnd: pchar);
var
  lPos: pchar;
  I: TLHTTPMethod;
  NowLocal: TDateTime;
begin
  { make a timestamp for this request }
  NowLocal := Now;
  FRequestInfo.DateTime := LocalTimeToGMT(NowLocal);
  { begin log message }
  FLogMessage.Pos := FLogMessage.Memory;
  AppendString(FLogMessage, PeerAddress);
  AppendString(FLogMessage, ' - [');
  AppendString(FLogMessage, FormatDateTime('dd/mmm/yyyy:hh:nn:ss', NowLocal));
  AppendString(FLogMessage, TLHTTPServer(FCreator).FLogMessageTZString);
  AppendString(FLogMessage, FBufferPos, pLineEnd-FBufferPos);
  AppendString(FLogMessage, '" ');

  { decode version }
  lPos := pLineEnd;
  repeat
    if lPos^ = ' ' then break;
    dec(lPos);
    if lPos < FBufferPos then
    begin
      WriteError(hsBadRequest);
      exit;
    end;
  until false;

  lPos^ := #0;
  inc(lPos);
  { lPos = version string }
  if not HTTPVersionCheck(lPos, pLineEnd, FRequestInfo.Version) then
  begin
    WriteError(hsBadRequest);
    exit;
  end;
  FRequestInfo.VersionStr := lPos;
  FHeaderOut.Version := FRequestInfo.Version;
  
  { trim spaces at end of URI }
  dec(lPos);
  repeat
    if lPos = FBufferPos then break;
    dec(lPos);
    if lPos^ <> ' ' then break;
    lPos^ := #0;
  until false;

  { decode method }
  FRequestInfo.Method := FBufferPos;
  lPos := StrScan(FBufferPos, ' ');
  if lPos = nil then
  begin
    WriteError(hsBadRequest);
    exit;
  end;

  lPos^ := #0;
  for I := Low(TLHTTPMethod) to High(TLHTTPMethod) do
  begin
    if (I = hmUnknown) or (((lPos-FBufferPos) = Length(HTTPMethodStrings[I]))
      and CompareMem(FBufferPos, PChar(HTTPMethodStrings[I]), lPos-FBufferPos)) then
    begin
      repeat
        inc(lPos);
      until lPos^ <> ' ';
      FRequestInfo.Argument := lPos;
      FRequestInfo.RequestType := I;
      break;
    end;
  end;

  if ((pLineEnd-FRequestInfo.Argument) > 7) and (StrIComp(FRequestInfo.Argument, 'http://') = 0) then
  begin
    { absolute URI }
    lPos := FRequestInfo.Argument+7;
    while (lPos^ = '/') do 
      Inc(lPos);
    FParameters[hpHost] := lPos;
    lPos := StrScan(lPos, '/');
    FRequestInfo.Argument := lPos;
  end;
  { FRequestInfo.Argument now points to an "abs_path" }
  if FRequestInfo.Argument[0] <> '/' then
  begin
    WriteError(hsBadRequest);
    exit;
  end;
  repeat
    Inc(FRequestInfo.Argument);
  until FRequestInfo.Argument[0] <> '/';
end;

procedure TLHTTPServerSocket.ProcessHeaders;
  { process request }
var
  lPos: pchar;
begin
  { do HTTP/1.1 Host-field present check }
  if (FRequestInfo.Version > 10) and (FParameters[hpHost] = nil) then
  begin
    WriteError(hsBadRequest);
    exit;
  end;
      
  lPos := StrScan(FRequestInfo.Argument, '?');
  if lPos <> nil then
  begin
    lPos^ := #0;
    FRequestInfo.QueryParams := lPos+1;
  end;

  FKeepAlive := FRequestInfo.Version > 10;
  if FParameters[hpConnection] <> nil then
  begin
    if StrIComp(FParameters[hpConnection], 'keep-alive') = 0 then
      FKeepAlive := true
    else
    if StrIComp(FParameters[hpConnection], 'close') = 0 then
      FKeepAlive := false;
  end;
  
  HTTPDecode(FRequestInfo.Argument);
  if not CheckPermission(FRequestInfo.Argument) then
  begin
    WriteError(hsForbidden);
  end else begin
    if not ProcessEncoding then
    begin
      WriteError(hsNotImplemented);
      exit;
    end;
      
    FCurrentInput := HandleURI;
    { if we have a valid outputitem, wait until it is ready 
      to produce its response }
    if FCurrentInput = nil then
    begin
      if FResponseInfo.Status = hsOK then
        WriteError(hsNotFound)
      else
        WriteError(FResponseInfo.Status);
    end else if FRequestInputDone then
      FCurrentInput.DoneInput;
  end;
end;

function TLHTTPServerSocket.PrepareResponse(AOutputItem: TOutputItem; ACustomErrorMessage: boolean): boolean;
var
  lDateTime: TDateTime;
begin
  { check modification date }
  if FResponseInfo.Status < hsBadRequest then
  begin
    if (FParameters[hpIfModifiedSince] <> nil) 
      and (FResponseInfo.LastModified <> 0.0) then
    begin
      if TryHTTPDateStrToDateTime(FParameters[hpIfModifiedSince], lDateTime) then
      begin
        if lDateTime > FRequestInfo.DateTime then
          FResponseInfo.Status := hsBadRequest
        else
        if FResponseInfo.LastModified <= lDateTime then
          FResponseInfo.Status := hsNotModified;
      end;
    end else
    if (FParameters[hpIfUnmodifiedSince] <> nil) then
    begin
      if TryHTTPDateStrToDateTime(FParameters[hpIfUnmodifiedSince], lDateTime) then
      begin
        if (FResponseInfo.LastModified = 0.0) 
          or (lDateTime < FResponseInfo.LastModified) then
          FResponseInfo.Status := hsPreconditionFailed;
      end;
    end;
  end;

  if (FResponseInfo.Status < hsOK) or (FResponseInfo.Status in [hsNoContent, hsNotModified]) then
  begin
    { RFC says we MUST not include a response for these statuses }
    ACustomErrorMessage := false;
    FHeaderOut.ContentLength := 0;
  end;
  
  Result := (FResponseInfo.Status = hsOK) or ACustomErrorMessage;
  if not Result then
  begin
    WriteError(FResponseInfo.Status);
    DelayFree(AOutputItem);
  end;
end;

procedure TLHTTPServerSocket.StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false);
begin
  if PrepareResponse(AOutputItem, ACustomErrorMessage) then
  begin
    if FRequestInfo.RequestType <> hmHead then
      FHeaderOut.ContentLength := AOutputItem.FBufferSize
    else
      FHeaderOut.ContentLength := 0;
    WriteHeaders(nil, AOutputItem);
  end;
end;

function TLHTTPServerSocket.SetupEncoding(AOutputItem: TBufferOutput): boolean;
const
  SetupEncodingToState: array[boolean] of TSetupEncodingState = (seWaitHeaders, seStartHeaders);
begin
  if FSetupEncodingState > seNone then
    exit(FSetupEncodingState = seStartHeaders);
  Result := inherited SetupEncoding(AOutputItem, @FHeaderOut);
  FSetupEncodingState := SetupEncodingToState[Result];
end;

procedure TLHTTPServerSocket.StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false);
begin
  if PrepareResponse(AOutputItem, ACustomErrorMessage) then
    if (FRequestInfo.RequestType = hmHead) or SetupEncoding(AOutputItem) then
      WriteHeaders(nil, AOutputItem);
end;

function TLHTTPServerSocket.HandleURI: TOutputItem; {inline;} {<--- triggers IE}
begin
  Result := TLHTTPServer(FCreator).HandleURI(Self);
end;

procedure TLHTTPServerSocket.WriteError(AStatus: TLHTTPStatus);
var
  lMessage: string;
  lMsgOutput: TMemoryOutput;
begin
  if AStatus in HTTPDisconnectStatuses then
    FKeepAlive := false;
  lMessage := HTTPDescriptions[AStatus];
  FRequestHeaderDone := true;
  FResponseInfo.Status := AStatus;
  FHeaderOut.ContentLength := Length(lMessage);
  FHeaderOut.TransferEncoding := teIdentity;
  if Length(lMessage) > 0 then
  begin
    FResponseInfo.ContentType := 'text/html';
    lMsgOutput := TMemoryOutput.Create(Self, PChar(lMessage), 0, Length(lMessage), false)
  end else begin
    FResponseInfo.ContentType := '';
    lMsgOutput := nil;
  end;
  WriteHeaders(nil, lMsgOutput);
end;

procedure TLHTTPServerSocket.WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem);
var
  lTemp: string[23];
  lMessage: TStringBuffer;
  tempStr: string;
begin
  lMessage := InitStringBuffer(504);
  
  AppendString(lMessage, 'HTTP/1.1 ');
  Str(HTTPStatusCodes[FResponseInfo.Status], lTemp);
  AppendString(lMessage, lTemp);
  AppendChar(lMessage, ' ');
  AppendString(lMessage, HTTPTexts[FResponseInfo.Status]);
  AppendString(lMessage, #13#10+'Date: ');
  AppendString(lMessage, FormatDateTime(HTTPDateFormat, FRequestInfo.DateTime));
  AppendString(lMessage, ' GMT');
  tempStr := TLHTTPServer(FCreator).ServerSoftware;
  if Length(tempStr) > 0 then
  begin
    AppendString(lMessage, #13#10+'Server: ');
    AppendString(lMessage, tempStr);
  end;
  if Length(FResponseInfo.ContentType) > 0 then
  begin
    AppendString(lMessage, #13#10+'Content-Type: ');
    AppendString(lMessage, FResponseInfo.ContentType);
    if Length(FResponseInfo.ContentCharset) > 0 then
    begin
      AppendString(lMessage, '; charset=');
      AppendString(lMessage, FResponseInfo.ContentCharset);
    end;
  end;
  if FHeaderOut.TransferEncoding = teIdentity then
  begin
    AppendString(lMessage, #13#10+'Content-Length: ');
    Str(FHeaderOut.ContentLength, lTemp);
    AppendString(lMessage, lTemp);
  end else begin
    { only other possibility: teChunked }
    AppendString(lMessage, #13#10+'Transfer-Encoding: chunked');
  end;
  if FResponseInfo.LastModified <> 0.0 then
  begin
    AppendString(lMessage, #13#10+'Last-Modified: ');
    AppendString(lMessage, FormatDateTime(HTTPDateFormat, FResponseInfo.LastModified));
    AppendString(lMessage, ' GMT');
  end;
  AppendString(lMessage, #13#10+'Connection: ');
  if FKeepAlive then
    AppendString(lMessage, 'keep-alive')
  else
    AppendString(lMessage, 'close');
  AppendString(lMessage, #13#10);
  with FHeaderOut.ExtraHeaders do
    AppendString(lMessage, Memory, Pos-Memory);
  AppendString(lMessage, #13#10);
  if AHeaderResponse <> nil then
  begin
    AHeaderResponse.FBuffer := lMessage.Memory;
    AHeaderResponse.FBufferSize := lMessage.Pos-lMessage.Memory;
  end else
    AddToOutput(TMemoryOutput.Create(Self, lMessage.Memory, 0,
      lMessage.Pos-lMessage.Memory, true));

  if ADataResponse <> nil then
  begin
    if FRequestInfo.RequestType = hmHead then
      DelayFree(ADataResponse)
    else
      AddToOutput(ADataResponse);
  end;
end;

{ TLHTTPConnection }

destructor TLHTTPConnection.Destroy;
begin
  inherited;
end;

procedure TLHTTPConnection.LogAccess(const AMessage: string);
begin
end;

procedure TLHTTPConnection.ReceiveEvent(aSocket: TLHandle);
begin
  TLHTTPSocket(aSocket).HandleReceive;
  TLHTTPSocket(aSocket).FreeDelayFreeItems;
end;

procedure TLHTTPConnection.CanSendEvent(aSocket: TLHandle);
begin
  TLHTTPSocket(aSocket).WriteBlock;
  TLHTTPSocket(aSocket).FreeDelayFreeItems;
end;

{ TLHTTPServer }

constructor TLHTTPServer.Create(AOwner: TComponent);
var
  TZSign: char;
  TZSecsAbs: integer;
begin
  inherited Create(AOwner);

  FPort := 80; // default port
  SocketClass := TLHTTPServerSocket;
  if TZSeconds >= 0 then
    TZSign := '+'
  else
    TZSign := '-';
  TZSecsAbs := Abs(TZSeconds);
  FLogMessageTZString := Format(' %s%.2d%.2d] "', 
    [TZSign, TZSecsAbs div 3600, (TZSecsAbs div 60) mod 60]);
end;

function TLHTTPServer.HandleURI(ASocket: TLHTTPServerSocket): TOutputItem;
var
  lHandler: TURIHandler;
begin
  Result := nil;
  lHandler := FHandlerList;
  while lHandler <> nil do
  begin
    if ASocket.FRequestInfo.RequestType in lHandler.Methods then
    begin
      Result := lHandler.HandleURI(ASocket);
      if ASocket.FResponseInfo.Status <> hsOK then break;
      if Result <> nil then break;
    end;
    lHandler := lHandler.FNext;
  end;
end;

procedure TLHTTPServer.LogAccess(const AMessage: string);
begin
  if Assigned(FOnAccess) then
    FOnAccess(AMessage);
end;

procedure TLHTTPServer.RegisterHandler(AHandler: TURIHandler);
begin
  if AHandler = nil then exit;
  AHandler.FNext := FHandlerList;
  FHandlerList := AHandler;
  if Eventer <> nil then
    AHandler.RegisterWithEventer(Eventer);
end;

procedure TLHTTPServer.RegisterWithEventer;
var
  lHandler: TURIHandler;
begin
  inherited;
  lHandler := FHandlerList;
  while lHandler <> nil do
  begin
    lHandler.RegisterWithEventer(Eventer);
    lHandler := lHandler.FNext;
  end;
end;

{ TClientInput }

type
  TClientOutput = class(TOutputItem)
  protected
    FPersistent: boolean;
    
    procedure DoneInput; override;
  public
    constructor Create(ASocket: TLHTTPClientSocket);
    destructor Destroy; override;
    procedure FreeInstance; override;

    function  HandleInput(ABuffer: pchar; ASize: integer): integer; override;
    function  WriteBlock: TWriteBlockStatus; override;
  end;

constructor TClientOutput.Create(ASocket: TLHTTPClientSocket);
begin
  inherited Create(ASocket);
  FPersistent := true;
end;

destructor TClientOutput.Destroy;
begin
  if FPersistent then exit; 
  inherited;
end;

procedure TClientOutput.FreeInstance;
begin
  if FPersistent then exit; 
  inherited;
end;

procedure TClientOutput.DoneInput;
begin
  TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
    DoDoneInput(TLHTTPClientSocket(FSocket));
end;

function  TClientOutput.HandleInput(ABuffer: pchar; ASize: integer): integer;
begin
  Result := TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
    DoHandleInput(TLHTTPClientSocket(FSocket), ABuffer, ASize);
end;

function  TClientOutput.WriteBlock: TWriteBlockStatus;
begin
  Result := TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
    DoWriteBlock(TLHTTPClientSocket(FSocket));
end;

{ TLHTTPClientSocket }

constructor TLHTTPClientSocket.Create;
begin
  inherited Create;

  FCurrentInput := TClientOutput.Create(Self);
  ResetDefaults;
end;

destructor TLHTTPClientSocket.Destroy;
begin
  if Assigned(FCurrentInput) then begin
    TClientOutput(FCurrentInput).FPersistent := false;
    FreeAndNil(FCurrentInput);
  end;
  inherited;
end;

procedure TLHTTPClientSocket.AddContentLength(ALength: integer);
begin
  Inc(TLHTTPClient(FCreator).FHeaderOut.ContentLength, ALength);
end;

procedure TLHTTPClientSocket.Cancel(AError: TLHTTPClientError);
begin
  FError := AError;
  Disconnect;
end;

function TLHTTPClientSocket.GetResponseReason: string;
begin
  Result := FResponse^.Reason;
end;

function TLHTTPClientSocket.GetResponseStatus: TLHTTPStatus;
begin
  Result := FResponse^.Status;
end;

procedure TLHTTPClientSocket.SendRequest;
var
  lMessage: TStringBuffer;
  lTemp: string[23];
  hasRangeStart, hasRangeEnd: boolean;
begin
  lMessage := InitStringBuffer(504);

  AppendString(lMessage, HTTPMethodStrings[FRequest^.Method]);
  AppendChar(lMessage, ' ');
  AppendString(lMessage, FRequest^.URI);
  AppendChar(lMessage, ' ');
  AppendString(lMessage, 'HTTP/1.1'+#13#10+'Host: ');
  AppendString(lMessage, TLHTTPClient(FCreator).Host);
  if TLHTTPClient(FCreator).Port <> 80 then
  begin
    AppendChar(lMessage, ':');
    Str(TLHTTPClient(FCreator).Port, lTemp);
    AppendString(lMessage, lTemp);
  end;
  AppendString(lMessage, #13#10);
  hasRangeStart := TLHTTPClient(FCreator).RangeStart <> high(qword);
  hasRangeEnd := TLHTTPClient(FCreator).RangeEnd <> high(qword);
  if hasRangeStart or hasRangeEnd then
  begin
    AppendString(lMessage, 'Range: bytes=');
    if hasRangeStart then
    begin
      Str(TLHTTPClient(FCreator).RangeStart, lTemp);
      AppendString(lMessage, lTemp);
    end;
    AppendChar(lMessage, '-');
    if hasRangeEnd then
    begin
      Str(TLHTTPClient(FCreator).RangeEnd, lTemp);
      AppendString(lMessage, lTemp);
    end;
  end;
  with FHeaderOut^.ExtraHeaders do
    AppendString(lMessage, Memory, Pos-Memory);
  AppendString(lMessage, #13#10);
  AddToOutput(TMemoryOutput.Create(Self, lMessage.Memory, 0,
    lMessage.Pos-lMessage.Memory, true));
  AddToOutput(FCurrentInput);
  
  WriteBlock;
end;

procedure TLHTTPClientSocket.ParseLine(pLineEnd: pchar);
begin
  if FError <> ceNone then
    exit;

  if FResponse^.Status = hsUnknown then
  begin
    ParseStatusLine(pLineEnd);
    exit;
  end;

  inherited;
end;

procedure TLHTTPClientSocket.ParseStatusLine(pLineEnd: pchar);
var
  lPos: pchar;
begin
  lPos := FBufferPos;
  repeat
    if lPos >= pLineEnd then
    begin
      Cancel(ceMalformedStatusLine);
      exit;
    end;
    if lPos^ = ' ' then
      break;
    Inc(lPos);
  until false;
  if not HTTPVersionCheck(FBufferPos, lPos, FResponse^.Version) then
  begin
    Cancel(ceMalformedStatusLine);
    exit;
  end;

  if (FResponse^.Version > 11) then
  begin
    Cancel(ceVersionNotSupported);
    exit;
  end;

  { status code }
  Inc(lPos);
  if (lPos+3 >= pLineEnd) or (lPos[3] <> ' ') then
  begin
    Cancel(ceMalformedStatusLine);
    exit;
  end;
  FResponse^.Status := CodeToHTTPStatus((ord(lPos[0])-ord('0'))*100
    + (ord(lPos[1])-ord('0'))*10 + (ord(lPos[2])-ord('0')));
  if FResponse^.Status = hsUnknown then
  begin
    Cancel(ceMalformedStatusLine);
    exit;
  end;

  Inc(lPos, 4);
  if lPos < pLineEnd then
    FResponse^.Reason := lPos;
end;

procedure TLHTTPClientSocket.ProcessHeaders;
begin
  if not ProcessEncoding then
    Cancel(ceUnsupportedEncoding);

  TLHTTPClient(FCreator).DoProcessHeaders(Self);
end;

procedure TLHTTPClientSocket.ResetDefaults;
begin
  inherited;

  FError := ceNone;
end;

{ TLHTTPClient }

constructor TLHTTPClient.Create(AOwner: TComponent);
begin
  inherited;

  FPort := 80;
  SocketClass := TLHTTPClientSocket;
  FRequest.Method := hmGet;
  FHeaderOut.ExtraHeaders := InitStringBuffer(256);
  ResetRange;
end;

destructor TLHTTPClient.Destroy;
begin
  FreeMem(FHeaderOut.ExtraHeaders.Memory);
  inherited;
end;

procedure TLHTTPClient.AddExtraHeader(const AHeader: string);
begin
  AppendString(FHeaderOut.ExtraHeaders, AHeader);
  AppendString(FHeaderOut.ExtraHeaders, #13#10);
end;

procedure TLHTTPClient.ConnectEvent(aSocket: TLHandle);
begin
  inherited;
  InternalSendRequest;
end;

procedure TLHTTPClient.DoDoneInput(ASocket: TLHTTPClientSocket);
begin
  Dec(FPendingResponses);
  if FPendingResponses = 0 then
    FState := hcsIdle
  else
    FState := hcsWaiting;
  if Assigned(FOnDoneInput) then
    FOnDoneInput(ASocket);
end;

function  TLHTTPClient.DoHandleInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer;
begin
  FState := hcsReceiving;
  if Assigned(FOnInput) then
    Result := FOnInput(ASocket, ABuffer, ASize)
  else
    Result := ASize;
end;

procedure TLHTTPClient.DoProcessHeaders(ASocket: TLHTTPClientSocket);
begin
  if Assigned(FOnProcessHeaders) then
    FOnProcessHeaders(ASocket);
end;

function  TLHTTPClient.DoWriteBlock(ASocket: TLHTTPClientSocket): TWriteBlockStatus;
begin
  Result := wsDone;
  if not FOutputEof then
    if Assigned(FOnCanWrite) then
      FOnCanWrite(ASocket, Result)
end;

function  TLHTTPClient.InitSocket(aSocket: TLSocket): TLSocket;
begin
  Result := inherited;
  TLHTTPClientSocket(aSocket).FHeaderOut := @FHeaderOut;
  TLHTTPClientSocket(aSocket).FRequest := @FRequest;
  TLHTTPClientSocket(aSocket).FResponse := @FResponse;
end;

procedure TLHTTPClient.InternalSendRequest;
begin
  FOutputEof := false;
  TLHTTPClientSocket(FIterator).SendRequest;
  Inc(FPendingResponses);
  if FState = hcsIdle then
    FState := hcsWaiting;
end;

procedure TLHTTPClient.ResetRange;
begin
  FRequest.RangeStart := High(FRequest.RangeStart);
  FRequest.RangeEnd := High(FRequest.RangeEnd);
end;

procedure TLHTTPClient.SendRequest;
begin
  if not Connected then
    Connect(FHost, FPort)
  else
    InternalSendRequest;
end;

end.