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

* Initial implementation of FastCgi support

Browse Source 
git-svn-id: trunk@12970 -
This commit is contained in:
joost 2009-03-27 22:33:27 +00:00
parent b4a8ae3637
commit 9938d57233
4 changed files with 742 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -1635,7 +1635,10 @@ packages/fcl-web/fptemplate.txt svneol=native#text/plain
packages/fcl-web/src/README.txt svneol=native#text/plain packages/fcl-web/src/README.txt svneol=native#text/plain
packages/fcl-web/src/cgiapp.pp svneol=native#text/plain packages/fcl-web/src/cgiapp.pp svneol=native#text/plain
packages/fcl-web/src/custcgi.pp svneol=native#text/plain packages/fcl-web/src/custcgi.pp svneol=native#text/plain
packages/fcl-web/src/custfcgi.pp svneol=native#text/plain
packages/fcl-web/src/custweb.pp svneol=native#text/plain
packages/fcl-web/src/ezcgi.pp svneol=native#text/plain packages/fcl-web/src/ezcgi.pp svneol=native#text/plain
packages/fcl-web/src/fastcgi.pp svneol=native#text/plain
packages/fcl-web/src/fpapache.pp svneol=native#text/plain packages/fcl-web/src/fpapache.pp svneol=native#text/plain
packages/fcl-web/src/fpcgi.pp svneol=native#text/plain packages/fcl-web/src/fpcgi.pp svneol=native#text/plain
packages/fcl-web/src/fpdatasetform.pp svneol=native#text/plain packages/fcl-web/src/fpdatasetform.pp svneol=native#text/plain

438
packages/fcl-web/src/custfcgi.pp Normal file
View File

