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

* Rework header treatment, deprecated some calls/properties

Browse Source 
git-svn-id: trunk@30550 -
This commit is contained in:
michael 2015-04-12 08:24:24 +00:00
parent 9559dabe51
commit 4769a5407c
10 changed files with 1067 additions and 588 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -3149,6 +3149,7 @@ packages/fcl-web/src/base/Makefile svneol=native#text/plain
packages/fcl-web/src/base/Makefile.fpc svneol=native#text/plain
packages/fcl-web/src/base/README.txt svneol=native#text/plain
packages/fcl-web/src/base/cgiapp.pp svneol=native#text/plain
packages/fcl-web/src/base/cgiprotocol.pp svneol=native#text/plain
packages/fcl-web/src/base/custcgi.pp svneol=native#text/plain
packages/fcl-web/src/base/custfcgi.pp svneol=native#text/plain
packages/fcl-web/src/base/custhttpapp.pp svneol=native#text/plain
@ -3169,6 +3170,7 @@ packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
packages/fcl-web/src/base/httpprotocol.pp svneol=native#text/plain
packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain
packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
packages/fcl-web/src/base/websession.pp svneol=native#text/plain

11
packages/fcl-web/fpmake.pp
View File

@ -48,6 +48,8 @@ begin
T.ResourceStrings:=true;
with T.Dependencies do
begin
AddUnit('httpprotocol');
AddUnit('cgiprotocol');
AddUnit('httpdefs');
end;
T:=P.Targets.AddUnit('ezcgi.pp');
@ -83,7 +85,12 @@ begin
AddUnit('fphttp');
AddUnit('websession');
end;
T:=P.Targets.AddUnit('httpprotocol.pp');
T:=P.Targets.AddUnit('cgiprotocol.pp');
T:=P.Targets.AddUnit('httpdefs.pp');
T.Dependencies.AddUnit('httpprotocol');
T.ResourceStrings:=true;
T:=P.Targets.AddUnit('iniwebsession.pp');
T.ResourceStrings:=true;
@ -122,6 +129,9 @@ begin
with P.Targets.AddUnit('custfcgi.pp') do
begin
OSes:=AllOses-[wince,darwin,iphonesim,aix,amiga,aros];
Dependencies.AddUnit('httpprotocol');
Dependencies.AddUnit('cgiprotocol');
Dependencies.AddUnit('custcgi');
Dependencies.AddUnit('httpdefs');
Dependencies.AddUnit('custweb');
ResourceStrings:=true;
@ -129,6 +139,7 @@ begin
with P.Targets.AddUnit('fpapache.pp') do
begin
OSes:=AllOses-[amiga,aros];
Dependencies.AddUnit('httpprotocol');
Dependencies.AddUnit('fphttp');
Dependencies.AddUnit('custweb');
ResourceStrings:=true;

80
packages/fcl-web/src/base/cgiprotocol.pp Normal file
View File

@ -0,0 +1,80 @@
unit cgiprotocol;
{$mode objfpc}{$H+}
interface
Const
CGIVarCount = 44 ;
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',
{ 35 } 'CONTENT',
{ 36 } 'HTTP_X_REQUESTED_WITH',
{ 37 } 'HTTP_AUTHORIZATION',
{ 38 } 'SCRIPT_URI',
{ 39 } 'SCRIPT_URL',
{ 40 } 'CONTEXT_DOCUMENT_ROOT',
{ 41 } 'CONTEXT_PREFIX',
{ 42 } 'HTTP_CACHE_CONTROL',
{ 43 } 'HTTP_PRAGMA',
{ 44 } 'REQUEST_SCHEME'
);
Function IndexOfCGIVar(AVarName: String): Integer;
implementation
uses sysutils;
Function IndexOfCGIVar(AVarName: String): Integer;
begin
Result:=CGIVarCount;
While (Result>0) and (CompareText(AVarName,CgiVarNames[Result])<>0) do
Dec(Result);
If Result<1 then
Result:=-1;
end;
end.

221
packages/fcl-web/src/base/custcgi.pp
View File

@ -21,7 +21,7 @@ unit custcgi;
Interface
uses
CustWeb,Classes,SysUtils, httpdefs;
CustWeb, Classes,SysUtils, httpdefs, cgiprotocol, httpprotocol;
Type
{ TCGIRequest }
@ -36,7 +36,8 @@ Type
FOnContentRead: TCGIContentReadEvent;
function GetCGIVar(Index: integer): String;
Protected
Function GetFieldValue(Index : Integer) : String; override;
Function DoMapCgiToHTTP(Const AVariableName : String; Out AHeaderType : THeader; Out AVariableType : THTTPVariableType) : Boolean;
function DoGetCGIVar(AVarName: String): String; virtual;
Procedure InitFromEnvironment; virtual;
// Read content from stdin. Calls DoContentRead to see if reading must be aborted.
procedure ReadContent; override;
@ -45,16 +46,30 @@ Type
Function DoContentRead(B : PByte; Len : Integer) : Boolean; virtual;
Public
Constructor CreateCGI(ACGI : TCGIHandler);
Function GetCustomHeader(const Name: String) : String; override;
Property OnContentRead : TCGIContentReadEvent Read FOnContentRead Write FOnContentRead;
Property GatewayInterface : String Index 1 Read GetCGIVar;
Property RemoteIdent : String Index 2 read GetCGIVar;
Property RemoteUser : String Index 3 read GetCGIVar;
Property RequestMethod : String Index 4 read GetCGIVar;
Property ServerName : String Index 5 read GetCGIVar;
Property ServerProtocol : String Index 6 read GetCGIVar;
Property ServerSoftware : String Index 7 read GetCGIVar;
// Index is index in CGIVarnames array.
Property GatewayInterface : String Index 4 Read GetCGIVar;
Property RemoteIdent : String Index 10 read GetCGIVar;
Property RemoteUser : String Index 11 read GetCGIVar;
Property RequestMethod : String Index 12 read GetCGIVar;
Property ServerName : String Index 14 read GetCGIVar;
Property ServerProtocol : String Index 16 read GetCGIVar;
Property ServerSoftware : String Index 17 read GetCGIVar;
Property ServerSignature : String Index 28 Read GetCGIVar;
Property ServerAddr : String Index 29 Read GetCGIVar;
Property DocumentRoot : String Index 30 Read GetCGIVar;
Property ServerAdmin : String Index 31 Read GetCGIVar;
Property ScriptFileName : String Index 32 Read GetCGIVar;
Property RemotePort : String Index 33 Read GetCGIVar;
Property RequestURI : String Index 34 Read GetCGIVar;
Property ScriptURI : String Index 38 Read GetCGIVar;
Property ContextDocumentRoot : String Index 40 Read GetCGIVar;
Property ContextPrefix : String Index 41 Read GetCGIVar;
Property RequestScheme : String Index 44 Read GetCGIVar;
end;
TCGIRequestClass = Class of TCGIRequest;
{ TCGIResponse }
TCGIResponse = Class(TResponse)
@ -139,53 +154,61 @@ uses
{$endif}
iostream;
Type
TMap = record
h : THeader;
v : THTTPVariableType;
end;
TCGIHeaderMap = Array[1..CGIVarCount] of TMap;
Const
MapCgiToHTTP : TCGIVarArray =
({ 1: 'AUTH_TYPE' } fieldWWWAuthenticate, // ?
{ 2: 'CONTENT_LENGTH' } FieldContentLength,
{ 3: 'CONTENT_TYPE' } FieldContentType,
{ 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' } FieldAccept,
{ 19: 'HTTP_ACCEPT_CHARSET' } FieldAcceptCharset,
{ 20: 'HTTP_ACCEPT_ENCODING' } FieldAcceptEncoding,
{ 21: 'HTTP_IF_MODIFIED_SINCE' } FieldIfModifiedSince,
{ 22: 'HTTP_REFERER' } FieldReferer,
{ 23: 'HTTP_USER_AGENT' } FieldUserAgent,
{ 24: 'HTTP_COOKIE' } FieldCookie,
MapCgiToHTTP : TCGIHeaderMap =
({ 1: 'AUTH_TYPE' } (h : hhWWWAuthenticate; v : hvUnknown), // ?
{ 2: 'CONTENT_LENGTH' } (h : hhContentLength; v : hvUnknown),
{ 3: 'CONTENT_TYPE' } (h : hhContentType; v : hvUnknown),
{ 4: 'GATEWAY_INTERFACE' } (h:hhUnknown; v : hvUnknown),
{ 5: 'PATH_INFO' } (h:hhUnknown; v : hvPathInfo),
{ 6: 'PATH_TRANSLATED' } (h:hhUnknown; v : hvPathTranslated),
{ 7: 'QUERY_STRING' } (h:hhUnknown; v : hvQuery),
{ 8: 'REMOTE_ADDR' } (h:hhUnknown; v : hvRemoteAddress),
{ 9: 'REMOTE_HOST' } (h:hhUnknown; v : hvRemoteHost),
{ 10: 'REMOTE_IDENT' } (h:hhUnknown; v : hvUnknown),
{ 11: 'REMOTE_USER' } (h:hhUnknown; v : hvUnknown),
{ 12: 'REQUEST_METHOD' } (h:hhUnknown; v : hvMethod),
{ 13: 'SCRIPT_NAME' } (h:hhUnknown; v : hvScriptName),
{ 14: 'SERVER_NAME' } (h:hhServer; v : hvUnknown),
{ 15: 'SERVER_PORT' } (h:hhUnknown; v : hvServerPort),
{ 16: 'SERVER_PROTOCOL' } (h:hhUnknown; v : hvUnknown),
{ 17: 'SERVER_SOFTWARE' } (h:hhUnknown; v : hvUnknown),
{ 18: 'HTTP_ACCEPT' } (h:hhAccept; v : hvUnknown),
{ 19: 'HTTP_ACCEPT_CHARSET' } (h:hhAcceptCharset; v : hvUnknown),
{ 20: 'HTTP_ACCEPT_ENCODING' } (h:hhAcceptEncoding; v : hvUnknown),
{ 21: 'HTTP_IF_MODIFIED_SINCE' } (h:hhIfModifiedSince; v : hvUnknown),
{ 22: 'HTTP_REFERER' } (h:hhReferer; v : hvUnknown),
{ 23: 'HTTP_USER_AGENT' } (h:hhUserAgent; v : hvUnknown),
{ 24: 'HTTP_COOKIE' } (h:hhUnknown; v : hvCookie),
// Additional Apache vars
{ 25: 'HTTP_CONNECTION' } FieldConnection,
{ 26: 'HTTP_ACCEPT_LANGUAGE' } FieldAcceptLanguage,
{ 27: 'HTTP_HOST' } '',
{ 28: 'SERVER_SIGNATURE' } '',
{ 29: 'SERVER_ADDR' } '',
{ 30: 'DOCUMENT_ROOT' } '',
{ 31: 'SERVER_ADMIN' } '',
{ 32: 'SCRIPT_FILENAME' } '',
{ 33: 'REMOTE_PORT' } '',
{ 34: 'REQUEST_URI' } '',
{ 35: 'CONTENT' } '',
{ 36: 'XHTTPREQUESTEDWITH' } '',
{ 37: 'HTTP_AUTHORIZATION' } FieldAuthorization,
{ 38: 'SCRIPT_URI' } '',
{ 39: 'SCRIPT_URL' } '',
{ 40: 'CONTEXT_DOCUMENT_ROOT' } '',
{ 41: 'CONTEXT_PREFIX' } '',
{ 42: 'HTTP_CACHE_CONTROL' } '',
{ 43: 'HTTP_PRAGMA' } '',
{ 44: 'REQUEST_SCHEME' } ''
{ 25: 'HTTP_CONNECTION' } (h:hhConnection; v : hvUnknown),
{ 26: 'HTTP_ACCEPT_LANGUAGE' } (h:hhAcceptLanguage; v : hvUnknown),
{ 27: 'HTTP_HOST' } (h:hhHost; v : hvUnknown),
{ 28: 'SERVER_SIGNATURE' } (h:hhUnknown; v : hvUnknown),
{ 29: 'SERVER_ADDR' } (h:hhUnknown; v : hvUnknown),
{ 30: 'DOCUMENT_ROOT' } (h:hhUnknown; v : hvUnknown),
{ 31: 'SERVER_ADMIN' } (h:hhUnknown; v : hvUnknown),
{ 32: 'SCRIPT_FILENAME' } (h:hhUnknown; v : hvUnknown),
{ 33: 'REMOTE_PORT' } (h:hhUnknown; v : hvUnknown),
{ 34: 'REQUEST_URI' } (h:hhUnknown; v : hvUnknown),
{ 35: 'CONTENT' } (h:hhUnknown; v : hvContent),
{ 36: 'XHTTPREQUESTEDWITH' } (h:hhUnknown; v : hvXRequestedWith),
{ 37: 'HTTP_AUTHORIZATION' } (h:hhAuthorization; v : hvUnknown),
{ 38: 'SCRIPT_URI' } (h:hhUnknown; v : hvUnknown),
{ 39: 'SCRIPT_URL' } (h:hhUnknown; v : hvURL),
{ 40: 'CONTEXT_DOCUMENT_ROOT' } (h:hhUnknown; v : hvUnknown),
{ 41: 'CONTEXT_PREFIX' } (h:hhUnknown; v : hvUnknown),
{ 42: 'HTTP_CACHE_CONTROL' } (h:hhCacheControl; v : hvUnknown),
{ 43: 'HTTP_PRAGMA' } (h:hhPragma; v : hvUnknown),
{ 44: 'REQUEST_SCHEME' } (h:hhUnknown; v : hvUnknown)
);
procedure TCgiHandler.GetCGIVarList(List: TStrings);
@ -282,7 +305,20 @@ begin
FCGI:=ACGI;
end;
function TCGIRequest.GetCustomHeader(const Name: String): String;
begin
Result:=inherited GetCustomHeader(Name);
// Check environment
if (Result='') then
Result:=DoGetCGIVAr('HTTP_'+StringReplace(Uppercase(Name),'-','_',[rfReplaceAll]));
end;
{ TCGIHTTPRequest }
function TCGIRequest.DoGetCGIVar(AVarName : String) : String;
begin
GetEnvironmentVariable(AVarName);
end;
function TCGIRequest.GetCGIVar(Index: integer): String;
@ -290,41 +326,51 @@ Var
R : String;
begin
Case Index of
1 : R:=GetEnvironmentVariable(CGIVarNames[4]); // Property GatewayInterface : String Index 1 Read GetCGIVar;
2 : R:=GetEnvironmentVariable(CGIVarNames[10]); // Property RemoteIdent : String Index 2 read GetCGIVar;
3 : R:=GetEnvironmentVariable(CGIVarNames[11]); // Property RemoteUser : String Index 3 read GetCGIVar;
4 : R:=GetEnvironmentVariable(CGIVarNames[12]); // Property RequestMethod : String Index 4 read GetCGIVar;
5 : R:=GetEnvironmentVariable(CGIVarNames[14]); // Property ServerName : String Index 5 read GetCGIVar;
6 : R:=GetEnvironmentVariable(CGIVarNames[16]); // Property ServerProtocol : String Index 6 read GetCGIVar;
7 : R:=GetEnvironmentVariable(CGIVarNames[17]); // Property ServerSoftware : String Index 7 read GetCGIVar;
end;
if Index in [1..CGIVarCount] then
R:=DoGetCGIVar(CGIVarNames[Index])
else
R:='';
Result:=HTTPDecode(R);
end;
function TCGIRequest.DoMapCgiToHTTP(const AVariableName: String; out
AHeaderType: THeader; Out AVariableType: THTTPVariableType): Boolean;
Var
I : Integer;
begin
I:=IndexOfCGIVar(AVariableName);
Result:=I<>-1;
if Result then
begin
AHeaderType:=MapCgiToHTTP[i].H;
AVariableType:=MapCgiToHTTP[i].V;
end;
end;
procedure TCGIRequest.InitFromEnvironment;
Var
I : Integer;
N,V,OV : String;
V,OV : String;
M : TMap;
begin
For I:=1 to CGIVarCount do
begin
N:=MapCgiToHTTP[i];
if (N<>'') then
V:=GetEnvironmentVariable(CGIVarNames[I]);
if (V<>'') then
begin
OV:=GetFieldByName(N);
V:=GetEnvironmentVariable(CGIVarNames[I]);
If (OV='') or (V<>'') then
M:=MapCgiToHTTP[i];
if M.H<>hhUnknown then
SetHeader(M.H,HTTPDecode(V))
else if M.V<>hvUnknown then
begin
if (N<>'QUERY_STRING') then
if M.V<>hvQuery then
V:=HTTPDecode(V);
SetFieldByName(N,V);
SetHTTPVariable(M.V,V)
end;
end;
end
end;
end;
@ -390,35 +436,6 @@ begin
FOnContentRead(Self,B,Len,Result);
end;
function TCGIRequest.GetFieldValue(Index: Integer): String;
Function DecodeVar(I : Integer; DoDecode : Boolean = true) : String;
begin
Result:=GetEnvironmentVariable(CGIVarNames[I]);
if DoDecode then
Result:=HttpDecode(Result)
end;
begin
Case Index of
21,
34 : Result:=DecodeVar(14); // Property ServerName and Host
25 : Result:=Decodevar(5); // Property PathInfo
26 : Result:=DecodeVar(6); // Property PathTranslated
27 : Result:=DecodeVar(8); // Property RemoteAddress
28 : Result:=DecodeVar(9); // Property RemoteHost
29 : Result:=DecodeVar(13); // Property ScriptName
30 : Result:=DecodeVar(15); // Property ServerPort
31 : Result:=DecodeVar(12); // Property RequestMethod
32 : Result:=DecodeVar(34); // Property URI
33 : Result:=DecodeVar(7,False); // Property QueryString
36 : Result:=DecodeVar(36); // Property XRequestedWith
else
Result:=Inherited GetFieldValue(Index);
end;
end;
{ TCGIResponse }

114
packages/fcl-web/src/base/custfcgi.pp
View File

@ -36,7 +36,7 @@ uses
{$else}
winsock2, windows,
{$endif}
Sockets, custweb, custcgi, fastcgi;
Sockets, custweb, cgiprotocol, httpprotocol, custcgi, fastcgi;
Type
{ TFCGIRequest }
@ -62,11 +62,10 @@ Type
FUR: TUnknownRecordEvent;
FLog : TLogEvent;
FSTDin : String;
procedure GetNameValuePairsFromContentRecord(const ARecord : PFCGI_ContentRecord; NameValueList : TStrings);
Protected
function DoGetCGIVar(AVarName: String): String; override;
procedure GetNameValuePairsFromContentRecord(const ARecord : PFCGI_ContentRecord; NameValueList : TStrings); virtual;
Procedure Log(EventType : TEventType; Const Msg : String);
Function GetFieldValue(Index : Integer) : String; override;
procedure ReadContent; override;
Public
destructor Destroy; override;
function ProcessFCGIRecord(AFCGIRecord : PFCGI_Header) : boolean; virtual;
@ -240,11 +239,6 @@ end;
{ TFCGIHTTPRequest }
procedure TFCGIRequest.ReadContent;
begin
// Nothing has to be done. This should never be called
end;
destructor TFCGIRequest.Destroy;
begin
FCGIParams.Free;
@ -297,6 +291,11 @@ begin
end;
end;
function TFCGIRequest.DoGetCGIVar(AVarName: String): String;
begin
Result:=FCGIParams.Values[AVarName];
end;
procedure TFCGIRequest.GetNameValuePairsFromContentRecord(const ARecord: PFCGI_ContentRecord; NameValueList: TStrings);
var
@ -327,21 +326,44 @@ var
end;
var
NameLength, ValueLength : Integer;
VarNo,NameLength, ValueLength : Integer;
RecordLength : Integer;
Name,Value : String;
h : THeader;
v : THTTPVariableType;
begin
Touch('pairs-enter');
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);
VarNo:=IndexOfCGIVar(Name);
Touch('pairs_'+Name+'__'+Value);
if Not DoMapCgiToHTTP(Name,H,V) then
NameValueList.Add(Name+'='+Value)
else if (H<>hhUnknown) then
SetHeader(H,Value)
else if (v<>hvUnknown) then
begin
Touch('pairs_var_'+Name+'__'+Value);
if (V=hvPathInfo) and (Copy(Value,1,2)='//') then //mod_proxy_fcgi gives double slashes at the beginning for some reason
Delete(Value,1,3);
if (V<>hvQuery) then
Value:=HTTPDecode(Value);
SetHTTPVariable(v,Value);
Touch('pairs_var_done_'+Name+'__'+Value);
end
else
begin
Touch('pairs_other_'+Name+'__'+Value);
NameValueList.Add(Name+'='+Value)
end;
Inc(I);
end;
end;
@ -351,74 +373,8 @@ begin
FLog(EventType,Msg);
end;
Function TFCGIRequest.GetFieldValue(Index : Integer) : String;
Type THttpToCGI = array[1..37] of byte;
const HttpToCGI : THttpToCGI =
(
18, // 1 'HTTP_ACCEPT' - field Accept
19, // 2 'HTTP_ACCEPT_CHARSET' - field AcceptCharset
20, // 3 'HTTP_ACCEPT_ENCODING' - field AcceptEncoding
26, // 4 'HTTP_ACCEPT_LANGUAGE' - field AcceptLanguage
37, // 5 HTTP_AUTHORIZATION - field Authorization
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'
0, // 35 'CONTENT'
36, // 36 'XHTTPREQUESTEDWITH'
37 // 37 'HTTP_AUTHORIZATION'
);
var ACgiVarNr : Integer;
begin
Result := '';
if assigned(FCGIParams) and (index <= high(HttpToCGI)) and (index > 0) and (index<>35) then
begin
ACgiVarNr:=HttpToCGI[Index];
if ACgiVarNr>0 then
begin
Result:=FCGIParams.Values[CgiVarNames[ACgiVarNr]];
if (ACgiVarNr = 5) and //PATH_INFO
(length(Result)>=2)and(word(Pointer(@Result[1])^)=$2F2F)then //mod_proxy_fcgi gives double slashes at the beginning for some reason
Delete(Result, 1, 1); //Remove the extra first one
end else
Result := '';
end
else
Result:=inherited GetFieldValue(Index);
end;
{ TCGIResponse }
procedure TFCGIResponse.Write_FCGIRecord(ARecord : PFCGI_Header);
var ErrorCode,

58
packages/fcl-web/src/base/custweb.pp
View File

@ -23,65 +23,7 @@ Interface
uses
CustApp,Classes,SysUtils, httpdefs, fphttp, eventlog;
Const
CGIVarCount = 44 ;
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',
{ 35 } 'CONTENT',
{ 36 } 'HTTP_X_REQUESTED_WITH',
{ 37 } 'HTTP_AUTHORIZATION',
{ 38 } 'SCRIPT_URI',
{ 39 } 'SCRIPT_URL',
{ 40 } 'CONTEXT_DOCUMENT_ROOT',
{ 41 } 'CONTEXT_PREFIX',
{ 42 } 'HTTP_CACHE_CONTROL',
{ 43 } 'HTTP_PRAGMA',
{ 44 } 'REQUEST_SCHEME'
);
Type
{ TCustomWebApplication }
TGetModuleEvent = Procedure (Sender : TObject; ARequest : TRequest;

108
packages/fcl-web/src/base/fpapache.pp
View File

@ -18,7 +18,7 @@ unit fpapache;
interface
uses
SysUtils,Classes,CustWeb,httpDefs,fpHTTP,httpd, apr, SyncObjs;
SysUtils,Classes,CustWeb,httpDefs,fpHTTP,httpd,httpprotocol, apr, SyncObjs;
Type
@ -31,11 +31,11 @@ Type
FApache : TApacheHandler;
FRequest : PRequest_rec;
Protected
Function GetFieldValue(Index : Integer) : String; override;
Procedure InitFromRequest;
procedure ReadContent; override;
Public
Constructor CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
Function GetCustomHeader(const Name: String) : String; override;
Property ApacheRequest : Prequest_rec Read FRequest;
Property ApacheApp : TApacheHandler Read FApache;
end;
@ -179,6 +179,12 @@ const
HPRIO : Array[THandlerPriority] of Integer
= (APR_HOOK_FIRST,APR_HOOK_MIDDLE,APR_HOOK_LAST);
Function MaybeP(P : Pchar) : String;
begin
If (P<>Nil) then
Result:=StrPas(P);
end;
Procedure InitApache;
@ -448,60 +454,6 @@ end;
{ TApacheRequest }
function TApacheRequest.GetFieldValue(Index: Integer): String;
Function MaybeP(P : Pchar) : String;
begin
If (P<>Nil) then
Result:=StrPas(P);
end;
var
FN : String;
I : Integer;
begin
Result:='';
If (Index in [1..NoHTTPFields]) then
begin
FN:=HTTPFieldNames[Index];
Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(FN)));
end;
if (Result='') and Assigned(FRequest) then
case Index of
0 : Result:=MaybeP(FRequest^.protocol); // ProtocolVersion
7 : Result:=MaybeP(FRequest^.content_encoding); //ContentEncoding
25 : Result:=MaybeP(FRequest^.path_info); // PathInfo
26 : Result:=MaybeP(FRequest^.filename); // PathTranslated
27 : // RemoteAddr
If (FRequest^.Connection<>Nil) then
Result:=MaybeP(FRequest^.Connection^.remote_ip);
28 : // RemoteHost
If (FRequest^.Connection<>Nil) then
begin
Result:=MaybeP(ap_get_remote_host(FRequest^.Connection,
FRequest^.per_dir_config,
// nil,
REMOTE_NAME,@i));
end;
29 : begin // ScriptName
Result:=MaybeP(FRequest^.unparsed_uri);
I:=Pos('?',Result)-1;
If (I=-1) then
I:=Length(Result);
Result:=Copy(Result,1,I-Length(PathInfo));
end;
30 : Result:=IntToStr(ap_get_server_port(FRequest)); // ServerPort
31 : Result:=MaybeP(FRequest^.method); // Method
32 : Result:=MaybeP(FRequest^.unparsed_uri); // URL
33 : Result:=MaybeP(FRequest^.args); // Query
34 : Result:=MaybeP(FRequest^.HostName); // Host
else
Result:=inherited GetFieldValue(Index);
end;
end;
procedure TApacheRequest.ReadContent;
Function MinS(A,B : Integer) : Integer;
@ -542,11 +494,46 @@ begin
end;
procedure TApacheRequest.InitFromRequest;
Var
H : THeader;
V : String;
I : Integer;
begin
ParseCookies;
For H in THeader do
begin
V:=MaybeP(apr_table_get(FRequest^.headers_in,PAnsiChar(HTTPHeaderNames[h])));
If (V<>'') then
SetHeader(H,V);
end;
// Some Specials;
SetHeader(hhContentEncoding,MaybeP(FRequest^.content_encoding));
SetHTTPVariable(hvHTTPVersion,MaybeP(FRequest^.protocol));
SetHTTPVariable(hvPathInfo,MaybeP(FRequest^.path_info));
SetHTTPVariable(hvPathTranslated,MaybeP(FRequest^.filename));
If (FRequest^.Connection<>Nil) then
begin
SetHTTPVariable(hvRemoteAddress,MaybeP(FRequest^.Connection^.remote_ip));
SetHTTPVariable(hvRemoteHost,MaybeP(ap_get_remote_host(FRequest^.Connection,
FRequest^.per_dir_config, REMOTE_NAME,@i)));
end;
V:=MaybeP(FRequest^.unparsed_uri);
I:=Pos('?',V)-1;
If (I=-1) then
I:=Length(V);
SetHTTPVariable(hvScriptName,Copy(V,1,I-Length(PathInfo)));
SetHTTPVariable(hvServerPort,IntToStr(ap_get_server_port(FRequest)));
SetHTTPVariable(hvMethod,MaybeP(FRequest^.method));
SetHTTPVariable(hvURL,FRequest^.unparsed_uri);
SetHTTPVariable(hvQuery,MaybeP(FRequest^.args));
SetHeader(hhHost,MaybeP(FRequest^.HostName));
end;
Constructor TApacheRequest.CreateReq(App : TApacheHandler; ARequest : PRequest_rec);
constructor TApacheRequest.CreateReq(App: TApacheHandler; ARequest: PRequest_rec
);
begin
FApache:=App;
@ -556,6 +543,13 @@ begin
InitFromRequest;
end;
function TApacheRequest.GetCustomHeader(const Name: String): String;
begin
Result:=inherited GetCustomHeader(Name);
if Result='' then
Result:=MaybeP(apr_table_get(FRequest^.headers_in,pchar(Name)));
end;
{ TApacheResponse }
procedure TApacheResponse.DoSendHeaders(Headers: TStrings);

