{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: François PIETTE
Description: THttpServer implement the HTTP server protocol, that is a
web server kernel.
Reference: RFC2616 (HTTP protocol) and RFC2617 (Authentication).
You must implement sucurity yourself, specially, check the URL or
document path for valid values in your application. Be sure to
check for '..\', '.\', drive designation and UNC.
Do the check in OnGetDocument and similar event handlers.
Creation: Oct 10, 1999
Version: 6.07
EMail: francois.piette@overbyte.be http://www.overbyte.be
Support: Use the mailing list twsocket@elists.org
Follow "support" link at http://www.overbyte.be for subscription.
Legal issues: Copyright (C) 1999-2009 by François PIETTE
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
' + #13#10;
SendHeader(FVersion + ' 416 Requested range not satisfiable' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10 +
#13#10);
{ Do not use AnswerString method because we don't want to use ranges }
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.Answer404;
var
Body : String;
begin
Body := ' ' + #13#10;
SendHeader(FVersion + ' 404 Not Found' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10 +
#13#10);
{ Do not use AnswerString method because we don't want to use ranges }
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.Answer403;
var
Body : String;
begin
Body := ' ' + #13#10;
SendHeader(FVersion + ' 403 Forbidden' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10 +
#13#10);
{ Do not use AnswerString method because we don't want to use ranges }
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.Answer401;
var
Body : String;
Header : String;
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
I : Integer;
iCh : Integer;
AuthString : String;
Nonce : TAuthDigestNonceRec;
{$ENDIF}
begin
Body := ' ' + #13#10;
Header := FVersion + ' 401 Access Denied' + #13#10;
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
{$IFDEF USE_NTLM_AUTH}
if (atNtlm in FAuthTypes) then begin
if Assigned(FAuthNtlmSession) and
(FAuthNtlmSession.State = lsInAuth) then
Header := Header + Trim('WWW-Authenticate: NTLM ' +
FAuthNtlmSession.NtlmMessage) + #13#10
else
Header := Header +
'WWW-Authenticate: NTLM' + #13#10;
end;
{$ENDIF}
if (atDigest in FAuthTypes) then begin
FAuthDigestServerNonce := '';
FAuthDigestServerOpaque := '';
//Randomize; MUST be called only once! Thus moved to the constructor.
//FAuthDigestServerNonce := Base64Encode(_DateTimeToStr(_Now)); IMO weak AG
FAuthDigestOneTimeFlag := FAuthDigestNonceLifeTimeMin = 0;
{ This is the original implementation by FastStream with slightly }
{ improved speed and security, RFC2617 however recommends to include }
{ the ETAG header as well. IMO this stuff should be reviewed if we }
{ worry about security. AG }
{ Generate the opaque, we need it for the nonce hash }
SetLength(FAuthDigestServerOpaque, 34);
for I := 1 to Length(FAuthDigestServerOpaque) do begin
while TRUE do begin
iCh := Random(122);
case iCh of
48..57, 65..90, 97..122 :
begin
FAuthDigestServerOpaque[I] := Char(iCh);
Break;
end;
end
end;
end;
Nonce.DT := Now;
Nonce.Hash := AuthDigestGenNonceHash(Nonce.DT, FAuthDigestServerOpaque);
FAuthDigestServerNonce := String(Base64Encode(PAnsiChar(@Nonce), SizeOf(Nonce)));
case FServer.FAuthDigestMethod of
daAuth: AuthString := 'auth';
daAuthInt: AuthString := 'auth-int';
daBoth: AuthString := 'auth,auth-int';
end;
Header := Header +
'WWW-Authenticate: ' +
'Digest realm="' + FAuthRealm + '"' +
', qop="' + AuthString + '"' +
', nonce="' + FAuthDigestServerNonce + '"' +
', opaque="' + FAuthDigestServerOpaque + '"';
if FAuthDigestStale then
Header := Header + ', stale="true"' + #13#10
else
Header := Header + #13#10;
end;
if (atBasic in FAuthTypes) then begin
Header := Header +
'WWW-Authenticate: ' +
'Basic Realm="' + FAuthRealm + '"' + #13#10;
end;
{$ENDIF}
Header := Header +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10;
if (FHttpVerNum = 11) and (not FKeepAlive) then
Header := Header + 'Connection: close' + #13#10
else if (FHttpVerNum = 10) and FKeepAlive then
Header := Header + 'Connection: keep-alive' + #13#10;
(*
if FAuthInit then begin //the initial 401
if (FHttpVerNum = 11) and (not FKeepAlive) then
Header := Header + 'Connection: close' + #13#10
else if (FHttpVerNum = 10) and FKeepAlive then
Header := Header + 'Connection: keep-alive' + #13#10;
end
else begin
{$IFDEF USE_NTLM_AUTH}
if not FKeepAlive then
FKeepAlive := TRUE;
if (FHttpVerNum = 10) then
Header := Header + 'Connection: keep-alive' + #13#10;
{$ELSE}
if (FHttpVerNum = 11) and (not FKeepAlive) then
Header := Header + 'Connection: close' + #13#10
else if (FHttpVerNum = 10) and FKeepAlive then
Header := Header + 'Connection: keep-alive' + #13#10;
{$ENDIF}
end;
*)
Header := Header + #13#10; // Mark the end of header
{ Do not use AnswerString method because we don't want to use ranges }
SendHeader(Header);
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.Answer501;
var
Body : String;
begin
Body := '501 Unimplemented';
SendHeader(FVersion + ' 501 Unimplemented' + #13#10 +
'Content-Type: text/plain' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10 +
#13#10);
{ Do not use AnswerString method because we don't want to use ranges }
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ As its name implies... }
procedure THttpConnection.ProcessRequest;
var
Status : Integer;
begin
TriggerBeforeProcessRequest;
if FPath = '/' then
FDocument := FDocDir
else if (FPath <> '') and (FPath[1] = '/') then
FDocument := AbsolutisePath(FDocDir +
URLDecode(UnixPathToDosPath(FPath)))
else
FDocument := AbsolutisePath(FDocDir + '\' +
URLDecode(UnixPathToDosPath(FPath)));
if Length(FDocument) < Length(FDocDir) then
Status := -1
else if Length(FDocument) > Length(FDocDir) then
Status := CompareText(Copy(FDocument, 1, Length(FDocDir) + 1),
FDocDir + '\')
else
Status := CompareText(FDocument + '\', FDocDir + '\');
FOutsideFlag := (Status <> 0);
{ Check for default document }
if (Length(FDocument) > 0) and
(FDocument[Length(FDocument)] = '\') and
(FileExists(FDocument + FDefaultDoc)) then
FDocument := FDocument + FDefaultDoc
else if IsDirectory(FDocument) and
(FileExists(FDocument + '\' + FDefaultDoc)) then
FDocument := FDocument + '\' + FDefaultDoc;
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
AuthCheckAuthenticated;
{$ENDIF}
if FMethod = 'GET' then
ProcessGet
else if FMethod = 'POST' then
ProcessPost
else if FMethod = 'HEAD' then
ProcessHead
else begin
Answer501; { 07/03/2005 was Answer404 }
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerGetDocument(var Flags : THttpGetFlag);
begin
if Assigned(FOnGetDocument) then
FOnGetDocument(Self, Flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerHeadDocument(var Flags : THttpGetFlag);
begin
if Assigned(FOnHeadDocument) then
FOnHeadDocument(Self, Flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerPostDocument(var Flags : THttpGetFlag);
begin
if Assigned(FOnPostDocument) then
FOnPostDocument(Self, Flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerHttpRequestDone;
begin
if Assigned(FOnHttpRequestDone) then
FOnHttpRequestDone(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerBeforeProcessRequest; {DAVID}
begin
if Assigned(FOnBeforeProcessRequest) then
FOnBeforeProcessRequest(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessPost;
var
Flags : THttpGetFlag;
begin
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
if not FAuthenticated then
Flags := hg401
else
{$ENDIF}
if FOutsideFlag and (not (hoAllowOutsideRoot in FOptions)) then
Flags := hg403
else
Flags := hg404;
FAcceptPostedData := FALSE;
TriggerPostDocument(Flags);
case Flags of
hg401:
begin
Answer401;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg403:
begin
Answer403;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg404:
begin
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hgAcceptData:
FAcceptPostedData := TRUE;
else
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This method has to be called by main code when all posted data has been }
{ received. }
procedure THttpConnection.PostedDataReceived;
begin
LineMode := TRUE;
FState := hcRequest; { Bjørnar. To let the server be able to handle }
{ more requests on same connection after a POST }
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessHead;
var
Flags : THttpGetFlag;
begin
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
if not FAuthenticated then
Flags := hg401
else
{$ENDIF}
if FOutsideFlag and (not (hoAllowOutsideRoot in FOptions)) then
Flags := hg403
else if (hoAllowDirList in FOptions) and IsDirectory(FDocument) then
Flags := hgSendDirList
else
Flags := hgSendDoc;
TriggerHeadDocument(Flags);
case Flags of
hg401:
begin
Answer401;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg403:
begin
Answer403;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg404:
begin
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hgSendDoc:
begin
if FileExists(FDocument) then
SendDocument(httpSendHead)
else begin
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
end;
hgSendStream:
SendStream;
hgSendDirList:
SendDirList(httpSendHead);
hgWillSendMySelf:
{ Nothing to do };
else
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessGet;
var
Flags : THttpGetFlag;
TempStream : TFileStream;
OK : Boolean;
begin
{$IFNDEF NO_AUTHENTICATION_SUPPORT}
if not FAuthenticated then
Flags := hg401
else
{$ENDIF}
if FOutsideFlag and (not (hoAllowOutsideRoot in FOptions)) then
Flags := hg403
else if (hoAllowDirList in FOptions) and IsDirectory(FDocument) then
Flags := hgSendDirList
else
Flags := hgSendDoc;
TriggerGetDocument(Flags);
case Flags of
hg401:
begin
Answer401;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg403:
begin
Answer403;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hg404:
begin
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
hgSendDoc:
begin
OK := FALSE;
try
if not FileExists(FDocument) then begin
{ File not found }
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end
else begin
TempStream := TFileStream.Create(FDocument, fmOpenRead + fmShareDenyWrite);
TempStream.Destroy;
OK := TRUE;
end;
except
Answer404;
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
if OK then
SendDocument(httpSendDoc)
end;
hgSendStream:
SendStream;
hgSendDirList:
SendDirList(httpSendDoc);
hgWillSendMySelf:
{ Nothing to do };
else
if FKeepAlive = FALSE then {Bjornar}
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function DocumentToContentType(FileName : String) : String;
var
Ext : String;
begin
{ We probably should use the registry to find MIME type for file types }
Ext := LowerCase(ExtractFileExt(FileName));
if Length(Ext) > 1 then
Ext := Copy(Ext, 2, Length(Ext));
if (Ext = 'htm') or (Ext = 'html') then
Result := 'text/html'
else if Ext = 'gif' then
Result := 'image/gif'
else if Ext = 'bmp' then
Result := 'image/bmp'
else if (Ext = 'jpg') or (Ext = 'jpeg') then
Result := 'image/jpeg'
else if (Ext = 'tif') or (Ext = 'tiff') then
Result := 'image/tiff'
else if Ext = 'txt' then
Result := 'text/plain'
else if Ext = 'css' then
Result := 'text/css'
else if Ext = 'wav' then
Result := 'audio/x-wav'
else if Ext = 'ico' then
Result := 'image/x-icon'
{ WAP support begin }
else if Ext = 'wml' then
Result := 'text/vnd.wap.wml'
else if Ext = 'wbmp' then
Result := 'image/vnd.wap.wbmp'
else if Ext = 'wmlc' then
Result := 'application/vnd.wap.wmlc'
else if Ext = 'wmlscript' then
Result := 'text/vnd.wap.wmlscript'
else if Ext = 'wmlscriptc' then
Result := 'application/vnd.wap.wmlscriptc'
{ WAP support end }
else if Ext = 'pdf' then
Result := 'application/pdf'
else
Result := 'application/binary';
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ See also RFC822_DateTime function in SmtpCli component }
{ RFC1123 5.2.14 redefine RFC822 Section 5. }
function RFC1123_Date(aDate : TDateTime) : String;
const
StrWeekDay : String = 'MonTueWedThuFriSatSun';
StrMonth : String = 'JanFebMarAprMayJunJulAugSepOctNovDec';
var
Year, Month, Day : Word;
Hour, Min, Sec, MSec : Word;
DayOfWeek : Word;
begin
DecodeDate(aDate, Year, Month, Day);
DecodeTime(aDate, Hour, Min, Sec, MSec);
DayOfWeek := ((Trunc(aDate) - 2) mod 7);
Result := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' +
Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d',
[Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3),
Year, Hour, Min, Sec]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Return document file date from document filename. }
{ Return 0 if file not found. }
function FileDate(FileName : String) : TDateTime;
var
SearchRec : TSearchRec;
Status : Integer;
begin
Status := FindFirst(FileName, faAnyFile, SearchRec);
try
if Status <> 0 then
Result := 0
else
Result := FileDateToDateTime(SearchRec.Time);
finally
FindClose(SearchRec);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ANDREAS Byte-range-separator (use the same as IIS) }
const
ByteRangeSeparator = '[lka9uw3et5vxybtp87ghq23dpu7djv84nhls9p]';
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ANDREAS Helperfunction to create the HTTP-Header }
function CreateHttpHeader(
Version : String;
ProtoNumber : Integer;
AnswerContentType : String;
RangeList : THttpRangeList;
DocSize : THttpRangeInt;
CompleteDocSize : THttpRangeInt): String;
begin
if ProtoNumber = 200 then
Result := Version + ' 200 OK' + #13#10 +
'Content-Type: ' + AnswerContentType + #13#10 +
'Content-Length: ' + IntToStr(DocSize) + #13#10 +
'Accept-Ranges: bytes' + #13#10
{else if ProtoNumber = 416 then
Result := Version + ' 416 Request range not satisfiable' + #13#10}
else if ProtoNumber = 206 then begin
if RangeList.Count = 1 then begin
Result := Version + ' 206 Partial Content' + #13#10 +
'Content-Type: ' + AnswerContentType + #13#10 +
'Content-Length: ' + IntToStr(DocSize) + #13#10 +
'Content-Range: bytes ' +
RangeList.Items[0].GetContentRangeString(CompleteDocSize) +
#13#10;
end
else begin
Result := Version + ' 206 Partial Content' + #13#10 +
'Content-Type: multipart/byteranges; boundary=' +
ByteRangeSeparator + #13#10 +
'Content-Length: ' + IntToStr(DocSize) + #13#10;
end;
end
else
raise Exception.Create('Unexpected ProtoNumber in CreateHttpHeader');
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ SendDocument will send FDocument file to remote client, build header and }
{ sending data (if required) }
procedure THttpConnection.SendDocument(SendType : THttpSendType);
var
Header : String;
NewDocStream : TStream;
ProtoNumber : Integer;
CompleteDocSize : THttpRangeInt;
ErrorSend : Boolean;
SyntaxError : Boolean;
begin
ErrorSend := FALSE;
ProtoNumber := 200;
FLastModified := FileDate(FDocument);
FAnswerContentType := DocumentToContentType(FDocument);
FDocStream.Free;
FDocStream := TFileStream.Create(FDocument, fmOpenRead + fmShareDenyWrite);
CompleteDocSize := FDocStream.Size;
{ANDREAS Create the virtual 'byte-range-doc-stream', if we are ask for ranges}
if RequestRangeValues.Valid then begin
{ NewDocStream will now be the owner of FDocStream -> don't free FDocStream }
NewDocStream := RequestRangeValues.CreateRangeStream(FDocStream,
FAnswerContentType, CompleteDocSize, SyntaxError);
if Assigned(NewDocStream) then begin
FDocStream := NewDocStream;
FDocStream.Position := 0;
ProtoNumber := 206;
end
else begin
if SyntaxError then
{ Ignore the content range header and send entire document in case }
{ of syntactically invalid byte-range-set }
FDocStream.Position := 0
else begin
{ Answer 416 Request range not satisfiable }
FDocStream.Free;
FDocStream := nil;
Answer416;
Exit;
end;
end;
end;
FDocSize := FDocStream.Size;
FDataSent := 0; { will be incremented after each send part of data }
{ Seek to end of document because HEAD will not send actual document }
if SendType = httpSendHead then
FDocStream.Seek(0, soFromEnd);
OnDataSent := ConnectionDataSent;
{ Create Header }
{ANDREAS Create Header for the several protocols}
Header := CreateHttpHeader(FVersion, ProtoNumber, FAnswerContentType, RequestRangeValues, FDocSize, CompleteDocSize);
if FLastModified <> 0 then
Header := Header +
'Last-Modified: ' + RFC1123_Date(FLastModified) +
' GMT' + #13#10;
{Bjornar}
if FKeepAlive then
Header := Header + 'Connection: keep-alive' + #13#10
else
Header := Header + 'Connection: close' + #13#10;
{Bjornar}
Header := Header + #13#10;
SendHeader(Header);
if not ErrorSend then begin
if FDocSize <= 0 then
Send(nil, 0);
if SendType = httpSendDoc then
SendStream
else
Send(nil, 0); { Added 15/04/02 }
end
else
Send(nil, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.SendHeader(Header : String);
begin
PutStringInSendBuffer(Header);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.SendStream;
begin
if not Assigned(FDocStream) then begin
{ No Stream to send ! Create an empty one to continue }
FDocStream := TMemoryStream.Create;
end
else
FDocStream.Seek(0, 0); { Go to start of stream }
(*
{$IFDEF USE_SSL}
BufSize := 8192; { Only for testing }
{$ENDIF}
*)
if not Assigned(FDocBuf) then
GetMem(FDocBuf, FSndBlkSize);
FDocSize := FDocStream.Size; { Should it take care of ranges ? }
FDataSent := 0;
OnDataSent := ConnectionDataSent;
ConnectionDataSent(Self, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.TriggerFilterDirEntry(DirEntry: THttpDirEntry);
begin
if Assigned(FOnFilterDirEntry) then
FOnFilterDirEntry(Self, Self, DirEntry);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function THttpConnection.FormatDirEntry(F : THttpDirEntry) : String;
var
Attr : String;
Link : String;
SizeString : String;
const
StrMonth : array [1..12] of String =
('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
begin
{$IFNDEF VER80}{$WARNINGS OFF}{$ENDIF}
if F.VolumeID or
(F.Name = '.') or
(F.Name = '..') then begin
{ Ignore hidden files, volume ID, current and parent dir entries }
Result := '';
Exit;
end;
Attr := '-rw--';
if F.Directory then begin
Attr[1] := 'd';
SizeString := '';
end
else
SizeString := IntToStr(F.SizeLow);
if F.ReadOnly then
Attr[3] := '-';
if F.SysFile then
Attr[4] := 's';
if F.Hidden then
Attr[5] := 'h';
{$IFNDEF VER80}{$WARNINGS ON}{$ENDIF}
if Path = '/' then
Link := '/' + UrlEncode(F.Name)
else if Path[Length(Path)] = '/' then
Link := Path + UrlEncode(F.Name)
else
Link := Path + '/' + UrlEncode(F.Name);
Result := ' Directory of ' +
TextToHtmlText(DosPathToUnixPath(AbsolutisePath(UnixPathToDosPath(Path)))) +
': ' + #13#10 +
'416 Requested range not satisfiable
404 Not Found
The requested URL ' +
TextToHtmlText(FPath) +
' was not found on this server.403 Forbidden
The requested URL ' +
TextToHtmlText(FPath) +
' is Forbidden on this server.401 Access Denied
The requested URL ' +
TextToHtmlText(FPath) +
' requires authorization.' + Attr + ' ' +
'' + SizeString + ' ' +
'' +
' ' + Format('%s %2.2d, %4.4d', [StrMonth[F.Month], F.Day, F.Year]) + ' ' +
'' +
' ' + Format('%2.2d:%2.2d:%2.2d', [F.Hour, F.Min, F.Sec]) + ' ' +
'' +
' ' +
TextToHtmlText(F.Name) + ' ' + #13#10;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This feature is somewhat broken with Delphi 1 since strings are limited to }
{ 255 characters ! Should replace String by TStream... }
function THttpConnection.BuildDirList : String;
var
Status : Integer;
F : TSearchRec;
ParentDir : String;
DirList : TStringList;
FileList : TStringList;
Data : THttpDirEntry;
I : Integer;
Total : Cardinal;
TotalBytes : Cardinal;
begin
{ Create a list of all directories }
DirList := TStringList.Create;
Status := FindFirst(Document + '\*.*', faAnyFile, F);
while Status = 0 do begin
if ((F.Attr and faDirectory) <> 0) and
((F.Attr and faVolumeID) = 0) and
(F.Name <> '.') and
(F.Name <> '..') then begin
Data := THttpDirEntry.Create;
Data.Visible := TRUE;
Data.Name := F.Name;
Data.SizeLow := F.Size;
Data.SizeHigh := 0;
Data.Day := (HIWORD(F.Time) and $1F);
Data.Month := ((HIWORD(F.Time) shr 5) and $0F);
Data.Year := ((HIWORD(F.Time) shr 9) and $3F) + 1980;
Data.Sec := ((F.Time and $1F) shl 1);
Data.Min := ((F.Time shr 5) and $3F);
Data.Hour := ((F.Time shr 11) and $1F);
Data.VolumeID := ((F.Attr and faVolumeID) <> 0);
Data.Directory := ((F.Attr and faDirectory) <> 0);
Data.ReadOnly := ((F.Attr and faReadOnly) <> 0);
Data.SysFile := ((F.Attr and faSysFile) <> 0);
Data.Hidden := ((F.Attr and faHidden) <> 0);
TriggerFilterDirEntry(Data);
if Data.Visible then
DirList.AddObject(Data.Name, Data)
else
Data.Free;
end;
Status := FindNext(F);
end;
FindClose(F);
DirList.Sort;
{ Create a list of all files }
FileList := TStringList.Create;
Status := FindFirst(Document + '\*.*', faAnyFile, F);
while Status = 0 do begin
if ((F.Attr and faDirectory) = 0) and
((F.Attr and faVolumeID) = 0) then begin
Data := THttpDirEntry.Create;
Data.Visible := TRUE;
Data.Name := F.Name;
Data.SizeLow := F.Size;
Data.SizeHigh := 0;
Data.Day := (HIWORD(F.Time) and $1F);
Data.Month := ((HIWORD(F.Time) shr 5) and $0F);
Data.Year := ((HIWORD(F.Time) shr 9) and $3F) + 1980;
Data.Sec := ((F.Time and $1F) shl 1);
Data.Min := ((F.Time shr 5) and $3F);
Data.Hour := ((F.Time shr 11) and $1F);
Data.VolumeID := ((F.Attr and faVolumeID) <> 0);
Data.Directory := ((F.Attr and faDirectory) <> 0);
Data.ReadOnly := ((F.Attr and faReadOnly) <> 0);
Data.SysFile := ((F.Attr and faSysFile) <> 0);
Data.Hidden := ((F.Attr and faHidden) <> 0);
TriggerFilterDirEntry(Data);
if Data.Visible then
FileList.AddObject(Data.Name, Data)
else
Data.Free;
end;
Status := FindNext(F);
end;
FindClose(F);
FileList.Sort;
Result := '' + #13#10 +
'' + #13#10 +
'' + #13#10 +
'' + #13#10;
if Path = '/' then
ParentDir := ''
else if Path[Length(Path)] = '/' then
ParentDir := DosPathToUnixPath(ExtractFilePath(UnixPathToDosPath(Copy(Path, 1, Length(Path) - 1))))
else
ParentDir := DosPathToUnixPath(ExtractFilePath(UnixPathToDosPath(Path)));
if (ParentDir <> '') and (ParentDir <> '/') then
SetLength(ParentDir, Length(ParentDir) - 1);
if ParentDir <> '' then
Result := Result + '
';
TotalBytes := 0;
Total := DirList.Count + FileList.Count;
if Total <= 0 then
Result := Result +'[To Parent Directrory] '
else begin
for I := 0 to DirList.Count - 1 do begin
Data := THttpDirEntry(DirList.Objects[I]);
Result := Result + 'No file ' + FormatDirEntry(Data) + ' ' + #13#10;
DirList.Objects[I].Free;
end;
DirList.Free;
for I := 0 to FileList.Count - 1 do begin
Data := THttpDirEntry(FileList.Objects[I]);
Result := Result + '' + FormatDirEntry(Data) +
' ' + #13#10;
TotalBytes := TotalBytes + Cardinal(Data.SizeLow);
FileList.Objects[I].Free;
end;
FileList.Free;
Result := Result + ' ';
end;
Result := Result + 'Total: ' +
IntToStr(Total) + ' file(s), ' +
IntToStr(TotalBytes) + ' byte(s)