@ -0,0 +1,438 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2009 by the Free Pascal development team
TFCgiApplication class.
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.
**********************************************************************}
{ $define CGIDEBUG}
{$mode objfpc}
{$H+}
unit custfcgi;
Interface
uses
Classes,SysUtils, httpdefs,custweb, custcgi, fastcgi;
Type
{ TFCGIRequest }
TCustomFCgiApplication = Class;
TFCGIRequest = Class(TCGIRequest)
Private
FHandle: THandle;
FKeepConnectionAfterRequest: boolean;
FRequestID : Word;
FCGIParams : TSTrings;
procedure GetNameValuePairsFromContentRecord(const ARecord : PFCGI_ContentRecord; NameValueList : TStrings);
Protected
Function GetFieldValue(Index : Integer) : String; override;
procedure ReadContent; override;
Public
destructor Destroy; override;
function ProcessFCGIRecord(AFCGIRecord : PFCGI_Header) : boolean; virtual;
property RequestID : word read FRequestID write FRequestID;
property Handle : THandle read FHandle write FHandle;
property KeepConnectionAfterRequest : boolean read FKeepConnectionAfterRequest;
end;
{ TFCGIResponse }
TFCGIResponse = Class(TCGIResponse)
private
procedure Write_FCGIRecord(ARecord : PFCGI_Header);
Protected
Procedure DoSendHeaders(Headers : TStrings); override;
Procedure DoSendContent; override;
end;
TReqResp = record
Request : TFCgiRequest;
Response : TFCgiResponse;
end;
{ TCustomFCgiApplication }
TCustomFCgiApplication = Class(TCustomWebApplication)
Private
FRequestsArray : Array of TReqResp;
FRequestsAvail : integer;
FHandle : THandle;
function Read_FCGIRecord : PFCGI_Header;
protected
function WaitForRequest(var ARequest : TRequest; var AResponse : TResponse) : boolean; override;
procedure EndRequest(ARequest : TRequest;AResponse : TResponse); override;
Public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
ResourceString
SNoInputHandle = 'Failed to open input-handle passed from server. Socket Error: %d';
Implementation
uses
{$ifdef CGIDEBUG}
dbugintf,
{$endif}
BaseUnix, Sockets;
{ TFCGIHTTPRequest }
procedure TFCGIRequest.ReadContent;
begin
// Nothing has to be done. This should never be called
end;
destructor TFCGIRequest.Destroy;
begin
FCGIParams.Free;
inherited Destroy;
end;
function TFCGIRequest.ProcessFCGIRecord(AFCGIRecord: PFCGI_Header): boolean;
var cl,rcl : Integer;
begin
Result := False;
case AFCGIRecord^.reqtype of
FCGI_BEGIN_REQUEST : FKeepConnectionAfterRequest := (PFCGI_BeginRequestRecord(AFCGIRecord)^.body.flags and FCGI_KEEP_CONN) = FCGI_KEEP_CONN;
FCGI_PARAMS : begin
if AFCGIRecord^.contentLength=0 then
Result := False
else
begin
if not assigned(FCGIParams) then
FCGIParams := TStringList.Create;
GetNameValuePairsFromContentRecord(PFCGI_ContentRecord(AFCGIRecord),FCGIParams);
end;
end;
FCGI_STDIN : begin
if AFCGIRecord^.contentLength=0 then
begin
Result := True;
InitRequestVars;
end
else
begin
cl := length(FContent);
rcl := BetoN(PFCGI_ContentRecord(AFCGIRecord)^.header.contentLength);
SetLength(FContent, rcl+cl);
move(PFCGI_ContentRecord(AFCGIRecord)^.ContentData[0],FContent[cl+1],rcl);
FContentRead:=True;
end;
end;
end;
end;
procedure TFCGIRequest.GetNameValuePairsFromContentRecord(const ARecord: PFCGI_ContentRecord; NameValueList: TStrings);
var
i : integer;
function GetVarLength : Integer;
begin
if (ARecord^.ContentData[i] and 128) = 0 then
Result:=ARecord^.ContentData[i]
else
begin
Result:=BEtoN(PWord(@(ARecord^.ContentData[i]))^);
// ((ARecord^.ContentData[i] and $7f) shl 24) + (ARecord^.ContentData[i+1] shl 16)
// + (ARecord^.ContentData[i+2] shl 8) + (ARecord^.ContentData[i+3]);
inc(i,3);
end;
inc(i);
end;
function GetString(ALength : integer) : string;
begin
SetLength(Result,ALength);
move(ARecord^.ContentData[i],Result[1],ALength);
inc(i,ALength);
end;
var
NameLength, ValueLength : Integer;
RecordLength : Integer;
Name,Value : String;
begin
i := 0;
RecordLength:=BetoN(ARecord^.Header.contentLength);
while i < RecordLength do
begin
NameLength:=GetVarLength;
ValueLength:=GetVarLength;
Name:=GetString(NameLength);
Value:=GetString(ValueLength);
NameValueList.Add(Name+'='+Value);
end;
end;
Function TFCGIRequest.GetFieldValue(Index : Integer) : String;
Type THttpToCGI = array[1..CGIVarCount] of byte;
const HttpToCGI : THttpToCGI =
(
18, // 1 'HTTP_ACCEPT' - fieldAccept
19, // 2 'HTTP_ACCEPT_CHARSET' - fieldAcceptCharset
20, // 3 'HTTP_ACCEPT_ENCODING' - fieldAcceptEncoding
0, // 4
0, // 5
0, // 6
0, // 7
0, // 8
2, // 9 'CONTENT_LENGTH'
3, // 10 'CONTENT_TYPE' - fieldAcceptEncoding
24, // 11 'HTTP_COOKIE' - fieldCookie
0, // 12
0, // 13
0, // 14
21, // 15 'HTTP_IF_MODIFIED_SINCE'- fieldIfModifiedSince
0, // 16
0, // 17
0, // 18
22, // 19 'HTTP_REFERER' - fieldReferer
0, // 20
0, // 21
0, // 22
23, // 23 'HTTP_USER_AGENT' - fieldUserAgent
1, // 24 'AUTH_TYPE' - fieldWWWAuthenticate
5, // 25 'PATH_INFO'
6, // 26 'PATH_TRANSLATED'
8, // 27 'REMOTE_ADDR'
9, // 28 'REMOTE_HOST'
13, // 29 'SCRIPT_NAME'
15, // 30 'SERVER_PORT'
12, // 31 'REQUEST_METHOD'
0, // 32
7, // 33 'QUERY_STRING'
27 // 34 'HTTP_HOST'
);
var ACgiVarNr : Integer;
begin
Result := '';
if assigned(FCGIParams) and (index < high(HttpToCGI)) and (index > 0) then
begin
ACgiVarNr:=HttpToCGI[Index];
if ACgiVarNr>0 then
Result:=FCGIParams.Values[CgiVarNames[ACgiVarNr]]
else
Result := '';
end
else
Result:=inherited GetFieldValue(Index);
end;
{ TCGIResponse }
procedure TFCGIResponse.Write_FCGIRecord(ARecord : PFCGI_Header);
var BytesToWrite : word;
BytesWritten : Integer;
begin
BytesToWrite := BEtoN(ARecord^.contentLength) + ARecord^.paddingLength+sizeof(FCGI_Header);
BytesWritten := sockets.fpsend(TFCGIRequest(Request).Handle, ARecord, BytesToWrite, MSG_NOSIGNAL);
Assert(BytesWritten=BytesToWrite);
end;
procedure TFCGIResponse.DoSendHeaders(Headers : TStrings);
var
cl : word;
pl : byte;
str : String;
ARespRecord : PFCGI_ContentRecord;
begin
str := Headers.Text;
cl := length(str);
pl := (cl mod 8);
ARespRecord:=nil;
Getmem(ARespRecord,8+cl+pl);
ARespRecord^.header.version:=FCGI_VERSION_1;
ARespRecord^.header.reqtype:=FCGI_STDOUT;
ARespRecord^.header.paddingLength:=pl;
ARespRecord^.header.contentLength:=NtoBE(cl);
ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
move(str[1],ARespRecord^.ContentData,cl);
Write_FCGIRecord(PFCGI_Header(ARespRecord));
Freemem(ARespRecord);
end;
procedure TFCGIResponse.DoSendContent;
var
cl : word;
pl : byte;
str : String;
ARespRecord : PFCGI_ContentRecord;
EndRequest : FCGI_EndRequestRecord;
begin
If Assigned(ContentStream) then
begin
setlength(str,ContentStream.Size);
ContentStream.Position:=0;
ContentStream.Read(str[1],ContentStream.Size);
end
else
str := Contents.Text;
cl := length(str);
pl := (cl mod 8);
ARespRecord:=Nil;
Getmem(ARespRecord,8+cl+pl);
ARespRecord^.header.version:=FCGI_VERSION_1;
ARespRecord^.header.reqtype:=FCGI_STDOUT;
ARespRecord^.header.paddingLength:=pl;
ARespRecord^.header.contentLength:=NtoBE(cl);
ARespRecord^.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
move(str[1],ARespRecord^.ContentData,cl);
Write_FCGIRecord(PFCGI_Header(ARespRecord));
Freemem(ARespRecord);
EndRequest.header.version:=FCGI_VERSION_1;
EndRequest.header.reqtype:=FCGI_END_REQUEST;
EndRequest.header.contentLength:=NtoBE(8);
EndRequest.header.paddingLength:=0;
EndRequest.header.requestId:=NToBE(TFCGIRequest(Request).RequestID);
Write_FCGIRecord(PFCGI_Header(@EndRequest));
end;
{ TCustomFCgiApplication }
constructor TCustomFCgiApplication.Create(AOwner: TComponent);
begin
FRequestsAvail:=5;
SetLength(FRequestsArray,FRequestsAvail);
FHandle := -1;
end;
destructor TCustomFCgiApplication.Destroy;
begin
SetLength(FRequestsArray,0);
inherited Destroy;
end;
procedure TCustomFCgiApplication.EndRequest(ARequest: TRequest; AResponse: TResponse);
begin
with FRequestsArray[TFCGIRequest(ARequest).RequestID] do
begin
Assert(ARequest=Request);
Assert(AResponse=Response);
if not TFCGIRequest(ARequest).KeepConnectionAfterRequest then
begin
fpshutdown(FHandle,SHUT_RDWR);
FpClose(FHandle);
FHandle := -1;
end;
Request := Nil;
Response := Nil;
end;
Inherited;
end;
function TCustomFCgiApplication.Read_FCGIRecord : PFCGI_Header;
var Header : FCGI_Header;
BytesRead : integer;
ContentLength : word;
PaddingLength : byte;
ResRecord : pointer;
ReadBuf : pointer;
function ReadBytes(ByteAmount : Word) : boolean;
begin
result := False;
if ByteAmount>0 then
begin
BytesRead := sockets.fpRecv(FHandle, ReadBuf, ByteAmount, MSG_NOSIGNAL);
if BytesRead<>ByteAmount then
begin
// SendDebug('FCGIRecord incomplete');
// SendDebug('BytesRead: '+inttostr(BytesRead)+', expected: '+inttostr(ByteAmount));
exit;
end
else
Result := True;
end;
end;
begin
Result := Nil;
ResRecord:=Nil;
ReadBuf:=@Header;
if not ReadBytes(Sizeof(Header)) then exit;
ContentLength:=BetoN(Header.contentLength);
PaddingLength:=Header.paddingLength;
Getmem(ResRecord,BytesRead+ContentLength+PaddingLength);
PFCGI_Header(ResRecord)^:=Header;
ReadBuf:=ResRecord+BytesRead;
ReadBytes(ContentLength);
ReadBuf:=ReadBuf+BytesRead;
ReadBytes(PaddingLength);
Result := ResRecord;
end;
function TCustomFCgiApplication.WaitForRequest(var ARequest: TRequest; var AResponse: TResponse): boolean;
var
Address : TInetSockAddr;
AddressLength : tsocklen;
ARequestID : word;
AFCGI_Record : PFCGI_Header;
ATempRequest : TFCGIRequest;
begin
Result := False;
AddressLength:=Sizeof(Address);
if FHandle=-1 then
begin
FHandle:=fpaccept(StdInputHandle,psockaddr(@Address),@AddressLength);
if FHandle=-1 then
raise Exception.CreateFmt(SNoInputHandle,[socketerror]);
end;
repeat
AFCGI_Record:=Read_FCGIRecord;
if assigned(AFCGI_Record) then
begin
ARequestID:=BEtoN(AFCGI_Record^.requestID);
if AFCGI_Record^.reqtype = FCGI_BEGIN_REQUEST then
begin
if ARequestID>FRequestsAvail then
begin
inc(FRequestsAvail,10);
SetLength(FRequestsArray,FRequestsAvail);
end;
assert(not assigned(FRequestsArray[ARequestID].Request));
assert(not assigned(FRequestsArray[ARequestID].Response));
ATempRequest:=TFCGIRequest.Create;
ATempRequest.RequestID:=ARequestID;
ATempRequest.Handle:=FHandle;
FRequestsArray[ARequestID].Request := ATempRequest;
end;
if FRequestsArray[ARequestID].Request.ProcessFCGIRecord(AFCGI_Record) then
begin
ARequest:=FRequestsArray[ARequestID].Request;
FRequestsArray[ARequestID].Response := TFCGIResponse.Create(ARequest);
AResponse:=FRequestsArray[ARequestID].Response;
Result := True;
Break;
end;
end;
until Terminated;
end;
end.

