paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-06 19:38:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Adaptions to new version of HTTP unit: All server functionality now is

Browse Source 
in this unit, and not http.pp anymore
This commit is contained in:
sg 2003-11-22 12:01:18 +00:00
parent 838f4bb927
commit 830f7f5f0b
1 changed files with 128 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

241
fcl/net/httpsvlt.pp
View File

@ -17,7 +17,7 @@ unit HTTPSvlt;
interface interface
uses SysUtils, Classes, SSockets, fpAsync, HTTP, Servlets; uses SysUtils, Classes, fpAsync, fpSock, HTTP, Servlets;
resourcestring resourcestring
SErrUnknownMethod = 'Unknown HTTP method "%s" used'; SErrUnknownMethod = 'Unknown HTTP method "%s" used';
@ -78,12 +78,12 @@ type
THttpServletResponse = class(TServletResponse) THttpServletResponse = class(TServletResponse)
private private
ResponseHeader: THTTPAnswerHeader; ResponseHeader: THTTPResponseHeader;
protected protected
procedure SetContentType(const Value: String); override; procedure SetContentType(const Value: String); override;
procedure SetContentLength(Value: Int64); override; procedure SetContentLength(Value: Int64); override;
public public
constructor Create(AResponseHeader: THTTPAnswerHeader; constructor Create(AResponseHeader: THTTPResponseHeader;
AOutputStream: TStream); AOutputStream: TStream);
// procedure AddCookie(Cookie: TCookie); // !!!: Implement this // procedure AddCookie(Cookie: TCookie); // !!!: Implement this
// procedure AddDateHeader(const AName: String; ADate: TDateTime); // !!!: Implement this // procedure AddDateHeader(const AName: String; ADate: TDateTime); // !!!: Implement this
@ -158,27 +158,22 @@ type
default; default;
end; end;
THttpServer = class(TComponent) THttpServer = class(TCustomTCPServer)
private private
FEventLoop: TEventLoop; Connections: TList; // List of THttpServerConnection objects
FInetServer: TInetServer;
FPort: Word;
DataAvailableNotifyHandle: Pointer;
Connections: TList; // List of TXMLRPCServerConnection objects
FServletMappings: TServletMappings; FServletMappings: TServletMappings;
procedure InetServerDataAvailable(Sender: TObject); protected
procedure InetServerConnect(Sender: TObject; Data: TSocketStream); procedure DoConnect(AStream: TSocketStream); override;
procedure ConnectionClose(Sender: TObject);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
procedure Start(AEventLoop: TEventLoop);
procedure AddServlet(AServlet: THttpServlet; const AURLPattern: String); procedure AddServlet(AServlet: THttpServlet; const AURLPattern: String);
// procedure RemoveServlet(const APathName: String); // procedure RemoveServlet(const APathName: String);
property EventLoop: TEventLoop read FEventLoop;
property InetServer: TInetServer read FInetServer;
published published
property Port: Word read FPort write FPort; property Active;
property Port;
property OnQueryConnect;
property OnConnect;
property ServletMappings: TServletMappings property ServletMappings: TServletMappings
read FServletMappings write FServletMappings; read FServletMappings write FServletMappings;
end; end;
@ -232,7 +227,7 @@ begin
end; end;
constructor THttpServletResponse.Create(AResponseHeader: THTTPAnswerHeader; constructor THttpServletResponse.Create(AResponseHeader: THTTPResponseHeader;
AOutputStream: TStream); AOutputStream: TStream);
begin begin
inherited Create(AOutputStream); inherited Create(AOutputStream);
@ -326,73 +321,115 @@ end;
type type
THttpServerConnection = class THttpServerConnection = class
private private
FOnClose: TNotifyEvent;
Server: THttpServer; Server: THttpServer;
Stream: TInetSocket; Stream: TSocketStream;
HTTPConnection: THTTPConnection; RequestHeader: THttpRequestHeader;
RequestHeader: THTTPRequestHeader;
RequestStream: TMemoryStream; RequestStream: TMemoryStream;
ResponseHeader: THTTPAnswerHeader; ResponseHeader: THttpResponseHeader;
ResponseStream: TMemoryStream; ResponseStream: TMemoryStream;
BytesToRead, BytesToWrite: Integer;
DataAvailableNotifyHandle: Pointer;
CanSendNotifyHandle: Pointer;
SendBuffer: Pointer;
procedure RequestHeaderReceived(Sender: TObject); procedure RequestHeaderReceived(Sender: TObject);
procedure RequestStreamReceived(Sender: TObject); procedure DataAvailable(Sender: TObject);
procedure ResponseStreamSent(Sender: TObject); procedure RequestStreamReceived;
procedure ConnectionDestroyed(Sender: TObject); procedure ResponseHeaderSent(Sender: TObject);
procedure CanSend(Sender: TObject);
public public
constructor Create(AServer: THttpServer; AStream: TInetSocket); constructor Create(AServer: THttpServer; AStream: TSocketStream);
destructor Destroy; override; destructor Destroy; override;
property OnClose: TNotifyEvent read FOnClose write FOnClose;
end; end;
constructor THttpServerConnection.Create(AServer: THttpServer; constructor THttpServerConnection.Create(AServer: THttpServer;
AStream: TInetSocket); AStream: TSocketStream);
begin begin
inherited Create; inherited Create;
Server := AServer; Server := AServer;
Stream := AStream; Stream := AStream;
RequestHeader := THTTPRequestHeader.Create; RequestHeader := THttpRequestHeader.Create;
RequestStream := TMemoryStream.Create; RequestHeader.OnCompleted := @RequestHeaderReceived;
HTTPConnection := THTTPConnection.Create(Server.EventLoop, Stream); RequestHeader.AsyncReceive(Server.EventLoop, Stream);
HTTPConnection.ReceivedHeader := RequestHeader;
HTTPConnection.ReceivedStream := RequestStream;
HTTPConnection.OnHeaderReceived := @RequestHeaderReceived;
HTTPConnection.OnStreamReceived := @RequestStreamReceived;
HTTPConnection.OnDestroy := @ConnectionDestroyed;
HTTPConnection.Receive;
end; end;
destructor THttpServerConnection.Destroy; destructor THttpServerConnection.Destroy;
begin begin
if Assigned(DataAvailableNotifyHandle) then
Server.EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
if Assigned(CanSendNotifyHandle) then
Server.EventLoop.ClearCanWriteNotify(CanSendNotifyHandle);
RequestHeader.Free; RequestHeader.Free;
RequestStream.Free; RequestStream.Free;
ResponseHeader.Free; ResponseHeader.Free;
ResponseStream.Free; ResponseStream.Free;
if Assigned(OnClose) then
OnClose(Self);
Stream.Free; Stream.Free;
if Assigned(HTTPConnection) then Server.Connections.Remove(Self);
begin
HTTPConnection.OnDestroy := nil;
HTTPConnection.Free;
end;
inherited Destroy; inherited Destroy;
end; end;
procedure THttpServerConnection.RequestHeaderReceived(Sender: TObject); procedure THttpServerConnection.RequestHeaderReceived(Sender: TObject);
var
BytesInBuffer: Integer;
NeedMoreData: Boolean;
begin begin
// WriteLn('Header received: Method=', RequestHeader.Command, ', URI=', RequestHeader.URI); // WriteLn('HTTP-Header empfangen');
if RequestHeader.Command = 'GET' then
RequestStreamReceived(nil); BytesInBuffer:= RequestHeader.Reader.BytesInBuffer;
BytesToRead := RequestHeader.ContentLength;
// WriteLn('Content-Length: ', BytesToRead, ', noch im Puffer: ', BytesInBuffer);
RequestStream := TMemoryStream.Create;
NeedMoreData := RequestHeader.Command = 'POST';
if BytesInBuffer > 0 then
begin
RequestStream.Write(RequestHeader.Reader.Buffer^, BytesInBuffer);
if BytesToRead > 0 then
Dec(BytesToRead, BytesInBuffer);
if BytesInBuffer = RequestHeader.ContentLength then
NeedMoreData := False;
end;
if NeedMoreData then
DataAvailableNotifyHandle := Server.EventLoop.SetDataAvailableNotify(
Stream.Handle, @DataAvailable, nil)
else
RequestStreamReceived;
end; end;
procedure THttpServerConnection.RequestStreamReceived(Sender: TObject); procedure THttpServerConnection.DataAvailable(Sender: TObject);
var
Buffer: array[0..4095] of Byte;
ReadNow, BytesRead: Integer;
begin
ReadNow := SizeOf(Buffer);
if (BytesToRead > 0) and (ReadNow > BytesToRead) then
ReadNow := BytesToRead;
BytesRead := Stream.Read(Buffer, ReadNow);
// WriteLn('Sollte ', ReadNow, ' Bytes lesen, ', BytesRead, ' wurden gelesen');
RequestStream.Write(Buffer, BytesRead);
if BytesToRead > 0 then
begin
Dec(BytesToRead, BytesRead);
if BytesToRead = 0 then
begin
Server.EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle);
DataAvailableNotifyHandle := nil;
RequestStreamReceived;
end;
end;
end;
procedure THttpServerConnection.RequestStreamReceived;
var var
i: Integer; i: Integer;
Servlet: TGenericServlet;
s, URI: String; s, URI: String;
Servlet: TGenericServlet;
Request: THttpServletRequest; Request: THttpServletRequest;
Response: THttpServletResponse; Response: THttpServletResponse;
begin begin
@ -420,12 +457,10 @@ begin
s := Copy(s, 1, Length(s) - 1); s := Copy(s, 1, Length(s) - 1);
Request := THttpServletRequest.Create(RequestHeader, RequestStream, 'http', Request := THttpServletRequest.Create(RequestHeader, RequestStream, 'http',
Copy(RequestHeader.URI, Length(s) + 1, Length(RequestHeader.URI))); Copy(RequestHeader.URI, Length(s) + 1, Length(RequestHeader.URI)));
ResponseHeader := THTTPResponseHeader.Create;
ResponseHeader := THTTPAnswerHeader.Create; ResponseHeader.Connection := 'Keep-Alive';
ResponseStream := TMemoryStream.Create; ResponseStream := TMemoryStream.Create;
Response := THttpServletResponse.Create(ResponseHeader, ResponseStream); Response := THttpServletResponse.Create(ResponseHeader, ResponseStream);
HTTPConnection.HeaderToSend := ResponseHeader;
HTTPConnection.OnStreamSent := @ResponseStreamSent;
try try
try try
@ -449,35 +484,39 @@ begin
end; end;
end; end;
HTTPConnection.StreamToSend := ResponseStream; BytesToWrite := ResponseStream.Size;
ResponseHeader.ContentLength := ResponseStream.Size; SendBuffer := ResponseStream.Memory;
ResponseStream.Position := 0; ResponseStream.Position := 0;
ResponseHeader.ContentLength := BytesToWrite;
HTTPConnection.Send; ResponseHeader.OnCompleted := @ResponseHeaderSent;
ResponseHeader.AsyncSend(Server.EventLoop, Stream);
finally finally
Response.Free; Response.Free;
Request.Free; Request.Free;
FreeAndNil(RequestHeader);
HTTPConnection.OnHeaderReceived := nil;
FreeAndNil(RequestStream);
HTTPConnection.OnStreamReceived := nil;
end; end;
// WriteLn('Antwort wurde generiert');
end; end;
procedure THttpServerConnection.ResponseStreamSent(Sender: TObject); procedure THttpServerConnection.ResponseHeaderSent(Sender: TObject);
begin begin
// WriteLn('Response stream sent'); // WriteLn('Antwortheader geschickt');
FreeAndNil(Stream); if BytesToWrite > 0 then
HTTPConnection.DoDestroy := True; CanSendNotifyHandle := Server.EventLoop.SetCanWriteNotify(Stream.Handle,
@CanSend, nil);
end; end;
procedure THttpServerConnection.ConnectionDestroyed(Sender: TObject); procedure THttpServerConnection.CanSend(Sender: TObject);
var
BytesWritten: Integer;
begin begin
// WriteLn('Connection closed'); BytesWritten := Stream.Write(SendBuffer^, BytesToWrite);
HTTPConnection := nil; Dec(BytesToWrite, BytesWritten);
Free; Inc(SendBuffer, BytesWritten);
if BytesToWrite = 0 then
begin
// WriteLn('Antwortdaten geschickt');
Free;
end;
end; end;
@ -492,32 +531,15 @@ var
i: Integer; i: Integer;
begin begin
ServletMappings.Free; ServletMappings.Free;
for i := 0 to Connections.Count - 1 do if Assigned(Connections) then
THttpServerConnection(Connections[i]).Free; begin
Connections.Free; for i := 0 to Connections.Count - 1 do
if Assigned(DataAvailableNotifyHandle) and Assigned(EventLoop) then THttpServerConnection(Connections[i]).Free;
EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle); Connections.Free;
InetServer.Free; end;
inherited Destroy; inherited Destroy;
end; end;
procedure THttpServer.Start(AEventLoop: TEventLoop);
var
i: Integer;
begin
WriteLn(ServletMappings.Count, ' servlet mappings:');
for i := 0 to ServletMappings.Count - 1 do
WriteLn(ServletMappings[i].URLPattern, ' -> ', ServletMappings[i].Servlet.Name);
FEventLoop := AEventLoop;
FInetServer := TInetServer.Create(Port);
Connections := TList.Create;
DataAvailableNotifyHandle := EventLoop.SetDataAvailableNotify(
InetServer.Socket, @InetServerDataAvailable, nil);
InetServer.OnConnect := @InetServerConnect;
InetServer.SetNonBlocking;
InetServer.Listen;
end;
procedure THttpServer.AddServlet(AServlet: THttpServlet; procedure THttpServer.AddServlet(AServlet: THttpServlet;
const AURLPattern: String); const AURLPattern: String);
var var
@ -541,25 +563,14 @@ begin
end; end;
end;} end;}
procedure THttpServer.InetServerDataAvailable(Sender: TObject); procedure THttpServer.DoConnect(AStream: TSocketStream);
begin begin
InetServer.StartAccepting; // WriteLn('Incoming HTTP connection');
if not Assigned(Connections) then
Connections := TList.Create;
Connections.Add(THttpServerConnection.Create(Self, AStream));
end; end;
procedure THttpServer.InetServerConnect(Sender: TObject; Data: TSocketStream);
var
Connection: THttpServerConnection;
begin
// WriteLn('Incoming connection');
Connection := THttpServerConnection.Create(Self, Data as TInetSocket);
Connection.OnClose := @ConnectionClose;
Connections.Add(Connection);
end;
procedure THttpServer.ConnectionClose(Sender: TObject);
begin
Connections.Remove(Sender);
end;
@ -622,7 +633,11 @@ end.
{ {
$Log$ $Log$
Revision 1.2 2003-06-25 08:53:51 sg Revision 1.3 2003-11-22 12:01:18 sg
* Adaptions to new version of HTTP unit: All server functionality now is
in this unit, and not http.pp anymore
Revision 1.2 2003/06/25 08:53:51 sg
* Inform the server socket object that it runs non-blocking * Inform the server socket object that it runs non-blocking
Revision 1.1 2002/04/25 19:30:29 sg Revision 1.1 2002/04/25 19:30:29 sg