📄 httpsrv.pas
字号:
FRequestHeader.Add(FRcvdLine);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Request is in FRcvdLine property. }
{ Split it into FMethod, FPath, FVersion and parameters. }
procedure THttpConnection.ParseRequest;
var
I, J : Integer;
begin
I := 1;
while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
Inc(I);
FMethod := UpperCase(Copy(FRcvdLine, 1, I - 1));
Inc(I);
while (I <= Length(FRcvdLine)) and (FRcvdLine[I] = ' ') do
Inc(I);
J := I;
while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
Inc(I);
FPath := Copy(FRcvdLine, J, I - J);
{ Find parameters }
J := Pos('?', FPath);
if J <= 0 then
FParams := ''
else begin
FParams := Copy(FPath, J + 1, Length(FPath));
FPath := Copy(FPath, 1, J - 1);
end;
Inc(I);
while (I <= Length(FRcvdLine)) and (FRcvdLine[I] = ' ') do
Inc(I);
J := I;
while (I <= Length(FRcvdLine)) and (FRcvdLine[I] <> ' ') do
Inc(I);
FVersion := Trim(UpperCase(Copy(FRcvdLine, J, I - J)));
if FVersion = '' then
FVersion := 'HTTP/1.0';
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.Answer404;
var
Body : String;
begin
Body := '<HTML><HEAD><TITLE>404 Not Found</TITLE></HEAD>' +
'<BODY><H1>404 Not Found</H1>The requested URL ' + FPath +
' was not found on this server.<P></BODY></HTML>' + #13#10;
PutStringInSendBuffer(FVersion + ' 404 Not Found' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' + IntToStr(Length(Body)) + #13#10 +
#13#10);
SendStr(Body);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ As its name implies... }
procedure THttpConnection.ProcessRequest;
var
I : Integer;
begin
if FPath[1] = '/' then
FDocument := FDocDir + FPath
else
FDocument := FDocDir + '\' + FPath;
{ Check for default document }
if FDocument[Length(FDocument)] = '/' then
FDocument := FDocument + FDefaultDoc;
{ Change slashes to backslashes }
for I := 1 to Length(FDocument) do begin
if FDocument[I] = '/' then
FDocument[I] := '\';
end;
if FMethod = 'GET' then
ProcessGet
else if FMethod = 'POST' then
ProcessPost
else if FMethod = 'HEAD' then
ProcessHead
else begin
Answer404;
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.ProcessPost;
var
Flags : THttpGetFlag;
begin
Flags := hg404;
TriggerPostDocument(Flags);
if Flags = hg404 then begin
Answer404;
CloseDelayed;
Exit;
end
else if Flags = hgAcceptData then
FAcceptPostedData := TRUE;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessHead;
var
Flags : THttpGetFlag;
begin
Flags := hgSendDoc;
TriggerHeadDocument(Flags);
case Flags of
hg404:
begin
Answer404;
CloseDelayed;
end;
hgSendDoc:
begin
if FileExists(FDocument) then
SendDocument(httpSendHead)
else begin
Answer404;
CloseDelayed;
end;
end;
hgSendStream:
SendStream;
hgWillSendMySelf:
{ Nothing to do };
else
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.ProcessGet;
var
Flags : THttpGetFlag;
begin
Flags := hgSendDoc;
TriggerGetDocument(Flags);
case Flags of
hg404:
begin
Answer404;
CloseDelayed;
end;
hgSendDoc:
begin
if FileExists(FDocument) then
SendDocument(httpSendDoc)
else begin
Answer404;
CloseDelayed;
end;
end;
hgSendStream:
SendStream;
hgWillSendMySelf:
{ Nothing to do };
else
CloseDelayed;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function DocumentToContentType(FileName : String) : String;
var
Ext : String;
begin
{ We probably should the registry to find MIME type for known 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 = 'txt' then
Result := 'text/plain'
else
Result := 'application/binary';
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ SendDocument will send FDocument file to remote client, build header and }
{ sending data (if required) }
procedure THttpConnection.SendDocument(SendType : THttpSendType);
var
DocSize : Integer;
begin
FAnswerContentType := DocumentToContentType(FDocument);
if Assigned(FDocStream) then begin
FDocStream.Destroy;
FDocStream := nil;
end;
FDocStream := TFileStream.Create(FDocument, fmOpenRead + fmShareDenyWrite);
DocSize := FDocStream.Size;
{ Seek to end of document because HEAD will not send actual document }
if SendType = httpSendHead then
FDocStream.Seek(0, soFromEnd);
OnDataSent := ConnectionDataSent;
{ Send Header }
SendStr(FVersion + ' 200 OK' + #13#10 +
'Content-Type: ' + FAnswerContentType + #13#10 +
'Content-Length: ' + IntToStr(DocSize) + #13#10 +
#13#10);
if SendType = httpSendDoc then
SendStream;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure THttpConnection.SendStream;
begin
if not Assigned(FDocStream) then begin
CloseDelayed;
Exit;
end;
if not Assigned(FDocBuf) then
GetMem(FDocBuf, BufSize);
OnDataSent := ConnectionDataSent;
ConnectionDataSent(Self, 0);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ All data in TWSocket has been sent. Read next lock from stream and send. }
{ When end of stream is reached, closed communication. }
procedure THttpConnection.ConnectionDataSent(Sender : TObject; Error : WORD);
var
Count : Integer;
begin
if not Assigned(FDocStream) then begin
{ End of file has been reached }
Exit;
end;
Count := FDocStream.Read(FDocBuf^, BufSize);
if Count <= 0 then begin
{ End of file found }
FDocStream.Destroy;
FDocStream := nil;
ShutDown(1);
{$IFNDEF VER80}
Sleep(0);
{$ENDIF}
PostMessage(Handle, WM_HTTP_DONE, 0, 0);
Exit;
end;
Send(FDocBuf, Count);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function xdigit(Ch : char) : Integer;
begin
if ch in ['0'..'9'] then
Result := ord(Ch) - ord('0')
else
Result := (ord(Ch) and 15) + 9;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function isxdigit(Ch : char) : Boolean;
begin
Result := (ch in ['0'..'9']) or (ch in ['a'..'z']) or (ch in ['A'..'Z']);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function htoin(value : PChar; len : Integer) : Integer;
var
i : Integer;
begin
Result := 0;
i := 0;
while (i < len) and (Value[i] = ' ') do
i := i + 1;
while (i < len) and (isxDigit(Value[i])) do begin
Result := Result * 16 + xdigit(Value[i]);
i := i + 1;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function htoi2(value : PChar) : Integer;
begin
Result := htoin(value, 2);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Retrieve a single value by name out of an URL encoded data stream }
{ In the stream, every space is replaced by a '+'. The '%' character is }
{ an escape character. The next two are 2 digits hexadecimal codes ascii }
{ code value. The stream is consitueted by name=value couples separated }
{ by a single '&' character. The special characters are coded by the '%' }
{ followed by hex-ascii character code. }
function ExtractURLEncodedValue(
Msg : PChar; { URL Encoded stream }
Name : String; { Variable name to look for }
var Value : String) { Where to put variable value }
: Boolean; { Found or not found that's the question }
var
NameLen : Integer;
Ch : Char;
P, Q : PChar;
begin
Result := FALSE;
Value := '';
if Msg = nil then { Empty source }
Exit;
NameLen := Length(Name);
P := Msg;
while P^ <> #0 do begin
Q := P;
while (P^ <> #0) and (P^ <> '=') do
Inc(P);
if P^ = '=' then
Inc(P);
if StrLIComp(Q, @Name[1], NameLen) = 0 then begin
while (P^ <> #0) and (P^ <> '&') do begin
Ch := P^;
if Ch = '%' then begin
Ch := chr(htoi2(P + 1));
Inc(P, 2);
end
else if Ch = '+' then
Ch := ' ';
Value := Value + Ch;
Inc(P);
end;
Result := TRUE;
break;
end;
while (P^ <> #0) and (P^ <> '&') do
Inc(P);
if P^ = '&' then
Inc(P);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -