mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-12 00:05:58 +02:00
* Initial implementation of HTTP Server component
git-svn-id: trunk@17465 -
This commit is contained in:
parent
075b26b833
commit
1cfa5058fe
3
.gitattributes
vendored
3
.gitattributes
vendored
@ -2370,6 +2370,8 @@ packages/fcl-web/examples/combined/wmlogin.pp svneol=native#text/plain
|
||||
packages/fcl-web/examples/combined/wmusers.lfm svneol=native#text/plain
|
||||
packages/fcl-web/examples/combined/wmusers.lrs svneol=native#text/plain
|
||||
packages/fcl-web/examples/combined/wmusers.pp svneol=native#text/plain
|
||||
packages/fcl-web/examples/httpserver/simplehttpserver.lpi svneol=native#text/plain
|
||||
packages/fcl-web/examples/httpserver/simplehttpserver.pas svneol=native#text/plain
|
||||
packages/fcl-web/examples/jsonrpc/demo1/README.txt svneol=native#text/plain
|
||||
packages/fcl-web/examples/jsonrpc/demo1/demo.lpi svneol=native#text/plain
|
||||
packages/fcl-web/examples/jsonrpc/demo1/demo.lpr svneol=native#text/plain
|
||||
@ -2474,6 +2476,7 @@ packages/fcl-web/src/base/fpdatasetform.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/fpfcgi.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/fphtml.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/fphttp.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
|
||||
packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain
|
||||
|
71
packages/fcl-web/examples/httpserver/simplehttpserver.lpi
Normal file
71
packages/fcl-web/examples/httpserver/simplehttpserver.lpi
Normal file
@ -0,0 +1,71 @@
|
||||
<?xml version="1.0"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="9"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<SaveOnlyProjectUnits Value="True"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="Simple HTTP server demo"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<VersionInfo>
|
||||
<StringTable ProductVersion=""/>
|
||||
</VersionInfo>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
|
||||
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<Units Count="1">
|
||||
<Unit0>
|
||||
<Filename Value="simplehttpserver.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<UnitName Value="simplehttpserver"/>
|
||||
</Unit0>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="10"/>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<CompilerMessages>
|
||||
<UseMsgFile Value="True"/>
|
||||
</CompilerMessages>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
106
packages/fcl-web/examples/httpserver/simplehttpserver.pas
Normal file
106
packages/fcl-web/examples/httpserver/simplehttpserver.pas
Normal file
@ -0,0 +1,106 @@
|
||||
program simplehttpserver;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
{$define UseCThreads}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
sysutils, Classes, fphttpserver, fpmimetypes;
|
||||
|
||||
Type
|
||||
|
||||
{ TTestHTTPServer }
|
||||
|
||||
TTestHTTPServer = Class(TFPHTTPServer)
|
||||
private
|
||||
FBaseDir : String;
|
||||
FCount : Integer;
|
||||
FMimeLoaded : Boolean;
|
||||
FMimeTypesFile: String;
|
||||
procedure SetBaseDir(const AValue: String);
|
||||
Protected
|
||||
procedure CheckMimeLoaded;
|
||||
Property MimeLoaded : Boolean Read FMimeLoaded;
|
||||
public
|
||||
procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
|
||||
Var AResponse : TFPHTTPConnectionResponse); override;
|
||||
Property BaseDir : String Read FBaseDir Write SetBaseDir;
|
||||
Property MimeTypesFile : String Read FMimeTypesFile Write FMimeTypesFile;
|
||||
end;
|
||||
|
||||
Var
|
||||
Serv : TTestHTTPServer;
|
||||
{ TTestHTTPServer }
|
||||
|
||||
procedure TTestHTTPServer.SetBaseDir(const AValue: String);
|
||||
begin
|
||||
if FBaseDir=AValue then exit;
|
||||
FBaseDir:=AValue;
|
||||
If (FBaseDir<>'') then
|
||||
FBaseDir:=IncludeTrailingPathDelimiter(FBaseDir);
|
||||
end;
|
||||
|
||||
procedure TTestHTTPServer.CheckMimeLoaded;
|
||||
begin
|
||||
If (Not MimeLoaded) and (MimeTypesFile<>'') then
|
||||
begin
|
||||
MimeTypes.LoadFromFile(MimeTypesFile);
|
||||
FMimeLoaded:=true;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestHTTPServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest;
|
||||
var AResponse: TFPHTTPConnectionResponse);
|
||||
|
||||
Var
|
||||
F : TFileStream;
|
||||
FN : String;
|
||||
|
||||
begin
|
||||
FN:=ARequest.Url;
|
||||
If (length(FN)>0) and (FN[1]='/') then
|
||||
Delete(FN,1,1);
|
||||
DoDirSeparators(FN);
|
||||
FN:=BaseDir+FN;
|
||||
if FileExists(FN) then
|
||||
begin
|
||||
F:=TFileStream.Create(FN,fmOpenRead);
|
||||
try
|
||||
CheckMimeLoaded;
|
||||
AResponse.ContentType:=MimeTypes.GetMimeType(ExtractFileExt(FN));
|
||||
Writeln('Serving file: "',Fn,'". Reported Mime type: ',AResponse.ContentType);
|
||||
AResponse.ContentLength:=F.Size;
|
||||
AResponse.ContentStream:=F;
|
||||
AResponse.SendContent;
|
||||
AResponse.ContentStream:=Nil;
|
||||
finally
|
||||
F.Free;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
AResponse.Code:=404;
|
||||
AResponse.SendContent;
|
||||
end;
|
||||
Inc(FCount);
|
||||
If FCount>=5 then
|
||||
Active:=False;
|
||||
end;
|
||||
|
||||
begin
|
||||
Serv:=TTestHTTPServer.Create(Nil);
|
||||
try
|
||||
Serv.BaseDir:=ExtractFilePath(ParamStr(0));
|
||||
{$ifdef unix}
|
||||
Serv.MimeTypesFile:='/etc/mime.types';
|
||||
{$endif}
|
||||
Serv.Threaded:=False;
|
||||
Serv.Port:=8080;
|
||||
Serv.Active:=True;
|
||||
finally
|
||||
Serv.Free;
|
||||
end;
|
||||
end.
|
||||
|
587
packages/fcl-web/src/base/fphttpserver.pp
Normal file
587
packages/fcl-web/src/base/fphttpserver.pp
Normal file
@ -0,0 +1,587 @@
|
||||
{
|
||||
$Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
|
||||
This file is part of the Free Component Library (FCL)
|
||||
Copyright (c) 2011- by the Free Pascal development team
|
||||
|
||||
Simple HTTP server component.
|
||||
|
||||
See the file COPYING.FPC, included in this distribution,
|
||||
for details about the copyright.
|
||||
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
unit fphttpserver;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, ssockets, httpdefs;
|
||||
|
||||
Const
|
||||
ReadBufLen = 4096;
|
||||
|
||||
Type
|
||||
TFPHTTPConnection = Class;
|
||||
TFPHTTPConnectionThread = Class;
|
||||
TFPCustomHttpServer = Class;
|
||||
|
||||
{ TFPHTTPConnectionRequest }
|
||||
|
||||
TFPHTTPConnectionRequest = Class(TRequest)
|
||||
private
|
||||
FConnection: TFPHTTPConnection;
|
||||
protected
|
||||
Property Connection : TFPHTTPConnection Read FConnection;
|
||||
end;
|
||||
|
||||
{ TFPHTTPConnectionResponse }
|
||||
|
||||
TFPHTTPConnectionResponse = Class(TResponse)
|
||||
private
|
||||
FConnection: TFPHTTPConnection;
|
||||
Protected
|
||||
Procedure DoSendHeaders(Headers : TStrings); override;
|
||||
Procedure DoSendContent; override;
|
||||
Property Connection : TFPHTTPConnection Read FConnection;
|
||||
end;
|
||||
|
||||
|
||||
{ TFPHTTPConnection }
|
||||
|
||||
TFPHTTPConnection = Class(TObject)
|
||||
private
|
||||
FServer: TFPCustomHTTPServer;
|
||||
FSocket: TSocketStream;
|
||||
FBuffer : Ansistring;
|
||||
procedure InterPretHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String);
|
||||
function ReadString: String;
|
||||
Protected
|
||||
procedure ReadRequestContent(ARequest: TFPHTTPConnectionRequest); virtual;
|
||||
procedure UnknownHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String); virtual;
|
||||
Function ReadRequestHeaders : TFPHTTPConnectionRequest;
|
||||
Public
|
||||
Constructor Create(AServer : TFPCustomHTTPServer; ASocket : TSocketStream);
|
||||
Destructor Destroy; override;
|
||||
Procedure HandleRequest; virtual;
|
||||
Property Socket : TSocketStream Read FSocket;
|
||||
Property Server : TFPCustomHTTPServer Read FServer;
|
||||
end;
|
||||
|
||||
{ TFPHTTPConnectionThread }
|
||||
|
||||
TFPHTTPConnectionThread = Class(TThread)
|
||||
private
|
||||
FConnection: TFPHTTPConnection;
|
||||
Public
|
||||
Constructor CreateConnection(AConnection : TFPHTTPConnection); virtual;
|
||||
Procedure Execute; override;
|
||||
Property Connection : TFPHTTPConnection Read FConnection;
|
||||
end;
|
||||
|
||||
{ TFPHttpServer }
|
||||
THTTPServerRequestHandler = Procedure (Sender: TObject;
|
||||
Var ARequest: TFPHTTPConnectionRequest;
|
||||
Var AResponse : TFPHTTPConnectionResponse) of object;
|
||||
|
||||
{ TFPCustomHttpServer }
|
||||
|
||||
TFPCustomHttpServer = Class(TComponent)
|
||||
Private
|
||||
FOnAllowConnect: TConnectQuery;
|
||||
FOnRequest: THTTPServerRequestHandler;
|
||||
FPort: Word;
|
||||
FQueueSize: Word;
|
||||
FServer : TInetServer;
|
||||
FLoadActivate : Boolean;
|
||||
FThreaded: Boolean;
|
||||
function GetActive: Boolean;
|
||||
procedure SetActive(const AValue: Boolean);
|
||||
procedure SetOnAllowConnect(const AValue: TConnectQuery);
|
||||
procedure SetPort(const AValue: Word);
|
||||
procedure SetQueueSize(const AValue: Word);
|
||||
procedure SetThreaded(const AValue: Boolean);
|
||||
Protected
|
||||
// Create a connection handling object.
|
||||
function CreateConnection(Data : TSocketStream) : TFPHTTPConnection; virtual;
|
||||
// Create a connection handling thread.
|
||||
Function CreateConnectionThread(Conn : TFPHTTPConnection) : TFPHTTPConnectionThread; virtual;
|
||||
// Check if server is inactive
|
||||
Procedure CheckInactive;
|
||||
// Called by TInetServer when a new connection is accepted.
|
||||
Procedure DoConnect(Sender : TObject; Data : TSocketStream); virtual;
|
||||
// Create and configure TInetServer
|
||||
Procedure CreateServerSocket; virtual;
|
||||
// Stop and free TInetServer
|
||||
Procedure FreeServerSocket; virtual;
|
||||
// Handle request. This calls OnRequest. It can be overridden by descendants to provide standard handling.
|
||||
procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
|
||||
Var AResponse : TFPHTTPConnectionResponse); virtual;
|
||||
public
|
||||
Constructor Create(AOwner : TComponent); override;
|
||||
Destructor Destroy; override;
|
||||
protected
|
||||
// Set to true to start listening.
|
||||
Property Active : Boolean Read GetActive Write SetActive Default false;
|
||||
// Port to listen on.
|
||||
Property Port : Word Read FPort Write SetPort Default 80;
|
||||
// Max connections on queue (for Listen call)
|
||||
Property QueueSize : Word Read FQueueSize Write SetQueueSize Default 5;
|
||||
// Called when deciding whether to accept a connection.
|
||||
Property OnAllowConnect : TConnectQuery Read FOnAllowConnect Write SetOnAllowConnect;
|
||||
// Use a thread to handle a connection ?
|
||||
property Threaded : Boolean read FThreaded Write SetThreaded;
|
||||
// Called to handle the request. If Threaded=True, it is called in a the connection thread.
|
||||
Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest;
|
||||
end;
|
||||
|
||||
TFPHttpServer = Class(TFPCustomHttpServer)
|
||||
Published
|
||||
Property Active;
|
||||
Property Port;
|
||||
Property QueueSize;
|
||||
Property OnAllowConnect;
|
||||
property Threaded;
|
||||
Property OnRequest;
|
||||
end;
|
||||
|
||||
EHTTPServer = Class(Exception);
|
||||
|
||||
implementation
|
||||
|
||||
resourcestring
|
||||
SErrSocketActive = 'Operation not allowed while server is active';
|
||||
SErrReadingSocket = 'Error reading data from the socket';
|
||||
SErrMissingProtocol = 'Missing HTTP protocol version in request';
|
||||
|
||||
{ TFPHTTPConnectionRequest }
|
||||
Function GetStatusCode (ACode: Integer) : String;
|
||||
|
||||
begin
|
||||
Case ACode of
|
||||
100 : Result:='Continue';
|
||||
101 : Result:='Switching Protocols';
|
||||
200 : Result:='OK';
|
||||
201 : Result:='Created';
|
||||
202 : Result:='Accepted';
|
||||
203 : Result:='Non-Authoritative Information';
|
||||
204 : Result:='No Content';
|
||||
205 : Result:='Reset Content';
|
||||
206 : Result:='Partial Content';
|
||||
300 : Result:='Multiple Choices';
|
||||
301 : Result:='Moved Permanently';
|
||||
302 : Result:='Found';
|
||||
303 : Result:='See Other';
|
||||
304 : Result:='Not Modified';
|
||||
305 : Result:='Use Proxy';
|
||||
307 : Result:='Temporary Redirect';
|
||||
400 : Result:='Bad Request';
|
||||
401 : Result:='Unauthorized';
|
||||
402 : Result:='Payment Required';
|
||||
403 : Result:='Forbidden';
|
||||
404 : Result:='Not Found';
|
||||
405 : Result:='Method Not Allowed';
|
||||
406 : Result:='Not Acceptable';
|
||||
407 : Result:='Proxy Authentication Required';
|
||||
408 : Result:='Request Time-out';
|
||||
409 : Result:='Conflict';
|
||||
410 : Result:='Gone';
|
||||
411 : Result:='Length Required';
|
||||
412 : Result:='Precondition Failed';
|
||||
413 : Result:='Request Entity Too Large';
|
||||
414 : Result:='Request-URI Too Large';
|
||||
415 : Result:='Unsupported Media Type';
|
||||
416 : Result:='Requested range not satisfiable';
|
||||
417 : Result:='Expectation Failed';
|
||||
500 : Result:='Internal Server Error';
|
||||
501 : Result:='Not Implemented';
|
||||
502 : Result:='Bad Gateway';
|
||||
503 : Result:='Service Unavailable';
|
||||
504 : Result:='Gateway Time-out';
|
||||
505 : Result:='HTTP Version not supported';
|
||||
else
|
||||
Result:='Unknown status';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPHTTPConnectionResponse.DoSendHeaders(Headers: TStrings);
|
||||
|
||||
Var
|
||||
S : String;
|
||||
I : Integer;
|
||||
begin
|
||||
S:=Format('HTTP/1.1 %3d %s'#13#10,[Code,GetStatusCode(Code)]);
|
||||
For I:=0 to Headers.Count-1 do
|
||||
S:=S+Headers[i]+#13#10;
|
||||
// Last line in headers is empty.
|
||||
Connection.Socket.WriteBuffer(S[1],Length(S));
|
||||
end;
|
||||
|
||||
procedure TFPHTTPConnectionResponse.DoSendContent;
|
||||
begin
|
||||
If Assigned(ContentStream) then
|
||||
Connection.Socket.CopyFrom(ContentStream,0)
|
||||
else
|
||||
Contents.SaveToStream(Connection.Socket);
|
||||
end;
|
||||
|
||||
{ TFPHTTPConnection }
|
||||
|
||||
function TFPHTTPConnection.ReadString : String;
|
||||
|
||||
Procedure FillBuffer;
|
||||
|
||||
Var
|
||||
R : Integer;
|
||||
|
||||
begin
|
||||
SetLength(FBuffer,ReadBufLen);
|
||||
r:=FSocket.Read(FBuffer[1],ReadBufLen);
|
||||
If r<0 then
|
||||
Raise EHTTPServer.Create(SErrReadingSocket);
|
||||
if (r<ReadBuflen) then
|
||||
SetLength(FBuffer,r);
|
||||
end;
|
||||
|
||||
Var
|
||||
CheckLF,Done : Boolean;
|
||||
P,L : integer;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
Done:=False;
|
||||
CheckLF:=False;
|
||||
Repeat
|
||||
if Length(FBuffer)=0 then
|
||||
FillBuffer;
|
||||
if Length(FBuffer)=0 then
|
||||
Done:=True
|
||||
else if CheckLF then
|
||||
begin
|
||||
If (FBuffer[1]<>#10) then
|
||||
Result:=Result+#13
|
||||
else
|
||||
begin
|
||||
Delete(FBuffer,1,1);
|
||||
Done:=True;
|
||||
end;
|
||||
end;
|
||||
if not Done then
|
||||
begin
|
||||
P:=Pos(#13#10,FBuffer);
|
||||
If P=0 then
|
||||
begin
|
||||
L:=Length(FBuffer);
|
||||
CheckLF:=FBuffer[L]=#13;
|
||||
if CheckLF then
|
||||
Result:=Result+Copy(FBuffer,1,L-1)
|
||||
else
|
||||
Result:=Result+FBuffer;
|
||||
FBuffer:='';
|
||||
end
|
||||
else
|
||||
begin
|
||||
Result:=Result+Copy(FBuffer,1,P-1);
|
||||
Delete(FBuffer,1,P+1);
|
||||
Done:=True;
|
||||
end;
|
||||
end;
|
||||
until Done;
|
||||
end;
|
||||
|
||||
procedure TFPHTTPConnection.UnknownHeader(ARequest: TFPHTTPConnectionRequest;
|
||||
const AHeader: String);
|
||||
begin
|
||||
// Do nothing
|
||||
end;
|
||||
|
||||
Procedure TFPHTTPConnection.InterPretHeader(ARequest : TFPHTTPConnectionRequest; Const AHeader : String);
|
||||
|
||||
Var
|
||||
P : Integer;
|
||||
N,V : String;
|
||||
|
||||
begin
|
||||
V:=AHeader;
|
||||
P:=Pos(':',V);
|
||||
if (P=0) then
|
||||
begin
|
||||
UnknownHeader(ARequest,Aheader);
|
||||
Exit;
|
||||
end;
|
||||
N:=Copy(V,1,P-1);
|
||||
Delete(V,1,P+1);
|
||||
V:=Trim(V);
|
||||
ARequest.SetFieldByName(N,V);
|
||||
end;
|
||||
|
||||
procedure ParseStartLine(Request : TFPHTTPConnectionRequest; AStartLine : String);
|
||||
|
||||
Function GetNextWord(Var S : String) : string;
|
||||
|
||||
Var
|
||||
P : Integer;
|
||||
|
||||
begin
|
||||
P:=Pos(' ',S);
|
||||
If (P=0) then
|
||||
P:=Length(S)+1;
|
||||
Result:=Copy(S,1,P-1);
|
||||
Delete(S,1,P);
|
||||
end;
|
||||
|
||||
Var
|
||||
S : String;
|
||||
|
||||
begin
|
||||
Request.Method:=GetNextWord(AStartLine);
|
||||
Request.URL:=GetNextWord(AStartLine);
|
||||
S:=GetNextWord(AStartLine);
|
||||
If (Pos('HTTP/',S)<>1) then
|
||||
Raise Exception.Create(SErrMissingProtocol);
|
||||
Delete(S,1,5);
|
||||
Request.ProtocolVersion:=trim(S);
|
||||
end;
|
||||
|
||||
Procedure TFPHTTPConnection.ReadRequestContent(ARequest : TFPHTTPConnectionRequest);
|
||||
|
||||
Var
|
||||
P,L,R : integer;
|
||||
S : String;
|
||||
|
||||
begin
|
||||
L:=ARequest.ContentLength;
|
||||
If (L>0) then
|
||||
begin
|
||||
SetLength(S,L);
|
||||
P:=Length(FBuffer);
|
||||
if (P>0) then
|
||||
Move(FBuffer[1],S,P);
|
||||
P:=P+1;
|
||||
Repeat
|
||||
R:=FSocket.Read(S[p],L);
|
||||
If R<0 then
|
||||
Raise EHTTPServer.Create(SErrReadingSocket);
|
||||
if (R>0) then
|
||||
begin
|
||||
P:=P+R;
|
||||
L:=L-R;
|
||||
end;
|
||||
until (L=0) or (R=0);
|
||||
end;
|
||||
ARequest.Content:=S;
|
||||
end;
|
||||
|
||||
function TFPHTTPConnection.ReadRequestHeaders: TFPHTTPConnectionRequest;
|
||||
|
||||
Var
|
||||
StartLine,S : String;
|
||||
begin
|
||||
Result:=TFPHTTPConnectionRequest.Create;
|
||||
Result.FConnection:=Self;
|
||||
StartLine:=ReadString;
|
||||
ParseStartLine(Result,StartLine);
|
||||
Repeat
|
||||
S:=ReadString;
|
||||
if (S<>'') then
|
||||
InterPretHeader(Result,S);
|
||||
Until (S='');
|
||||
end;
|
||||
|
||||
constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSocketStream
|
||||
);
|
||||
begin
|
||||
FSocket:=ASocket;
|
||||
FServer:=AServer;
|
||||
end;
|
||||
|
||||
destructor TFPHTTPConnection.Destroy;
|
||||
begin
|
||||
FreeAndNil(FSocket);
|
||||
Inherited;
|
||||
end;
|
||||
|
||||
procedure TFPHTTPConnection.HandleRequest;
|
||||
|
||||
Var
|
||||
Req : TFPHTTPConnectionRequest;
|
||||
Resp : TFPHTTPConnectionResponse;
|
||||
|
||||
begin
|
||||
// Read headers.
|
||||
Req:=ReadRequestHeaders;
|
||||
try
|
||||
// Read content, if any
|
||||
If Req.ContentLength>0 then
|
||||
ReadRequestContent(Req);
|
||||
// Create Response
|
||||
Resp:= TFPHTTPConnectionResponse.Create(Req);
|
||||
try
|
||||
Resp.FConnection:=Self;
|
||||
// And dispatch
|
||||
if Server.Active then
|
||||
Server.HandleRequest(Req,Resp);
|
||||
if Assigned(Resp) and (not Resp.ContentSent) then
|
||||
Resp.SendContent;
|
||||
finally
|
||||
FreeAndNil(Resp);
|
||||
end;
|
||||
Finally
|
||||
FreeAndNil(Req);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TFPHTTPConnectionThread }
|
||||
|
||||
constructor TFPHTTPConnectionThread.CreateConnection(AConnection: TFPHTTPConnection
|
||||
);
|
||||
begin
|
||||
FConnection:=AConnection;
|
||||
FreeOnTerminate:=True;
|
||||
Inherited Create(False);
|
||||
end;
|
||||
|
||||
procedure TFPHTTPConnectionThread.Execute;
|
||||
begin
|
||||
try
|
||||
try
|
||||
FConnection.HandleRequest;
|
||||
finally
|
||||
FreeAndNil(FConnection);
|
||||
end;
|
||||
except
|
||||
// Silently ignore errors.
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TFPCustomHttpServer }
|
||||
|
||||
function TFPCustomHttpServer.GetActive: Boolean;
|
||||
begin
|
||||
if (csDesigning in ComponentState) then
|
||||
Result:=FLoadActivate
|
||||
else
|
||||
Result:=Assigned(FServer);
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.SetActive(const AValue: Boolean);
|
||||
begin
|
||||
If AValue=GetActive then exit;
|
||||
FLoadActivate:=AValue;
|
||||
if not (csDesigning in Componentstate) then
|
||||
if AValue then
|
||||
CreateServerSocket
|
||||
else
|
||||
FreeServerSocket;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery);
|
||||
begin
|
||||
if FOnAllowConnect=AValue then exit;
|
||||
CheckInactive;
|
||||
FOnAllowConnect:=AValue;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.SetPort(const AValue: Word);
|
||||
begin
|
||||
if FPort=AValue then exit;
|
||||
CheckInactive;
|
||||
FPort:=AValue;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.SetQueueSize(const AValue: Word);
|
||||
begin
|
||||
if FQueueSize=AValue then exit;
|
||||
CheckInactive;
|
||||
FQueueSize:=AValue;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.SetThreaded(const AValue: Boolean);
|
||||
begin
|
||||
if FThreaded=AValue then exit;
|
||||
CheckInactive;
|
||||
FThreaded:=AValue;
|
||||
end;
|
||||
|
||||
function TFPCustomHttpServer.CreateConnection(Data: TSocketStream): TFPHTTPConnection;
|
||||
begin
|
||||
Result:=TFPHTTPConnection.Create(Self,Data);
|
||||
end;
|
||||
|
||||
function TFPCustomHttpServer.CreateConnectionThread(Conn: TFPHTTPConnection
|
||||
): TFPHTTPConnectionThread;
|
||||
begin
|
||||
Result:=TFPHTTPConnectionThread.CreateConnection(Conn);
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.CheckInactive;
|
||||
begin
|
||||
If GetActive then
|
||||
Raise EHTTPServer.Create(SErrSocketActive);
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.DoConnect(Sender: TObject; Data: TSocketStream);
|
||||
|
||||
Var
|
||||
Con : TFPHTTPConnection;
|
||||
|
||||
begin
|
||||
Con:=CreateConnection(Data);
|
||||
try
|
||||
Con.FServer:=Self;
|
||||
if Threaded then
|
||||
CreateConnectionThread(Con)
|
||||
else
|
||||
begin
|
||||
Con.HandleRequest;
|
||||
end;
|
||||
finally
|
||||
if not Threaded then
|
||||
Con.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.CreateServerSocket;
|
||||
begin
|
||||
FServer:=TInetServer.Create(FPort);
|
||||
FServer.MaxConnections:=-1;
|
||||
FServer.OnConnectQuery:=OnAllowConnect;
|
||||
FServer.OnConnect:=@DOConnect;
|
||||
FServer.QueueSize:=Self.QueueSize;
|
||||
FServer.Bind;
|
||||
FServer.Listen;
|
||||
FServer.StartAccepting;
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.FreeServerSocket;
|
||||
begin
|
||||
FServer.StopAccepting;
|
||||
FreeAndNil(FServer);
|
||||
end;
|
||||
|
||||
procedure TFPCustomHttpServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest;
|
||||
var AResponse: TFPHTTPConnectionResponse);
|
||||
begin
|
||||
If Assigned(FOnRequest) then
|
||||
FonRequest(Self,ARequest,AResponse);
|
||||
end;
|
||||
|
||||
constructor TFPCustomHttpServer.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FPort:=80;
|
||||
FQueueSize:=5;
|
||||
end;
|
||||
|
||||
destructor TFPCustomHttpServer.Destroy;
|
||||
begin
|
||||
Active:=False;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
@ -127,7 +127,7 @@ Type
|
||||
Property AfterResponse : TResponseEvent Read FAfterResponse Write FAfterResponse;
|
||||
Property OnGetAction : TGetActionEvent Read GetOnGetAction Write SetOnGetAction;
|
||||
Property DefActionWhenUnknown : Boolean read GetDefActionWhenUnknown write SetDefActionWhenUnknown default true;
|
||||
Property Template : TFPTemplate Read FTemplate Write SetTemplate;
|
||||
Property ModuleTemplate : TFPTemplate Read FTemplate Write SetTemplate;
|
||||
Property OnGetParam : TGetParamEvent Read FOnGetParam Write FOnGetParam;
|
||||
Property OnTemplateContent : TGetParamEvent Read FOnGetParam Write FOnGetParam;
|
||||
Property Request: TRequest Read FRequest;
|
||||
|
@ -175,6 +175,7 @@ type
|
||||
FHTTPXRequestedWith: String;
|
||||
FFields : THttpFields;
|
||||
FQueryFields: TStrings;
|
||||
FURL : String;
|
||||
function GetSetField(AIndex: Integer): String;
|
||||
function GetSetFieldName(AIndex: Integer): String;
|
||||
procedure SetCookieFields(const AValue: TStrings);
|
||||
@ -624,6 +625,7 @@ begin
|
||||
else
|
||||
case Index of
|
||||
0 : Result:=FHTTPVersion;
|
||||
32 : Result:=FURL;
|
||||
36 : Result:=FHTTPXRequestedWith;
|
||||
else
|
||||
Result := '';
|
||||
@ -654,6 +656,7 @@ begin
|
||||
28 : ; // Property RemoteHost : String Index 28 read GetFieldValue Write SetFieldValue;
|
||||
29 : ; // Property ScriptName : String Index 29 read GetFieldValue Write SetFieldValue;
|
||||
30 : ; // Property ServerPort : Word Read GetServerPort; // Index 30
|
||||
32 : FURL:=Value;
|
||||
36 : FHTTPXRequestedWith:=Value;
|
||||
end;
|
||||
end;
|
||||
|
Loading…
Reference in New Issue
Block a user