143
packages/fcl-web/src/custweb.pp Normal file
View File

@ -0,0 +1,143 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2009 by the Free Pascal development team
TWebApplication class.
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.
**********************************************************************}
{ $define CGIDEBUG}
{$mode objfpc}
{$H+}
unit custweb;
Interface
uses
CustApp,Classes,SysUtils, httpdefs;
Const
CGIVarCount = 34;
Type
TCGIVarArray = Array[1..CGIVarCount] of String;
Const
CgiVarNames : TCGIVarArray =
({ 1 } 'AUTH_TYPE',
{ 2 } 'CONTENT_LENGTH',
{ 3 } 'CONTENT_TYPE',
{ 4 } 'GATEWAY_INTERFACE',
{ 5 } 'PATH_INFO',
{ 6 } 'PATH_TRANSLATED',
{ 7 } 'QUERY_STRING',
{ 8 } 'REMOTE_ADDR',
{ 9 } 'REMOTE_HOST',
{ 10 } 'REMOTE_IDENT',
{ 11 } 'REMOTE_USER',
{ 12 } 'REQUEST_METHOD',
{ 13 } 'SCRIPT_NAME',
{ 14 } 'SERVER_NAME',
{ 15 } 'SERVER_PORT',
{ 16 } 'SERVER_PROTOCOL',
{ 17 } 'SERVER_SOFTWARE',
{ 18 } 'HTTP_ACCEPT',
{ 19 } 'HTTP_ACCEPT_CHARSET',
{ 20 } 'HTTP_ACCEPT_ENCODING',
{ 21 } 'HTTP_IF_MODIFIED_SINCE',
{ 22 } 'HTTP_REFERER',
{ 23 } 'HTTP_USER_AGENT',
{ 24 } 'HTTP_COOKIE',
// Additional Apache vars
{ 25 } 'HTTP_CONNECTION',
{ 26 } 'HTTP_ACCEPT_LANGUAGE',
{ 27 } 'HTTP_HOST',
{ 28 } 'SERVER_SIGNATURE',
{ 29 } 'SERVER_ADDR',
{ 30 } 'DOCUMENT_ROOT',
{ 31 } 'SERVER_ADMIN',
{ 32 } 'SCRIPT_FILENAME',
{ 33 } 'REMOTE_PORT',
{ 34 } 'REQUEST_URI'
);
Type
{ TCustomWebApplication }
TCustomWebApplication = Class(TCustomApplication)
Private
FRequest : TRequest;
FHandleGetOnPost : Boolean;
FRedirectOnError : Boolean;
FRedirectOnErrorURL : String;
protected
function WaitForRequest(var ARequest : TRequest; var AResponse : TResponse) : boolean; virtual; abstract;
procedure EndRequest(ARequest : TRequest;AResponse : TResponse); virtual;
Public
constructor Create(AOwner: TComponent); override;
Procedure Initialize; override;
Procedure DoRun; override;
Procedure handleRequest(ARequest : TRequest; AResponse : TResponse); virtual;
Property HandleGetOnPost : Boolean Read FHandleGetOnPost Write FHandleGetOnPost;
Property RedirectOnError : boolean Read FRedirectOnError Write FRedirectOnError;
Property RedirectOnErrorURL : string Read FRedirectOnErrorURL Write FRedirectOnErrorURL;
Property Request : TRequest read FRequest;
end;
Implementation
{$ifdef CGIDEBUG}
uses
dbugintf;
{$endif}
procedure TCustomWebApplication.DoRun;
var ARequest : TRequest;
AResponse : TResponse;
begin
while not Terminated do
begin
if WaitForRequest(ARequest,AResponse) then
begin
HandleRequest(ARequest,AResponse);
If Not AResponse.ContentSent then
AResponse.SendContent;
EndRequest(ARequest,AResponse);
end;
end;
end;
procedure TCustomWebApplication.HandleRequest(ARequest: TRequest; AResponse: TResponse);
begin
// Needs overriding;
end;
Procedure TCustomWebApplication.Initialize;
begin
StopOnException:=True;
Inherited;
end;
procedure TCustomWebApplication.EndRequest(ARequest: TRequest; AResponse: TResponse);
begin
AResponse.Free;
ARequest.Free;
end;
constructor TCustomWebApplication.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FHandleGetOnPost := True;
FRedirectOnError := False;
FRedirectOnErrorURL := '';
end;
end.

