pascal
/
fpc
зеркало из https://gitlab.com/freepascal.org/fpc/source.git


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265
							{ HTTP server and client components

  Copyright (C) 2006 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);
  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;
    FRequestInfo: TRequestInfo;
    FResponseInfo: TResponseInfo;
    FHeaderOut: THeaderOutInfo;
    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
    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);

    property HeaderOut: THeaderOutInfo read FHeaderOut;
    property RequestInfo: TRequestInfo read FRequestInfo;
    property ResponseInfo: TResponseInfo read FResponseInfo;
  end;
  
  TURIHandler = class(TObject)
  private
    FNext: TURIHandler;
  protected
    function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; virtual; abstract;
    procedure RegisterWithEventer(AEventer: TLEventer); virtual;
  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 }

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 then
    begin
      WriteError(hsNotImplemented);
      exit;
    end;
    
    if ((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
    Result := lHandler.HandleURI(ASocket);
    if ASocket.ResponseInfo.Status <> hsOK then break;
    if Result <> nil then break;
    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.