unit httpServer;

{$MODE DELPHI}

uses Classes, SysUtils, typinfo,

{$IFNDEF FPC}{$IFNDEF LINUX}filectrl, {$ENDIF}{$ENDIF}

blcksock, visualserverbase, inifiles, vstypedef, ExecCGI,

synacode, synautil, mimemess, authentication;

MAX_POST_DATA_SIZE=8192;

PathDelim = '/';

PathDelim = '\';

TEnumHTTPProtocols = (hpHEAD, hpGET, hpPUT, hpDELETE, hpPOST, hpTRACE, hpOPTIONS, hpCONNECT);

THTTPProtocols = set of TEnumHTTPProtocols;

//cmGET is default

//cmClose forces connection close

//cmDone marks all client IO as done, but keeps connection open if enabled

//cmConnect marks proxy

THttpConnectionMode = (cmWait, cmGET, cmPOST, cmPUT, cmCONNECT, cmReadCGI, cmCLOSE, cmDONE);

TCGIPath = class

CGIName:String;

ExePath:TFileName;

end;

TPreParser = class

ExePath:String;

Params: String;

end;

TvsHTTPResponse = class (TResponse)

procedure FixHeader; override;

end;

TvsVirtualDomain = class (TObject)

FDefaultDocument:String;

FDefaultDocuments:TStrings;

FHostName:String;

FVirtualPath: TStrings;

FCGI: TStrings; //Array of TCGIPath;

FPreParser: TStrings; //Array TPreParser;

FManualURL: TStrings;

FMimeTypes: TStrings;

FAuthNeeded: TStrings;

constructor Create;

destructor Destroy; override;

end;

THTTPVars = record

FDoVirtualHosts:Boolean;

FDomain:TvsVirtualDomain;

FVirtualDomainRoot: String;

FPHPPath:TFileName;

FCaseSensitive:Boolean;

FServerName:String;

FVirtualDomains: TList;

FSupported: THTTPProtocols;

FAutomated: THTTPProtocols;

FErrorDocs: String;

end;

THTTPDocument = record

Headers: String;

Data: String;

end;

THTTPDoc = record

Command: TEnumHTTPProtocols;

Request,

Response: THTTPDocument;

end;

THostInfo = record

Host,

Port: String;

end;

TCallBack = record

FOnHead,

FOnGet,

FOnPut,

FOnPost,

FOnTrace,

FOnOptions: TOnRequest; //THTTPCallBack;

end;

//the component

TvsHTTPServer = class (TVisualServer)

protected

FVirtualServers:TList;

FHTTPVars:THTTPVars;

FCallBack: TCallBack;

//creates a virtual domain if not exists:

function GetVirtualDomain(Domain: String): TvsVirtualDomain;

public

class function ParseDomain(Domain: String): String; //cleans up a domain name

constructor Create (AOwner:TComponent); override;

procedure AddVirtualDomain (Domain:TvsVirtualDomain);

procedure RegisterDir (PhysicalDir: TFileName; VirtualDir: String; Domain: String=''; Recursive: Boolean=True);

procedure RegisterPreParser (Binary: TFileName; Extension: String; Domain: String=''; Params: String='"%s"');

procedure RegisterPHP (Binary: TFileName; Extension: String=''; Domain: String='');

procedure RegisterDefaultDoc (FileName: String; Domain: String='');

procedure RegisterMimeType (Extension, MimeType: String; Domain: String='');

procedure RegisterCGI (PhysicalDir: TFileName; VirtualDir: String='/cgi-bin'; Domain: String='');

procedure RegisterManualURL (URL: String; Domain: String='');

procedure RegisterAuthenticationDir (VirtualDir: String; Domain: String=''; Recursive: Boolean=True);

procedure ClearSettings;

function SaveSettings (FileName: TFileName): Boolean; override;

function LoadSettings (FileName: TFileName): Boolean; override;

published

property OnHead: TOnRequest read FCallBack.FOnHead write FCallBack.FOnHead;

property OnGet: TOnRequest read FCallBack.FOnGet write FCallBack.FOnGet;

property OnPost: TOnRequest read FCallBack.FOnPost write FCallBack.FOnPost;