740
packages/fcl-web/src/base/httpdefs.pp
View File

File diff suppressed because it is too large Load Diff

269
packages/fcl-web/src/base/httpprotocol.pp Normal file
View File

@ -0,0 +1,269 @@
unit httpprotocol;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
Type
// HTTP 1.1 defined headers.
THeader = (hhUnknown,
hhAccept,hhAcceptCharset,hhAcceptEncoding, hhAcceptLanguage,
hhAcceptRanges, hhAge, hhAllow, hhAuthorization, hhCacheControl,
hhConnection, hhContentEncoding, hhContentLanguage,
hhContentLength,hhContentLocation, hhContentMD5, hhContentRange,
hhContentType, hhDate, hhETag, hhExpires, hhExpect,
hhFrom, hhHost, hhIfMatch, hhIfModifiedSince, hhIfNoneMatch,
hhIfRange, hhIfUnModifiedSince, hhLastModified, hhLocation, hhMaxForwards,
hhPragma, hhProxyAuthenticate, hhProxyAuthorization, hhRange, hhReferer,
hhRetryAfter, hhServer, hhTE, hhTrailer,
hhTransferEncoding, hhUpgrade , hhUserAgent, hhVary,
hhVia, hhWarning, hhWWWAuthenticate);
THeaders = Set of THeader;
THeaderDirection = (hdRequest,hdResponse);
THeaderDirections = Set of THeaderDirection;
THeadersArray = Array[THeader] of string;
Const
HeaderAccept = 'Accept';
HeaderAcceptCharset = 'Accept-Charset';
HeaderAcceptEncoding = 'Accept-Encoding';
HeaderAcceptLanguage = 'Accept-Language';
HeaderAcceptRanges = 'Accept-Ranges';
HeaderAge = 'Age';
HeaderAllow = 'Allow';
HeaderAuthorization = 'Authorization';
HeaderCacheControl = 'Cache-Control';
HeaderConnection = 'Connection';
HeaderContentEncoding = 'Content-Encoding';
HeaderContentLanguage = 'Content-Language';
HeaderContentLength = 'Content-Length';
HeaderContentLocation = 'Content-Location';
HeaderContentMD5 = 'Content-MD5';
HeaderContentRange = 'Content-Range';
HeaderContentType = 'Content-Type';
HeaderDate = 'Date';
HeaderETag = 'ETag';
HeaderExpires = 'Expires';
HeaderExpect = 'Expect';
HeaderFrom = 'From';
HeaderHost = 'Host';
HeaderIfMatch = 'If-Match';
HeaderIfModifiedSince = 'If-Modified-Since';
HeaderIfNoneMatch = 'If-None-Match';
HeaderIfRange = 'If-Range';
HeaderIfUnModifiedSince = 'If-Unmodified-Since';
HeaderLastModified = 'Last-Modified';
HeaderLocation = 'Location';
HeaderMaxForwards = 'Max-Forwards';
HeaderPragma = 'Pragma';
HeaderProxyAuthenticate = 'Proxy-Authenticate';
HeaderProxyAuthorization = 'Proxy-Authorization';
HeaderRange = 'Range';
HeaderReferer = 'Referer';
HeaderRetryAfter = 'Retry-After';
HeaderServer = 'Server';
HeaderTE = 'TE';
HeaderTrailer = 'Trailer';
HeaderTransferEncoding = 'Transfer-Encoding';
HeaderUpgrade = 'Upgrade';
HeaderUserAgent = 'User-Agent';
HeaderVary = 'Vary';
HeaderVia = 'Via';
HeaderWarning = 'Warning';
HeaderWWWAuthenticate = 'WWW-Authenticate';
// These Headers are NOT in the HTTP 1.1 definition.
HeaderXRequestedWith = 'X-Requested-With';
HeaderCookie = 'Cookie';
HeaderSetCookie = 'Set-Cookie';
HTTPDateFmt = '"%s", dd "%s" yyyy hh:mm:ss'; // For use in FormatDateTime
SCookieExpire = ' "Expires="'+HTTPDateFmt+' "GMT"';
SCookieDomain = ' Domain=%s';
SCookiePath = ' Path=%s';
SCookieSecure = ' Secure';
SCookieHttpOnly = ' HttpOnly';
HTTPMonths: array[1..12] of string[3] = (
'Jan', 'Feb', 'Mar', 'Apr',
'May', 'Jun', 'Jul', 'Aug',
'Sep', 'Oct', 'Nov', 'Dec');
HTTPDays: array[1..7] of string[3] = (
'Sun', 'Mon', 'Tue', 'Wed',
'Thu', 'Fri', 'Sat');
Const
HTTPHeaderDirections : Array[THeader] of THeaderDirections = (
[],
[hdRequest],[hdRequest],[hdRequest], [hdRequest],
[hdResponse], [hdResponse], [hdResponse], [hdRequest], [hdRequest,hdResponse],
[hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest,hdResponse],
[hdRequest,hdResponse],[hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest,hdResponse],
[hdRequest,hdResponse], [hdRequest,hdResponse], [hdResponse], [hdRequest,hdResponse], [hdRequest],
[hdRequest], [hdRequest], [hdRequest], [hdRequest], [hdRequest],
[hdRequest], [hdRequest], [hdRequest,hdResponse], [hdResponse], [hdRequest],
[hdRequest, hdResponse] , [hdResponse], [hdRequest], [hdRequest,hdResponse], [hdRequest],
[hdResponse], [hdResponse], [hdRequest], [hdRequest,hdResponse],
[hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest], [hdRequest,hdResponse],
[hdRequest,hdResponse], [hdRequest,hdResponse], [hdResponse]);
HTTPHeaderNames : THeadersArray
= ('',
HeaderAccept,HeaderAcceptCharset,HeaderAcceptEncoding, HeaderAcceptLanguage,
HeaderAcceptRanges, HeaderAge, HeaderAllow, HeaderAuthorization, HeaderCacheControl,
HeaderConnection, HeaderContentEncoding, HeaderContentLanguage,
HeaderContentLength,HeaderContentLocation, HeaderContentMD5, HeaderContentRange,
HeaderContentType, HeaderDate, HeaderETag, HeaderExpires, HeaderExpect,
HeaderFrom, HeaderHost, HeaderIfMatch, HeaderIfModifiedSince, HeaderIfNoneMatch,
HeaderIfRange, HeaderIfModifiedSince, HeaderLastModified, HeaderLocation, HeaderMaxForwards ,
HeaderPragma, HeaderProxyAuthenticate, HeaderProxyAuthorization, HeaderRange, HeaderReferer,
HeaderRetryAfter, HeaderServer, HeaderTE, HeaderTrailer,
HeaderTransferEncoding, HeaderUpgrade , HeaderUserAgent, HeaderVary,
HeaderVia, HeaderWarning, HeaderWWWAuthenticate);
Function HeaderName(AHeader : THeader) : String;
Function HeaderType(AHeader : String) : THeader;
Function HTTPDecode(const AStr: String): String;
Function HTTPEncode(const AStr: String): String;
Function IncludeHTTPPathDelimiter(const AStr: String): String;
Function ExcludeHTTPPathDelimiter(const AStr: String): String;
implementation
function HeaderName(AHeader: THeader): String;
begin
Result:=HTTPHeaderNames[AHeader];
end;
function HeaderType(AHeader: String): THeader;
begin
Result:=High(THeader);
While (Result>hhUnknown) and (CompareText(HTTPHeaderNames[Result],AHeader)<>0) do
Result:=Pred(Result);
end;
function HTTPDecode(const AStr: String): String;
var
S,SS, R : PChar;
H : String[3];
L,C : Integer;
begin
L:=Length(Astr);
SetLength(Result,L);
If (L=0) then
exit;
S:=PChar(AStr);
SS:=S;
R:=PChar(Result);
while (S-SS)<L do
begin
case S^ of
'+': R^ := ' ';
'%': begin
Inc(S);
if ((S-SS)<L) then
begin
if (S^='%') then
R^:='%'
else
begin
H:='$00';
H[2]:=S^;
Inc(S);
If (S-SS)<L then
begin
H[3]:=S^;
Val(H,PByte(R)^,C);
If (C<>0) then
R^:=' ';
end;
end;
end;
end;
else
R^ := S^;
end;
Inc(R);
Inc(S);
end;
SetLength(Result,R-PChar(Result));
end;
function HTTPEncode(const AStr: String): String;
const
HTTPAllowed = ['A'..'Z','a'..'z',
'*','@','.','_','-',
'0'..'9',
'$','!','''','(',')'];
var
SS,S,R: PChar;
H : String[2];
L : Integer;
begin
L:=Length(AStr);
SetLength(Result,L*3); // Worst case scenario
if (L=0) then
exit;
R:=PChar(Result);
S:=PChar(AStr);
SS:=S; // Avoid #0 limit !!
while ((S-SS)<L) do
begin
if S^ in HTTPAllowed then
R^:=S^
else if (S^=' ') then
R^:='+'
else
begin
R^:='%';
H:=HexStr(Ord(S^),2);
Inc(R);
R^:=H[1];
Inc(R);
R^:=H[2];
end;
Inc(R);
Inc(S);
end;
SetLength(Result,R-PChar(Result));
end;
function IncludeHTTPPathDelimiter(const AStr: String): String;
Var
l : Integer;
begin
Result:=AStr;
L:=Length(Result);
If (L>0) and (Result[L]<>'/') then
Result:=Result+'/';
end;
function ExcludeHTTPPathDelimiter(const AStr: String): String;
Var
l : Integer;
begin
L:=Length(AStr);
If (L>0) and (AStr[L]='/') then
Result:=Copy(AStr,1,L-1)
else
Result:=AStr;
end;
end.

52
packages/fcl-web/src/base/webutil.pp
View File

@ -18,7 +18,7 @@ unit webutil;
interface
uses
Classes, SysUtils, httpdefs;
Classes, SysUtils, httpprotocol, httpdefs;
procedure DumpRequest (ARequest : TRequest; Dump : TStrings; Environment : Boolean = False);
@ -37,32 +37,58 @@ procedure DumpRequest (ARequest : TRequest; Dump : TStrings; Environment : Boole
Var
I,J : integer;
N,V : String;
H : THeader;
VA : THTTPVariableType;
begin
With ARequest, Dump do
begin
// All possible headers
Add('<H1>All possible request headers:</H1>');
Add('<H1>HTTP 1.1 request headers:</H1>');
Add('<TABLE BORDER="1"><TR><TD>Header</TD><TD>Value</TD></TR>');
For I:=1 to NoHTTPFields do
begin
AddNV(HTTPFieldNames[i],GetFieldByName(HTTPFieldNames[i]));
end;
For H in THeader do
if (hdRequest in HTTPHeaderDirections[H]) then
AddNV(HTTPHeaderNames[H],GetHeader(H));
Add('</TABLE><P>');
// Actually sent headers
Add('<H1>Actually sent request headers:</H1>');
Add('<TABLE BORDER="1"><TR><TD>Header</TD><TD>Value</TD></TR>');
For I:=0 to FieldCount-1 do
AddNV(FieldNames[I],FieldValues[I]);
For H in THeader do
if (hdRequest in HTTPHeaderDirections[H]) and HeaderIsSet(H) then
AddNV(HTTPHeaderNames[H],GetHeader(H));
For Va in HeaderBasedVariables do
begin
V:=GetHTTPVariable(Va);
if V<>'' then
AddNV(THTTPHeader.GetVariableHeaderName(Va),V);
end;
For I:=0 to CustomHeaders.Count-1 do
begin
CustomHeaders.GetNameValue(I,N,V);
AddNV(N,V);
end;
Add('</TABLE><P>');
// Actually sent headers, as text
Add('<H1>Actually sent request headers as text:</H1>');
For I:=0 to FieldCount-1 do
Add(Fields[I]+'<BR>');
Add('<pre>');
For H in THeader do
if (hdRequest in HTTPHeaderDirections[H]) and HeaderIsSet(H) then
Add(HTTPHeaderNames[H]+': '+GetHeader(H));
For Va in HeaderBasedVariables do
begin
V:=GetHTTPVariable(Va);
if V<>'' then
Add(THTTPHeader.GetVariableHeaderName(Va)+': '+V);
end;
For I:=0 to CustomHeaders.Count-1 do
begin
CustomHeaders.GetNameValue(I,N,V);
Add(N+': '+V);
end;
Add('</PRE>');
// Additional headers
Add('<H1>Additional headers:</H1>');
Add('<H1>Additional protocol variables:</H1>');
Add('<TABLE BORDER="1"><TR><TD>Header</TD><TD>Value</TD></TR>');
AddNV('PathInfo',PathInfo);
AddNV('PathTranslated',PathTranslated);