158
packages/fcl-web/src/fastcgi.pp Normal file
View File

@ -0,0 +1,158 @@
unit fastcgi;
interface
{
Automatically converted by H2Pas 0.99.16 from fastcgi.h
The following command line parameters were used:
fastcgi.h
}
{$IFDEF FPC}
{$PACKRECORDS C}
{$ENDIF}
{
* Listening socket file number
}
const
FCGI_LISTENSOCK_FILENO = 0;
type
PFCGI_Header = ^FCGI_Header;
FCGI_Header = record
version : byte;
reqtype : byte;
// requestIdB1 : byte;
// requestIdB0 : byte;
requestID : word; // Stored as big-endian
//contentLengthB1 : byte;
//contentLengthB0 : byte;
contentLength : word; // Stored as big-endian
paddingLength : byte;
reserved : byte;
end;
{
* Number of bytes in a FCGI_Header. Future versions of the protocol
* will not reduce this number.
}
const
FCGI_HEADER_LEN = 8;
{
* Value for version component of FCGI_Header
}
FCGI_VERSION_1 = 1;
{
* Values for type component of FCGI_Header
}
FCGI_BEGIN_REQUEST = 1;
FCGI_ABORT_REQUEST = 2;
FCGI_END_REQUEST = 3;
FCGI_PARAMS = 4;
FCGI_STDIN = 5;
FCGI_STDOUT = 6;
FCGI_STDERR = 7;
FCGI_DATA = 8;
FCGI_GET_VALUES = 9;
FCGI_GET_VALUES_RESULT = 10;
FCGI_UNKNOWN_TYPE = 11;
FCGI_MAXTYPE = FCGI_UNKNOWN_TYPE;
{
* Value for requestId component of FCGI_Header
}
FCGI_NULL_REQUEST_ID = 0;
type
FCGI_BeginRequestBody = record
//roleB1 : byte;
//roleB0 : byte;
role : word; // Stored as big-endian
flags : byte;
reserved : array[0..4] of byte;
end;
PFCGI_BeginRequestRecord = ^FCGI_BeginRequestRecord;
FCGI_BeginRequestRecord = record
header : FCGI_Header;
body : FCGI_BeginRequestBody;
end;
{
* Mask for flags component of FCGI_BeginRequestBody
}
const
FCGI_KEEP_CONN = 1;
{
* Values for role component of FCGI_BeginRequestBody
}
FCGI_RESPONDER = 1;
FCGI_AUTHORIZER = 2;
FCGI_FILTER = 3;
type
FCGI_EndRequestBody = record
appStatusB3 : byte;
appStatusB2 : byte;
appStatusB1 : byte;
appStatusB0 : byte;
protocolStatus : byte;
reserved : array[0..2] of byte;
end;
FCGI_EndRequestRecord = record
header : FCGI_Header;
body : FCGI_EndRequestBody;
end;
{
* Values for protocolStatus component of FCGI_EndRequestBody
}
const
FCGI_REQUEST_COMPLETE = 0;
FCGI_CANT_MPX_CONN = 1;
FCGI_OVERLOADED = 2;
FCGI_UNKNOWN_ROLE = 3;
{
* Variable names for FCGI_GET_VALUES / FCGI_GET_VALUES_RESULT records
}
FCGI_MAX_CONNS = 'FCGI_MAX_CONNS';
FCGI_MAX_REQS = 'FCGI_MAX_REQS';
FCGI_MPXS_CONNS = 'FCGI_MPXS_CONNS';
type
FCGI_UnknownTypeBody = record
_type : byte;
reserved : array[0..6] of byte;
end;
FCGI_UnknownTypeRecord = record
header : FCGI_Header;
body : FCGI_UnknownTypeBody;
end;
PFCGI_ContentRecord = ^FCGI_ContentRecord;
FCGI_ContentRecord = record
header : FCGI_Header;
ContentData : array[0..1023] of byte;
end;
implementation
end.