property OnPut: TOnRequest read FCallBack.FOnPut write FCallBack.FOnPut;

property DoVirtualHosts:Boolean read FHTTPVars.FDoVirtualHosts write FHTTPVars.FDoVirtualHosts;

property PHPPath:TFileName read FHTTPVars.FPHPPath write FHTTPVars.FPHPPath;

property CaseSensitive:Boolean read FHTTPVars.FCaseSensitive write FHTTPVars.FCaseSensitive;

property SupportedProtocols:THTTPProtocols read FHTTPVars.FSupported write FHTTPVars.FSupported;

property AutomatedProtocols:THTTPProtocols read FHTTPVars.FAutomated write FHTTPVars.FAutomated;

property ErrorDocs: String read FHTTPVars.FErrorDocs write FHTTPVars.FErrorDocs;

property VirtualDomainRoot: String read FHTTPVars.FVirtualDomainRoot write FHTTPVars.FVirtualDomainRoot;

end;

//the protocol handler

TvsHTTPHandler = class (TServerHandler)

protected

//Returns NIL on invalid domain:

function GetVirtualDomain(Domain: String): TvsVirtualDomain;

//support function

function Compare (V1, V2: String): Boolean; //compares string based on CaseSensitive property

//procedures to find back vars:

function GetCGIPath(URL: String; Domain: String=''): String;

function GetPreParser (URL: String; Domain: String=''): TPreParser;

function IsManualURL (URL: String; Domain: String=''): Boolean;

function MapVirtualDir (URL: String; Domain: String=''): TFileName;

function GetDefaultDoc (Path: TFileName; Domain: String=''): String;

function IsAuthenticationNeeded (URL: String; Domain: String=''): Boolean;

function IsAuthenticated: Boolean;

procedure CreateFileHeaders (FileName: TFileName);

//function to see if there are any parsers (pre-parsers, cgi)

//if so, call them

//if not, return false and do rest

function CheckGetHeadPostParser (Domain: String=''): Boolean;

procedure Report404; //speaks for itself..

public

Buf:String;

FMode: THttpConnectionMode;

FPSock: TTCPBlockSocket;

//vars shared with component:

FHTTPVars: THTTPVars;

FCallBack: TCallBack;

//internal use:

FCurrentGetFile: TFileName;

FRangeStart: Int64;

FRangeEnd: Int64;

FPostData: String;

FCGIInfo: TCGIResult;

FKeepAlive: Boolean;

procedure Init; override;

procedure CopyCustomVars; override;

procedure Handler; override;

procedure ProcessRequest (Header: String);

function GetGetPath:TFileName; //returns path of file or cgi

procedure ProcessGet;

procedure ProcessHead;

procedure ProcessPut;

procedure ProcessPost;

procedure ProcessConnect;

procedure ProcessDelete;

procedure ProcessTrace;

procedure ProcessOptions;

//Procedures to split url:

function GetFile (URL: String): String;

function GetFileNoPath (URL: String): String;

function GetPath (URL: String): String;

function GetParams (URL: String): String;

procedure ReadPostData;

procedure MakeResponseHeaders;

procedure MakeErrorDoc;

procedure MakeArgs;

function MergeURL (Path, FileName: String): String;

procedure ProcessGetHeadPost(Method: TEnumHTTPProtocols);

procedure CheckRanges;

end;

function HTTPCodeToMessage (Code:Integer):String;

function HTTPCodeToMessage (Code:Integer):String;

var M:String;

if (code<100) or (code>999) then

code := 500; //internal server error

case Code of

100: M:='Continue';

101: M:='Switching Protocols';

200: M:='Ok';

201: M:='Created';

202: M:='Accepted';

203: M:='Non-Authoritive Information';

204: M:='No Content';

205: M:='Reset Content';

206: M:='Partial Content';

300: M:='Multiple Choices';

301: M:='Moved Permanently';

302: M:='Found';

303: M:='See Other Method';

304: M:='Not Modified';

305: M:='Use Proxy';

307: M:='Temporary Redirect';

400: M:='Bad Request';

401: M:='Unauthorized';

402: M:='Payment required';

403: M:='Forbidden';

404: M:='Not Found';

405: M:='Method Not Allowed';

406: M:='Not Acceptable';

407: M:='Proxy Authentication Required';

408: M:='Request Timeout';

409: M:='Conflict';

410: M:='Gone';

411: M:='Length Required';

412: M:='Precondition Failed';

413: M:='Request Entity Too Large';

414: M:='Request-URI Too Long';

415: M:='Unsupported Media Type';

416: M:='Requested Range Not Satisfiable';

417: M:='Expectation Failed';

500: M:='Internal Error';

501: M:='Not Implemented';

502: M:='Bad Gateway';

503: M:='Service Unavailable';

504: M:='Gateway Timeout';

505: M:='HTTP Version Not Supported';

else

M := 'Unknown';

end;

M:=IntToStr(Code)+' '+M;

Result := M;

end;

function ListDirAsHTML(PhysicalDir, VirtualDir, Hostname:String):String;

var v,w: String;

sr: TSearchRec;

f: Integer;

v := 'Index of //'+HostName+VirtualDir;

Result := '<html><head><title>'+v+'</title></head>'+

'<body><h2><i>'+v+'</i></h2><br>'#13#10'<table>'#13#10;

f := FindFirst (PhysicalDir+PathDelim+'*.*', faAnyFile - faHidden, sr);

while f = 0 do

begin

w := sr.Name;

if (sr.Attr and faDirectory)<>0 then

w := w + '/';

Result := Result + Format ( '<tr><td><a href="%s">%s</a></td><td>%d</td><td>%s</td></tr>',

[ '//'+HostName+VirtualDir+w,

VirtualDir+w,

sr.Size,

DateTimeToStr (FileDateToDateTime(sr.Time))

]);

f := FindNext (sr);

end;

Result := Result + '</table>'#13#10'<hr>Visual Synapse HTTP Server</body>'#13#10'</html>';

FindClose (sr);

end;

procedure TvsHTTPServer.AddVirtualDomain(Domain: TvsVirtualDomain);

end;

procedure TvsHTTPServer.ClearSettings;

var VD: TvsVirtualDomain;

i: Integer;

//remove list of virtual domains:

for i:=0 to FHTTPVars.FVirtualDomains.Count - 1 do

TvsVirtualDomain(FHTTPVars.FVirtualDomains[i]).Free;

FHTTPVars.FVirtualDomains.Clear;

VD := TvsVirtualDomain.Create;

VD.FHostName := '*';

FHTTPVars.FVirtualDomains.Add (VD);

FHTTPVars.FVirtualDomainRoot := '';

end;

constructor TvsHTTPServer.Create(AOwner: TComponent);

var VD: TvsVirtualDomain;

inherited;

FClientType := TvsHTTPHandler;

ListenPort := '80';

FSettings.FHasCustomVars := True;

FHTTPVars.FSupported := [hpHEAD, hpGET,{ hpPUT, hpDELETE,} hpPOST, hpTRACE, hpOPTIONS{, hpCONNECT}];

FHTTPVars.FAutomated := FHTTPVars.FSupported + [hpCONNECT];

FHTTPVars.FCaseSensitive := True;

FHTTPVars.FVirtualDomains := TList.Create;

ClearSettings;

end;

function TvsHTTPHandler.GetVirtualDomain(Domain: String): TvsVirtualDomain;

var i: Integer;

Domain := TvsHTTPServer.ParseDomain(Domain);

Result := nil;

for i:=0 to FHTTPVars.FVirtualDomains.Count - 1 do

if (TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]).FHostName = Domain) or

(TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]).FHostName = 'www.'+Domain) then

begin

Result := TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]);

break;

end;

if (Result = nil) and (FHTTPVars.FVirtualDomainRoot <> '') then

begin

//dynamic virtual domain mapping

//parse virtual domain root

//if directory exists, map

if (pos ('/', Domain)<=0) and (pos ('\', domain)<=0) and

(DirectoryExists (FHTTPVars.FVirtualDomainRoot + PathSep + Domain) or

DirectoryExists (FHTTPVars.FVirtualDomainRoot + PathSep + 'www.'+Domain)) then

begin

//FHTTPVars.FVirtualDomains.Add ();

//todo: thread safety.

Result := TvsVirtualDomain.Create;

Result.FVirtualPath.AddObject ('+/', StrToObj(FHTTPVars.FVirtualDomainRoot + PathSep + Domain));

Result.FHostName := Domain;

//FHTTPVars.

FHTTPVars.FVirtualDomains.Add (Result);

end;

end;

{

end;

class function TvsHTTPServer.ParseDomain(Domain: String): String;

Result := lowercase (Domain);

if Result='' then

Result := '*';

end;

procedure TvsHTTPServer.RegisterCGI(PhysicalDir: TFileName; VirtualDir,

Domain: String);

var VD: TvsVirtualDomain;

PhysicalDir := ExpandUNCFileName(PhysicalDir);

VD := GetVirtualDomain (Domain);

VD.FCGI.AddObject (VirtualDir, StrToObj(PhysicalDir));

end;

procedure TvsHTTPServer.RegisterDefaultDoc(FileName, Domain: String);

var VD: TvsVirtualDomain;

VD := GetVirtualDomain (Domain);

if VD.FDefaultDocuments.IndexOf (FileName)<0 then

VD.FDefaultDocuments.Add (FileName);

end;

procedure TvsHTTPServer.RegisterDir(PhysicalDir: TFileName; VirtualDir,

Domain: String; Recursive: Boolean);

var VD: TvsVirtualDomain;

SR: TSearchRec;

f: Integer;

//todo?

//check virtualdir for beginning slash

PhysicalDir := ExpandUNCFileName(PhysicalDir);

VD := GetVirtualDomain (Domain);

if Recursive then

VirtualDir := '+' + VirtualDir

else

VirtualDir := '-' + VirtualDir;

if VD.FVirtualPath.IndexOf (VirtualDir) < 0 then

VD.FVirtualPath.AddObject (VirtualDir, StrToObj(PhysicalDir));

}

end;

procedure TvsHTTPServer.RegisterManualURL(URL, Domain: String);

var VD: TvsVirtualDomain;

VD := GetVirtualDomain (Domain);

if VD.FManualURL.IndexOf(URL)<0 then

VD.FManualURL.Add (URL);

end;

procedure TvsHTTPServer.RegisterMimeType(Extension, MimeType: String; Domain: String='');

var VD: TvsVirtualDomain;

i: Integer;

VD := GetVirtualDomain (Domain);

i := VD.FMimeTypes.IndexOf(Extension);

if i>=0 then

VD.FMimeTypes.Delete(i);

VD.FMimeTypes.AddObject (Extension, StrToObj (MimeType));

end;

procedure TvsHTTPServer.RegisterPreParser(Binary: TFileName; Extension: String;

Domain: String=''; Params: String='"%s"');

var VD: TvsVirtualDomain;

i: Integer;

PreParser: TPreParser;

VD := GetVirtualDomain (Domain);

i := VD.FPreParser.IndexOf(Extension);

if i>=0 then

begin

VD.FPreParser.Objects[i].Free;

VD.FPreParser.Delete(i);

end;

PreParser := TPreParser.Create;

PreParser.ExePath := Binary;

PreParser.Params := Params;

VD.FPreParser.AddObject (Extension, PreParser);

end;

function TvsHTTPServer.LoadSettings(FileName: TFileName): Boolean;

var //FI: TIniFile;

sec, nv: TStrings;

i,j: Integer;

d,p,

n,v,

f : String;

r: Boolean;

pe,pp: String;

Result := InitIniRead (FileName);

if not Result then

exit;

FHTTPVars.FVirtualDomainRoot := FIni.ReadString ('global', 'virtualdomainroot', '');

sec := TStringList.Create;

nv := TStringList.Create;

FIni.ReadSections (sec);

for j := 0 to sec.Count - 1 do

if pos (':', sec[j])>0 then

begin

d := copy (sec[j],1, pos(':', sec[j])-1);

p := lowercase (copy (sec[j], length(d)+2, maxint));

if (p<>'') then

begin

nv.Clear;

FIni.ReadSectionValues(sec[j], nv);

for i:=0 to nv.count - 1 do

begin

n := nv.Names[i];

v := nv.Values[nv.Names[i]];

if(n<>'') and (n[1]<>'#') then //allow comments in ini file

begin

r := true;

if n<>'' then

begin

if n[1] in ['-', '+'] then

begin

r := n[1]='+';

f := copy (n,2,maxint);

end

else

f:=n;

end

else

f:='';

if pos ('|', v)>0 then

begin

pe := copy (v,1,pos('|',v)-1);

pp := copy (v, length(pe)+2, maxint);

end

else

begin

pe := v;

pp := '';

end;

//d-domain

//p-param/command

//n-'name'/key

//v-value

//f-filename

//r-recursive

if p='pathmapping' then

RegisterDir (v,f,d,r)

else

if p='cgi' then

RegisterCGI (v,f,d)

else

if p='preparser' then

RegisterPreParser (pe, n, d, pp)

else

if p='manualurl' then

RegisterManualURL (n, d)

else

if p='authenticationneeded' then

RegisterAuthenticationDir (f, d, r)

else

if p='defaultdocuments' then

RegisterDefaultDoc (n, d)

else

if p='mimetypes' then

RegisterMimeType (n, v, d)

;

end;

end;

end;

end;

FinishIni;

end;

function TvsHTTPServer.SaveSettings(FileName: TFileName): Boolean;

var i: Integer;

VD: TvsVirtualDomain;

h, hc: String;

sl: TStrings;

procedure StrObjToNameValue (so, nv: TStrings; Reverse: Boolean=False);

var i,n: Integer;

v: String;

begin

nv.Clear;

n := 0;

for i:=0 to so.Count-1 do

begin

v := '';

if so.Objects[i] is TString then

v := TString(so.Objects[i]).Value

else

if so.Objects[i] is TPreParser then

v := TPreParser(so.Objects[i]).ExePath+'|'+

TPreParser(so.Objects[i]).Params;

if Reverse then

begin

if so[i]='' then

so[i] := '=';

if v='' then

begin

inc (n);

v := 'n'+IntToStr(n); //Add a default name to this value.

end;

v := v+'='+so[i];

end

else

if so[i]<>'' then

begin

if v='' then

v := '='; //add a default value '=' to name with no value

v := so[i]+'='+v;

end;

if v<>'' then

nv.Add (v);

end;

if n<>0 then

nv.Add ('N='+IntToStr(n));

end;

if not InitIniWrite (FileName) then

exit;

FIni.WriteString ('global', 'virtualdomainroot', FHTTPVars.FVirtualDomainRoot);

sl := TStringList.Create;

for i := 0 to FHTTPVars.FVirtualDomains.Count - 1 do

begin

//h contains section id

vd := TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]);

h := vd.FHostName + ':';

//Save help info

if vd.FHostName = '*' then

begin

sl.Text := '#0= [+|-]/virtual_dir/=d:\physicaldir'#10+

'#1= The plus or minus determinate if the directory is'#10+

'#2= mapped recursively. + = recursive on, - = off';

WriteSectionValues (h+'PathMapping', sl);

sl.Text := '#0= CGI directory, containing executable files.'#10+

'#1= those files will be executed'#10+

'#2= Directory listing of cgi directories is not allowed'#10+

'#3= Take extreme care with cgi directories (do not map against a ftp account)'#10+

'#4= Currently cgi are executed within the servers process space.';

WriteSectionValues (h+'CGI', sl);

sl.Text := '#0= Preparsers, like php and perl are defined here'#10+

'#1= The executable is seperated from it''s parameters'#10+

'#2= by a pipe character | (vertical line). This character is mandatory'#10+

'#3= on the command line you can fill in %s to denote the path to the file'#10+

'#4= to the file to be preparsed (absolute physical path)';

WriteSectionValues (h+'PreParser', sl);

sl.Text := '#0= Manual url''s are implemented by a custom-made webserver';

WriteSectionValues (h+'ManualURL', sl);

sl.Text := '#0= A list of virtual directories for which authentication is needed.'#10+

'#1= Make sure to put some characters (or comment) after the equal sign (=)';

WriteSectionValues (h+'AuthenticationNeeded', sl);

sl.Text := '#0= A list of default documents. If exist, client will get redirected'#10+

'#1= to this document. If default document is not found, the contents of'#10+

'#2= the directory are listed.'#10+

'#3= Make sure to put some characters (or comment) after the equal sign (=)';

WriteSectionValues (h+'DefaultDocuments', sl);

sl.Text := '#0= Define addition mime types here, like: ext=mime/type';

WriteSectionValues (h+'MimeType', sl);

end;

//save settings...

StrObjToNameValue (vd.FVirtualPath, sl);

if sl.Count > 0 then

WriteSectionValues (h+'PathMapping', sl);

StrObjToNameValue (vd.FCGI, sl);

if sl.Count > 0 then

WriteSectionValues (h+'CGI', sl);

StrObjToNameValue (vd.FPreParser, sl);

if sl.Count > 0 then

WriteSectionValues (h+'PreParser', sl);

StrObjToNameValue (vd.FManualURL, sl);

if sl.Count > 0 then

WriteSectionValues (h+'ManualURL', sl);

StrObjToNameValue (vd.FAuthNeeded, sl);

if sl.Count > 0 then

WriteSectionValues (h+'AuthenticationNeeded', sl);

StrObjToNameValue (vd.FDefaultDocuments, sl);

if sl.Count > 0 then

WriteSectionValues (h+'DefaultDocuments', sl);

StrObjToNameValue (vd.FMimeTypes, sl);

if sl.Count > 0 then

WriteSectionValues (h+'MimeType', sl);

end;

sl.Free;

FinishIni;

end;

procedure TvsHTTPServer.RegisterPHP (Binary: TFileName; Extension: String=''; Domain: String='');

Binary := ExpandUNCFileName(Binary);

if Extension='' then

Extension := '.php';

RegisterPreParser (Binary, Extension, Domain, '-f "%s"');

end;

function TvsHTTPHandler.GetFile(URL: String): String;

var i: Integer;

i := pos ('?', URL);

if i>0 then

Result := Copy (URL, 1, i-1)

else

Result := URL;

end;

function TvsHTTPHandler.GetParams(URL: String): String;

var i: Integer;

i := pos ('?', URL);

if i>0 then

Result := Copy (URL, i+1, maxint)

else

Result := '';

end;

function TvsHTTPHandler.GetPreParser(URL, Domain: String): TPreParser;

var Ext: String;

i: Integer;

VD: TvsVirtualDomain;

Result := nil;

Ext := ExtractFileExt (GetFile (URL));

VD := GetVirtualDomain (Domain);

if Assigned (VD) then

i := VD.FPreParser.IndexOf (Ext) //we ignore case.. fix.

else

i := -1; //domain does not exist.

if i>=0 then

Result := TPreParser(VD.FPreParser.Objects[i])

else //not found

if Domain<>'' then //avoid endless lookups on empty (default) domain

Result := GetPreParser (URL); //fetch parser of default (''no'') domain.

end;

function TvsHTTPHandler.GetCGIPath(URL, Domain: String): String;

var Path: String;

VD: TvsVirtualDomain;

i: Integer;

Path := GetPath (URL); //S _should_ (?) be in form /path/ or /full/path/name/

VD := GetVirtualDomain (Domain);

if Assigned (VD) then

i := VD.FCGI.IndexOf (Path) //we ignore case.. fix.

else

i := -1; //domain does not exist.

if i>=0 then

Result := TString(VD.FCGI.Objects[i]).Value+PathSep+Copy (GetFile(URL), Length(Path)+1, maxint)

else

if Domain <> '' then

Result := GetCGIPath (URL, '');

end;

function TvsHTTPHandler.IsManualURL(URL, Domain: String): Boolean;

var VD: TvsVirtualDomain;

i: Integer;

VD := GetVirtualDomain (Domain);

if Assigned (VD) then

i := VD.FManualURL.IndexOf (GetFile(URL)) //yeah.. case insensitive again.. fix.

else

i := -1;

if (i < 0) and (Domain <> '') then

Result := IsManualURL (URL)

else

Result := i >= 0;

end;

function TvsHTTPHandler.Compare(V1, V2: String): Boolean;

if FHTTPVars.FCaseSensitive then

Result := V1 = V2

else

Result := AnsiStrComp (PChar(V1), PChar(V2))=0;

end;

function TvsHTTPHandler.GetPath(URL: String): String;

var s: String;

i: Integer;

p,q: Integer;

s := GetFile (URL);

i := length (s);

while i>1 do

if s[i]='/' then

break

else

dec(i);

if i>1 then //i holds position of last slash

Result := copy (URL, 1, i)

else

Result := '/';

//Now filter out dummy paths:

//strip '/./' directories:

Result := StringReplace (Result, '/./', '/', [rfReplaceAll]);

//strip '/../' directories:

while (pos ('/../', Result)) > 0 do

begin

p := pos ('/../', Result);

q := p - 1;

while (q>1) and (Result[q] <> '/') do

dec (q);

if (q>=1) and (Result[q] = '/') then

begin

Delete (Result, q, p - q +3);

end

else

begin

Result := ''; //invalid request

exit;

end;

end;

end;

function TvsHTTPServer.GetVirtualDomain(Domain: String): TvsVirtualDomain;

var i: Integer;

Domain := ParseDomain(Domain);

Result := nil;

for i:=0 to FHTTPVars.FVirtualDomains.Count - 1 do

if TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]).FHostName = Domain then

begin

Result := TvsVirtualDomain (FHTTPVars.FVirtualDomains[i]);

break;

end;

//Add one if not yet exist:

if (not Assigned (Result)) then

begin //add one

Result := TvsVirtualDomain.Create;

FHTTPVars.FVirtualDomains.Add (Result);

Result.FHostName := Domain;

end;

end;

procedure TvsHTTPServer.RegisterAuthenticationDir(VirtualDir, Domain: String;

Recursive: Boolean);

var r: String;

vd : TvsVirtualDomain;

if VirtualDir='' then

VirtualDir := '/';

vd := GetVirtualDomain (Domain);

with VD.FAuthNeeded do

begin

if Recursive then

r := '+'

else

r := '-';

r := r + VirtualDir;

if IndexOf (r)<0 then

Add (r);

end;

end;

procedure TvsHTTPHandler.CopyCustomVars;

FHTTPVars := TvsHTTPServer(FSettings.Owner).FHTTPVars;

FCallBack := TvsHTTPServer(FSettings.Owner).FCallBack;

end;

function TvsHTTPHandler.GetGetPath: TFileName;

//See if handler fits in some virtual domain

end;

procedure TvsHTTPHandler.Handler; //= Thread.Execute

var FS: TFileStream;

i: Integer;

FMode := cmWait;

while not Terminated do

begin

//Read an HTTP header

case FMode of

cmWait: //this is not limited to GET

//but it porcesses the header

//if necessary, like PUT, POST or CONNECT it will change the mode

begin

Buf := FSock.RecvTerminated (FSettings.FTimeOut{30000}, CRLF+CRLF);

//for the time being, don't support keep-alive (fix this)

//fix: if connection keep-alive mode = get

//Unless otherwise set, we close the connection after processing.

FMode := cmClose;

if Buf<>'' then

begin

FResponse.ResponseCode := 0;

ProcessRequest (Buf);

if FResponse.ResponseCode = 0 then

FResponse.ResponseCode := 400; //Unknown request

if (FResponse.ResponseCode >= 400) and

(FResponse.Data='') then //generate error doc

MakeErrorDoc;

FKeepAlive := (FMode=cmDone) and

(FResponse.ResponseCode >= 200) and

(FResponse.ResponseCode < 500) and

(lowercase(FRequest.Header.Values['Connection']) = 'keep-alive');

FKeepAlive := False; //sorry, there are bugs currently.

//keep alive conditionals:

//the client must request it

//it must not be a parsed PHP script

//since there is no content-length available.

if (FResponse.ResponseCode <> 0) then

begin //We send data ourselves:

Log (Format ('%d %s %s %s',

[FResponse.ResponseCode,

FRequest.Command,

FRequest.Parameter,

FRequest.Domain,