diff --git a/.gitattributes b/.gitattributes index d345bafd7b..c0d413ac3c 100644 --- a/.gitattributes +++ b/.gitattributes @@ -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 diff --git a/packages/fcl-web/fpmake.pp b/packages/fcl-web/fpmake.pp index 7ce5a0ee83..440f0bc48e 100644 --- a/packages/fcl-web/fpmake.pp +++ b/packages/fcl-web/fpmake.pp @@ -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; diff --git a/packages/fcl-web/src/base/cgiprotocol.pp b/packages/fcl-web/src/base/cgiprotocol.pp new file mode 100644 index 0000000000..737fc5e91a --- /dev/null +++ b/packages/fcl-web/src/base/cgiprotocol.pp @@ -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. + diff --git a/packages/fcl-web/src/base/custcgi.pp b/packages/fcl-web/src/base/custcgi.pp index 59cdc0d2a2..18ddb18981 100644 --- a/packages/fcl-web/src/base/custcgi.pp +++ b/packages/fcl-web/src/base/custcgi.pp @@ -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 } diff --git a/packages/fcl-web/src/base/custfcgi.pp b/packages/fcl-web/src/base/custfcgi.pp index b04a933261..a9b0da3aed 100644 --- a/packages/fcl-web/src/base/custfcgi.pp +++ b/packages/fcl-web/src/base/custfcgi.pp @@ -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, diff --git a/packages/fcl-web/src/base/custweb.pp b/packages/fcl-web/src/base/custweb.pp index 75f1850439..ba08b4060f 100644 --- a/packages/fcl-web/src/base/custweb.pp +++ b/packages/fcl-web/src/base/custweb.pp @@ -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; diff --git a/packages/fcl-web/src/base/fpapache.pp b/packages/fcl-web/src/base/fpapache.pp index 346ba6da6a..41ffbd17ed 100644 --- a/packages/fcl-web/src/base/fpapache.pp +++ b/packages/fcl-web/src/base/fpapache.pp @@ -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); diff --git a/packages/fcl-web/src/base/httpdefs.pp b/packages/fcl-web/src/base/httpdefs.pp index 276bf372ef..209b66528c 100644 --- a/packages/fcl-web/src/base/httpdefs.pp +++ b/packages/fcl-web/src/base/httpdefs.pp @@ -29,52 +29,76 @@ unit HTTPDefs; interface -uses Classes,Sysutils; +uses typinfo,Classes, Sysutils, httpprotocol; const DefaultTimeOut = 15; SFPWebSession = 'FPWebSession'; // Cookie name for session. - fieldAccept = 'Accept'; - fieldAcceptCharset = 'Accept-Charset'; - fieldAcceptEncoding = 'Accept-Encoding'; - fieldAcceptLanguage = 'Accept-Language'; - fieldAuthorization = 'Authorization'; - fieldConnection = 'Connection'; - fieldContentEncoding = 'Content-Encoding'; - fieldContentLanguage = 'Content-Language'; - fieldContentLength = 'Content-Length'; - fieldContentType = 'Content-Type'; - fieldCookie = 'Cookie'; - fieldDate = 'Date'; - fieldExpires = 'Expires'; - fieldFrom = 'From'; - fieldIfModifiedSince = 'If-Modified-Since'; - fieldLastModified = 'Last-Modified'; - fieldLocation = 'Location'; - fieldPragma = 'Pragma'; - fieldReferer = 'Referer'; - fieldRetryAfter = 'Retry-After'; - fieldServer = 'Server'; - fieldSetCookie = 'Set-Cookie'; - fieldUserAgent = 'User-Agent'; - fieldWWWAuthenticate = 'WWW-Authenticate'; - // These cannot be added to the NoHTTPFields constant - // They are in the extra array. - fieldHost = 'Host'; - fieldCacheControl = 'Cache-Control'; - fieldXRequestedWith = 'X-Requested-With'; + + fieldAccept = HeaderAccept deprecated; + FieldAcceptCharset = HeaderAcceptCharset deprecated; + FieldAcceptEncoding = HeaderAcceptEncoding deprecated; + FieldAcceptLanguage = HeaderAcceptLanguage deprecated; + FieldAcceptRanges = HeaderAcceptRanges deprecated; + FieldAge = HeaderAge deprecated; + FieldAllow = HeaderAllow deprecated; + FieldAuthorization = HeaderAuthorization deprecated; + FieldCacheControl = HeaderCacheControl deprecated; + FieldConnection = HeaderConnection deprecated; + FieldContentEncoding = HeaderContentEncoding deprecated; + FieldContentLanguage = HeaderContentLanguage deprecated; + FieldContentLength = HeaderContentLength deprecated; + FieldContentLocation = HeaderContentLocation deprecated; + FieldContentMD5 = HeaderContentMD5 deprecated; + FieldContentRange = HeaderContentRange deprecated; + FieldContentType = HeaderContentType deprecated; + FieldDate = HeaderDate deprecated; + FieldETag = HeaderETag deprecated; + FieldExpires = HeaderExpires deprecated; + FieldExpect = HeaderExpect deprecated; + FieldFrom = HeaderFrom deprecated; + FieldHost = HeaderHost deprecated; + FieldIfMatch = HeaderIfMatch deprecated; + FieldIfModifiedSince = HeaderIfModifiedSince deprecated; + FieldIfNoneMatch = HeaderIfNoneMatch deprecated; + FieldIfRange = HeaderIfRange deprecated; + FieldIfUnModifiedSince = HeaderIfUnModifiedSince deprecated; + FieldLastModified = HeaderLastModified deprecated; + FieldLocation = HeaderLocation deprecated; + FieldMaxForwards = HeaderMaxForwards deprecated; + FieldPragma = HeaderPragma deprecated; + FieldProxyAuthenticate = HeaderProxyAuthenticate deprecated; + FieldProxyAuthorization = HeaderProxyAuthorization deprecated; + FieldRange = HeaderRange deprecated; + FieldReferer = HeaderReferer deprecated; + FieldRetryAfter = HeaderRetryAfter deprecated; + FieldServer = HeaderServer deprecated; + FieldTE = HeaderTE deprecated; + FieldTrailer = HeaderTrailer deprecated; + FieldTransferEncoding = HeaderTransferEncoding deprecated; + FieldUpgrade = HeaderUpgrade deprecated; + FieldUserAgent = HeaderUserAgent deprecated; + FieldVary = HeaderVary deprecated; + FieldVia = HeaderVia deprecated; + FieldWarning = HeaderWarning deprecated; + FieldWWWAuthenticate = HeaderWWWAuthenticate deprecated; + + // These fields are NOT in the HTTP 1.1 definition. + FieldXRequestedWith = HeaderXRequestedWith deprecated; + FieldCookie = HeaderCookie deprecated; + FieldSetCookie = HeaderSetCookie deprecated; NoHTTPFields = 27; - 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'; + HTTPDateFmt = httpProtocol.HTTPDateFmt; + SCookieExpire = httpProtocol.SCookieExpire; + SCookieDomain = httpProtocol.SCookieDomain; + SCookiePath = httpProtocol.SCookiePath; + SCookieSecure = httpProtocol.SCookieSecure; + SCookieHttpOnly = httpProtocol.SCookieHttpOnly; - HTTPMonths: array[1..12] of string[3] = ( + HTTPMonths : array[1..12] of string[3] = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'); @@ -82,23 +106,31 @@ const 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'); +Type + // HTTP related variables. + THTTPVariableType = (hvUnknown,hvHTTPVersion, hvMethod, hvCookie, hvSetCookie, hvXRequestedWith, + hvPathInfo,hvPathTranslated,hvRemoteAddress,hvRemoteHost,hvScriptName, + hvServerPort,hvURL,hvQuery,hvContent); + THTTPVariableTypes = Set of THTTPVariableType; Type - THttpFields = Array[1..NoHTTPFields] of string; - THttpIndexes = Array[1..NoHTTPFields] of integer; - + THTTPVariables = Array[THTTPVariableType] of string; + THttpFields = Array[1..NoHTTPFields] of string deprecated; + THttpIndexes = Array[1..NoHTTPFields] of integer deprecated; Const + HeaderBasedVariables = [hvCookie,hvSetCookie,hvXRequestedWith]; // For this constant, the header names corresponds to the property index used in THTTPHeader. HTTPFieldNames : THttpFields - = (fieldAccept, fieldAcceptCharset, fieldAcceptEncoding, - fieldAcceptLanguage, fieldAuthorization, fieldConnection, - fieldContentEncoding, fieldContentLanguage, fieldContentLength, - fieldContentType, fieldCookie, fieldDate, fieldExpires, - fieldFrom, fieldIfModifiedSince, fieldLastModified, fieldLocation, - fieldPragma, fieldReferer, fieldRetryAfter, fieldServer, - fieldSetCookie, fieldUserAgent, fieldWWWAuthenticate, - fieldHost, fieldCacheControl,fieldXRequestedWith); + = (fieldAccept, fieldAcceptCharset, fieldAcceptEncoding, + fieldAcceptLanguage, fieldAuthorization, fieldConnection, + fieldContentEncoding, fieldContentLanguage, fieldContentLength, + fieldContentType, fieldCookie, fieldDate, fieldExpires, + fieldFrom, fieldIfModifiedSince, fieldLastModified, fieldLocation, + fieldPragma, fieldReferer, fieldRetryAfter, fieldServer, + fieldSetCookie, fieldUserAgent, fieldWWWAuthenticate, + fieldHost, fieldCacheControl,fieldXRequestedWith) deprecated; + // Map header names on indexes in property getter/setter. 0 means not mapped ! HTTPFieldIndexes : THTTPIndexes = (1,2,3, @@ -108,7 +140,7 @@ Const 14,15,16,17, 18,19,20,21, 22,23,24, - 34,0,36); + 34,0,36) deprecated; @@ -256,88 +288,116 @@ type FCookieFields: TStrings; FHTTPVersion: String; FHTTPXRequestedWith: String; - FFields : THttpFields; + FFields : THeadersArray; + FVariables : THTTPVariables; FQueryFields: TStrings; + FCustomHeaders : TStringList; + function GetCustomHeaders: TStringList; function GetSetField(AIndex: Integer): String; function GetSetFieldName(AIndex: Integer): String; procedure SetCookieFields(const AValue: TStrings); Function GetFieldCount : Integer; Function GetContentLength : Integer; Procedure SetContentLength(Value : Integer); - Function GetFieldIndex(AIndex : Integer) : Integer; + Function GetFieldOrigin(AIndex : Integer; Out H : THeader; V : THTTPVAriableType) : Boolean; Function GetServerPort : Word; Procedure SetServerPort(AValue : Word); Function GetSetFieldValue(Index : Integer) : String; virtual; + // These are private, because we need to know for sure the index is in the correct enumerated. + Function GetHeaderValue(AIndex : Integer) : String; + Procedure SetHeaderValue(AIndex : Integer; AValue : String); + procedure SetHTTPVariable(AIndex: Integer; AValue: String); + Function GetHTTPVariable(AIndex : Integer) : String; Protected - Function GetFieldValue(Index : Integer) : String; virtual; - Procedure SetFieldValue(Index : Integer; Value : String); virtual; + // Kept for backwards compatibility + Class Function IndexToHTTPHeader (AIndex : Integer) : THeader; + Class Function IndexToHTTPVariable (AIndex : Integer) : THTTPVariableType; + procedure SetHTTPVariable(AVariable : THTTPVariableType; AValue: String); + Function GetFieldValue(Index : Integer) : String; virtual; deprecated; + Procedure SetFieldValue(Index : Integer; Value : String); virtual; deprecated; procedure ParseFirstHeaderLine(const line: String);virtual; Procedure ParseCookies; virtual; public constructor Create; virtual; destructor Destroy; override; + // This is the clean way to get HTTP headers. + Function HeaderIsSet(AHeader : THeader) : Boolean; + Function GetHeader(AHeader : THeader) : String; + Procedure SetHeader(AHeader : THeader; Const AValue : String); + // Get/Set a field by name. These calls handle 'known' fields. For unknown fields, Get/SetCustomheader is called. procedure SetFieldByName(const AName, AValue: String); - function GetFieldByName(const AName: String): String; + function GetFieldByName(const AName: String): String; + // Variables + Class Function GetVariableHeaderName(AVariable : THTTPVariableType) : String; + Function GetHTTPVariable(AVariable : THTTPVariableType) : String; + // Get/Set custom headers. + Function GetCustomHeader(const Name: String) : String; virtual; + Procedure SetCustomHeader(const Name, Value: String); virtual; Function LoadFromStream(Stream : TStream; IncludeCommand : Boolean) : integer; Function LoadFromStrings(Strings: TStrings; IncludeCommand : Boolean) : integer; virtual; // Common access // This is an internal table. We should try to get rid of it, // It requires a lot of duplication. - property FieldCount: Integer read GetFieldCount; - property Fields[AIndex: Integer]: String read GetSetField; - property FieldNames[AIndex: Integer]: String read GetSetFieldName; - property FieldValues[AIndex: Integer]: String read GetSetFieldValue; - // Various properties. - Property HttpVersion : String Index 0 Read GetFieldValue Write SetFieldValue; - Property ProtocolVersion : String Index 0 Read GetFieldValue Write SetFieldValue; - property Accept: String Index 1 read GetFieldValue write SetFieldValue; - property AcceptCharset: String Index 2 Read GetFieldValue Write SetFieldValue; - property AcceptEncoding: String Index 3 Read GetFieldValue Write SetFieldValue; - property AcceptLanguage: String Index 4 Read GetFieldValue Write SetFieldValue; - property Authorization: String Index 5 Read GetFieldValue Write SetFieldValue; - property Connection: String Index 6 Read GetFieldValue Write SetFieldValue; - property ContentEncoding: String Index 7 Read GetFieldValue Write SetFieldValue; - property ContentLanguage: String Index 8 Read GetFieldValue Write SetFieldValue; + property FieldCount: Integer read GetFieldCount; deprecated; + property Fields[AIndex: Integer]: String read GetSetField ; deprecated; + property FieldNames[AIndex: Integer]: String read GetSetFieldName ;deprecated; + property FieldValues[AIndex: Integer]: String read GetSetFieldValue ;deprecated; + // Official HTTP headers. + property Accept: String Index Ord(hhAccept) read GetHeaderValue write SetHeaderValue; + property AcceptCharset: String Index Ord(hhAcceptCharset) Read GetHeaderValue Write SetHeaderValue; + property AcceptEncoding: String Index Ord(hhAcceptEncoding) Read GetHeaderValue Write SetHeaderValue; + property AcceptLanguage: String Index Ord(hhAcceptLanguage) Read GetHeaderValue Write SetHeaderValue; + property Authorization: String Index Ord(hhAuthorization) Read GetHeaderValue Write SetHeaderValue; + property Connection: String Index Ord(hhConnection) Read GetHeaderValue Write SetHeaderValue; + property ContentEncoding: String Index Ord(hhContentEncoding) Read GetHeaderValue Write SetHeaderValue; + property ContentLanguage: String Index Ord(hhContentLanguage) Read GetHeaderValue Write SetHeaderValue; property ContentLength: Integer Read GetContentLength Write SetContentLength; // Index 9 - property ContentType: String Index 10 Read GetFieldValue Write SetFieldValue; - property Cookie: String Index 11 Read GetFieldValue Write SetFieldValue; - property Date: String Index 12 Read GetFieldValue Write SetFieldValue; - property Expires: String Index 13 Read GetFieldValue Write SetFieldValue; - property From: String Index 14 Read GetFieldValue Write SetFieldValue; - property IfModifiedSince: String Index 15 Read GetFieldValue Write SetFieldValue; - property LastModified: String Index 16 Read GetFieldValue Write SetFieldValue; - property Location: String Index 17 Read GetFieldValue Write SetFieldValue; - property Pragma: String Index 18 Read GetFieldValue Write SetFieldValue; - property Referer: String Index 19 Read GetFieldValue Write SetFieldValue; - property RetryAfter: String Index 20 Read GetFieldValue Write SetFieldValue; - property Server: String Index 21 Read GetFieldValue Write SetFieldValue; - property SetCookie: String Index 22 Read GetFieldValue Write SetFieldValue; - property UserAgent: String Index 23 Read GetFieldValue Write SetFieldValue; - property WWWAuthenticate: String Index 24 Read GetFieldValue Write SetFieldValue; - // Various aliases, for compatibility - Property PathInfo : String index 25 read GetFieldValue Write SetFieldValue; - Property PathTranslated : String Index 26 read GetFieldValue Write SetFieldValue; - Property RemoteAddress : String Index 27 read GetFieldValue Write SetFieldValue; - Property RemoteAddr : String Index 27 read GetFieldValue Write SetFieldValue; // Alias, Delphi-compat - Property RemoteHost : String Index 28 read GetFieldValue Write SetFieldValue; - Property ScriptName : String Index 29 read GetFieldValue Write SetFieldValue; + property ContentType: String Index Ord(hhContentType) Read GetHeaderValue Write SetHeaderValue; + property Date: String Index Ord(hhDate) Read GetHeaderValue Write SetHeaderValue; + property Expires: String Index Ord(hhExpires) Read GetHeaderValue Write SetHeaderValue; + property From: String Index Ord(hhFrom) Read GetHeaderValue Write SetHeaderValue; + Property Host : String Index Ord(hhHost) Read GetFieldValue Write SetFieldValue; + property IfModifiedSince: String Index Ord(hhIfModifiedSince) Read GetHeaderValue Write SetHeaderValue; + property LastModified: String Index Ord(hhLastModified) Read GetHeaderValue Write SetHeaderValue; + property Location: String Index Ord(hhLocation) Read GetHeaderValue Write SetHeaderValue; + property Pragma: String Index Ord(hhPragma) Read GetHeaderValue Write SetHeaderValue; + property Referer: String Index Ord(hhReferer) Read GetHeaderValue Write SetHeaderValue; + property RetryAfter: String Index Ord(hhRetryAfter) Read GetHeaderValue Write SetHeaderValue; + property Server: String Index Ord(hhServer) Read GetHeaderValue Write SetHeaderValue; + property UserAgent: String Index Ord(hhUserAgent) Read GetHeaderValue Write SetHeaderValue; + property Warning: String Index Ord(hhWarning) Read GetHeaderValue Write SetHeaderValue; + property WWWAuthenticate: String Index Ord(hhWWWAuthenticate) Read GetHeaderValue Write SetHeaderValue; + property Via: String Index Ord(hhVia) Read GetHeaderValue Write SetHeaderValue; + // HTTP headers, Delphi compatibility + Property HTTPAccept : String Index Ord(hhAccept) read GetFieldValue Write SetFieldValue; + Property HTTPAcceptCharset : String Index Ord(hhAcceptCharset) read GetFieldValue Write SetFieldValue; + Property HTTPAcceptEncoding : String Index Ord(hhAcceptEncoding) read GetFieldValue Write SetFieldValue; + Property HTTPIfModifiedSince : String Index Ord(hhIfModifiedSince) read GetFieldValue Write SetFieldValue; // Maybe change to TDateTime ?? + Property HTTPReferer : String Index Ord(hhReferer) read GetFieldValue Write SetFieldValue; + Property HTTPUserAgent : String Index Ord(hhUserAgent) read GetFieldValue Write SetFieldValue; + // Headers, not in HTTP spec. + property Cookie: String Index Ord(hvCookie) Read GetHTTPVariable Write SetHTTPVariable; + property SetCookie: String Index Ord(hvSetCookie) Read GetHTTPVariable Write SetHTTPVariable; + Property HTTPXRequestedWith : String Index Ord(hvXRequestedWith) read GetHTTPVariable Write SetHTTPVariable; + Property HttpVersion : String Index ord(hvHTTPVErsion) Read GetHTTPVariable Write SetHTTPVariable; + Property ProtocolVersion : String Index ord(hvHTTPVErsion) Read GetHTTPVariable Write SetHTTPVariable; + // Specials, mostly from CGI protocol/Apache. + Property PathInfo : String index Ord(hvPathInfo) read GetHTTPVariable Write SetHTTPVariable; + Property PathTranslated : String index Ord(hvPathInfo) read GetHTTPVariable Write SetHTTPVariable; + Property RemoteAddress : String Index Ord(hvRemoteAddress) read GetHTTPVariable Write SetHTTPVariable; + Property RemoteAddr : String Index Ord(hvRemoteAddress) read GetHTTPVariable Write SetHTTPVariable; // Alias, Delphi-compat + Property RemoteHost : String Index Ord(hvRemoteHost) read GetHTTPVariable Write SetHTTPVariable; + Property ScriptName : String Index Ord(hvScriptName) read GetHTTPVariable Write SetHTTPVariable; Property ServerPort : Word Read GetServerPort Write SetServerPort; // Index 30 - Property HTTPAccept : String Index 1 read GetFieldValue Write SetFieldValue; - Property HTTPAcceptCharset : String Index 2 read GetFieldValue Write SetFieldValue; - Property HTTPAcceptEncoding : String Index 3 read GetFieldValue Write SetFieldValue; - Property HTTPIfModifiedSince : String Index 15 read GetFieldValue Write SetFieldValue; // Maybe change to TDateTime ?? - Property HTTPReferer : String Index 19 read GetFieldValue Write SetFieldValue; - Property HTTPUserAgent : String Index 23 read GetFieldValue Write SetFieldValue; - Property Method : String Index 31 read GetFieldValue Write SetFieldValue; - Property URL : String Index 32 read GetFieldValue Write SetFieldValue; - Property Query : String Index 33 read GetFieldValue Write SetFieldValue; - Property Host : String Index 34 Read GetFieldValue Write SetFieldValue; - Property Content : String Index 35 Read GetFieldValue Write SetFieldValue; - Property HTTPXRequestedWith : String Index 36 read GetFieldValue Write SetFieldValue; + Property Method : String Index Ord(hvMethod) read GetHTTPVariable Write SetHTTPVariable; + Property URL : String Index Ord(hvURL) read GetHTTPVariable Write SetHTTPVariable; + Property Query : String Index Ord(hvQuery) read GetHTTPVariable Write SetHTTPVariable; + Property Content : String Index Ord(hvContent) Read GetHTTPVariable Write SetHTTPVariable; // Lists Property CookieFields : TStrings Read FCookieFields Write SetCookieFields; Property ContentFields: TStrings read FContentFields; property QueryFields : TStrings read FQueryFields; + Property CustomHeaders: TStringList read GetCustomHeaders; end; TOnUnknownEncodingEvent = Procedure (Sender : TRequest; Const ContentType : String;Stream : TStream) of object; @@ -385,17 +445,24 @@ type public constructor Create; override; destructor destroy; override; - Function GetNextPathInfo : String; - Property ReturnedPathInfo : String Read FReturnedPathInfo Write FReturnedPathInfo; - Property LocalPathPrefix : string Read GetLocalPathPrefix; - Property CommandLine : String Read FCommandLine; - Property Command : String read FCommand; - Property URI : String read FURI; // Uniform Resource Identifier - Property QueryString : String Index 33 read GetFieldValue Write SetFieldValue; // Alias - Property HeaderLine : String read GetFirstHeaderLine; - Property Files : TUploadedFiles Read FFiles; - Property HandleGetOnPost : Boolean Read FHandleGetOnPost Write FHandleGetOnPost; - Property OnUnknownEncoding : TOnUnknownEncodingEvent Read FOnUnknownEncoding Write FOnUnknownEncoding; + Function GetNextPathInfo : String; + Property ReturnedPathInfo : String Read FReturnedPathInfo Write FReturnedPathInfo; + Property LocalPathPrefix : string Read GetLocalPathPrefix; + Property CommandLine : String Read FCommandLine; + Property Command : String read FCommand; + Property URI : String read FURI; // Uniform Resource Identifier + Property QueryString : String Index Ord(hvQuery) read GetHTTPVariable Write SetHTTPVariable; + Property HeaderLine : String read GetFirstHeaderLine; + Property Files : TUploadedFiles Read FFiles; + Property HandleGetOnPost : Boolean Read FHandleGetOnPost Write FHandleGetOnPost; + Property OnUnknownEncoding : TOnUnknownEncodingEvent Read FOnUnknownEncoding Write FOnUnknownEncoding; + Property IfMatch : String Index ord(hhIfMatch) Read GetHeaderValue Write SetHeaderValue; + Property IfNoneMatch : String Index ord(hhIfNoneMatch) Read GetHeaderValue Write SetHeaderValue; + Property IfRange : String Index ord(hhIfRange) Read GetHeaderValue Write SetHeaderValue; + Property IfUnModifiedSince : String Index ord(hhIfUnmodifiedSince) Read GetHeaderValue Write SetHeaderValue; + Property ContentRange : String Index ord(hhContentRange) Read GetHeaderValue Write SetHeaderValue; + Property TE : String Index ord(hhTE) Read GetHeaderValue Write SetHeaderValue; + Property Upgrade : String Index ord(hhUpgrade) Read GetHeaderValue Write SetHeaderValue; end; @@ -403,7 +470,6 @@ type TResponse = class(THttpHeader) private - FCacheControl: String; FContents: TStrings; FContentStream : TStream; FCode: Integer; @@ -413,7 +479,6 @@ type FContentSent: Boolean; FRequest : TRequest; FCookies : TCookies; - FCustomHeaders : TStringList; function GetContent: String; procedure SetContent(const AValue: String); procedure SetContents(AValue: TStrings); @@ -431,13 +496,19 @@ type Procedure SendContent; Procedure SendHeaders; Procedure SendResponse; // Delphi compatibility - Function GetCustomHeader(const Name: String) : String; - Procedure SetCustomHeader(const Name, Value: String); Procedure SendRedirect(const TargetURL:String); Property Request : TRequest Read FRequest; Property Code: Integer Read FCode Write FCode; Property CodeText: String Read FCodeText Write FCodeText; - Property CacheControl : String Read FCacheControl Write FCacheControl; + Property Age : String Index Ord(hhAge) Read GetHeaderValue Write SetHeaderValue; + Property Allow : String Index Ord(hhAllow) Read GetHeaderValue Write SetHeaderValue; + Property CacheControl : String Index Ord(hhCacheControl) Read GetHeaderValue Write SetHeaderValue; + Property ContentLocation : String Index Ord(hhContentLocation) Read GetHeaderValue Write SetHeaderValue; + Property ContentMD5 : String Index Ord(hhContentMD5) Read GetHeaderValue Write SetHeaderValue; + Property ContentRange : String Index Ord(hhContentRange) Read GetHeaderValue Write SetHeaderValue; + Property ETag : String Index Ord(hhEtag) Read GetHeaderValue Write SetHeaderValue; + Property ProxyAuthenticate : String Index Ord(hhProxyAuthenticate) Read GetHeaderValue Write SetHeaderValue; + Property RetryAfter : String Index Ord(hhRetryAfter) Read GetHeaderValue Write SetHeaderValue; Property FirstHeaderLine : String Read GetFirstHeaderLine Write SetFirstHeaderLine; Property ContentStream : TStream Read FContentStream Write SetContentStream; Property Content : String Read GetContent Write SetContent; @@ -445,7 +516,6 @@ type Property HeadersSent : Boolean Read FHeadersSent; Property ContentSent : Boolean Read FContentSent; property Cookies: TCookies read FCookies; - Property CustomHeaders: TStringList read FCustomHeaders; Property FreeContentStream : Boolean Read FFreeContentStream Write FFreeContentStream; end; @@ -521,6 +591,8 @@ Var MimeItemsClass : TMimeItemsClass = TMimeItems; MimeItemClass : TMimeItemClass = nil; +Procedure Touch(Const AName : String); + implementation uses @@ -545,7 +617,12 @@ const { --------------------------------------------------------------------- Auxiliary functions ---------------------------------------------------------------------} - +Procedure Touch(Const AName : String); + +begin + FileClose(FileCreate('/tmp/touch-'+StringReplace(AName,'/','_',[rfReplaceAll]))); +end; + Function GetFieldNameIndex(AName : String) : Integer; var @@ -559,107 +636,22 @@ begin Result:=HTTPFieldIndexes[Result]; end; -function HTTPDecode(const AStr: String): String; - -var - S,SS, R : PChar; - H : String[3]; - L,C : Integer; +Function HTTPDecode(const AStr: String): String; begin - L:=Length(Astr); - SetLength(Result,L); - If (L=0) then - exit; - S:=PChar(AStr); - SS:=S; - R:=PChar(Result); - while (S-SS)0) then - R^:=' '; - end; - end; - end; - end; - else - R^ := S^; - end; - Inc(R); - Inc(S); - end; - SetLength(Result,R-PChar(Result)); + Result:=httpProtocol.HTTPDecode(AStr); end; -function HTTPEncode(const AStr: String): String; +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)0) and (Result[L]<>'/') then - Result:=Result+'/'; + Result:=httpProtocol.IncludeHTTPPathDelimiter(AStr); end; { ------------------------------------------------------------------- @@ -797,16 +789,20 @@ end; THTTPHeader ---------------------------------------------------------------------} -function THttpHeader.GetFieldCount: Integer; +function THTTPHeader.GetFieldCount: Integer; + Var - I : Integer; + h : THeader; begin Result:=0; - For I:=1 to NoHTTPFields do - If (GetFieldValue(i)<>'') then + For H in THeader do + If HeaderIsSet(H) then Inc(Result); + Inc(Result,Ord(FVariables[hvXRequestedWith]<>'')); + Inc(Result,Ord(FVariables[hvSetCookie]<>'')); + Inc(Result,Ord(FVariables[hvCookie]<>'')); end; function THTTPHeader.GetContentLength: Integer; @@ -820,23 +816,47 @@ begin end; -Function THttpHeader.GetFieldIndex(AIndex : Integer) : Integer; +function THTTPHeader.GetFieldOrigin(AIndex: Integer; out H: THeader; + V: THTTPVAriableType): Boolean; + -var - I : Integer; - begin - I:=1; - While (I<=NoHTTPFields) and (AIndex>=0) do + V:=hvUnknown; + H:=Succ(hhUnknown); + While (H<=High(THeader)) and (AIndex>=0) do begin - If (GetFieldValue(i)<>'') then + If (GetHeader(H)<>'') then Dec(AIndex); - Inc(I); + H:=Succ(H); end; - If (AIndex=-1) then - Result:=I-1 - else - Result:=-1; + Result:=(AIndex<0); + if Result then + begin + H:=Pred(H); + Exit; + end; + h:=hhUnknown; + if (AIndex>=0) then + begin + H:=hhUnknown; + V:=hvXRequestedWith; + if (FVariables[V]<>'') then + Dec(AIndex); + end; + if (AIndex>=0) then + begin + V:=hvSetCookie; + if (FVariables[V]<>'') then + Dec(AIndex); + end; + if (AIndex>=0) then + begin + V:=hvCookie; + if (FVariables[V]<>'') then + Dec(AIndex); + end; + Result:=(AIndex<0); + if not Result then V:=hvUnknown end; function THTTPHeader.GetServerPort: Word; @@ -844,7 +864,19 @@ begin Result:=StrToIntDef(GetFieldValue(30),0); end; -Procedure THTTPHeader.SetServerPort(AValue : Word); +procedure THTTPHeader.SetHTTPVariable(AIndex: Integer; AValue: String); +begin + if (AIndex>=0) and (Aindex<=Ord(High(THTTPVariableType))) then + SetHTTPVariable(THTTPVariableType(AIndex),AValue); +end; + +procedure THTTPHeader.SetHTTPVariable(AVariable: THTTPVariableType; AValue: String); +begin + Touch(GetEnumName(TypeInfo(THTTPVariableType),Ord(AVariable))+'='+AValue); + FVariables[AVariable]:=AValue +end; + +procedure THTTPHeader.SetServerPort(AValue: Word); begin SetFieldValue(30,IntToStr(AValue)); @@ -853,46 +885,138 @@ end; function THTTPHeader.GetSetFieldValue(Index: Integer): String; Var - I : Integer; + H : THeader; + V : THTTPVariableType; begin - I:=GetFieldIndex(Index); - If (I<>-1) then - Result:=GetFieldValue(I); + if GetFieldOrigin(Index,H,V) then + begin + if H<>hhUnknown then + Result:=GetHeader(H) + else if V<>hVUnknown then + Result:=GetHTTPVariable(V); + end; +end; + +function THTTPHeader.GetHeaderValue(AIndex: Integer): String; +begin + if (AIndex>=0) and (AIndex<=Ord(High(THeader))) then + Result:=GetHeader(THeader(AIndex)) + else + Result:=''; +end; + +procedure THTTPHeader.SetHeaderValue(AIndex: Integer; AValue: String); +begin + if (AIndex>=0) and (AIndex<=Ord(High(THeader))) then + SetHeader(THeader(AIndex),AValue); +end; + +function THTTPHeader.GetHTTPVariable(AVariable: THTTPVariableType): String; + +begin + Result:=FVariables[AVariable]; +end; + +function THTTPHeader.GetHTTPVariable(AIndex: Integer): String; +begin + if (AIndex>=0) and (AIndex<=Ord(High(THTTPVariableType))) then + Result:=GetHTTPVariable(THTTPVariableType(AIndex)) + else + Result:=''; +end; + +class function THTTPHeader.IndexToHTTPHeader(AIndex: Integer): THeader; + +Const + IDX : Array[THeader] of Integer = + (-1, + 1,2,3,4, + -1,-1,-1,5,-1, + 6,7,8, + 9,-1,-1,-1, + 10,12,-1,13,-1, + 14,34,-1,15,-1, + -1,-1,16,17,-1, + 18,-1,-1,-1,19, + 20,21,-1,-1, + -1,-1,23,-1, + -1,-1,24); + +begin + Result:=High(THeader); + While (Result>hhUnknown) and (IDX[Result]<>AIndex) do + Result:=Pred(Result); +end; + +class function THTTPHeader.IndexToHTTPVariable(AIndex: Integer + ): THTTPVariableType; + +Const + IDX : Array[THTTPVariableType] of Integer = + (-1, + 0,31,11,22,36, + 25,26,27,28,29, + 30,32,33,35); + +begin + Result:=High(THTTPVariableType); + While (Result>hvUnknown) and (IDX[Result]<>AIndex) do + Result:=Pred(Result); end; function THTTPHeader.GetSetField(AIndex: Integer): String; -var - I : Integer; + +Var + H : THeader; + V : THTTPVariableType; begin - I:=GetFieldIndex(AIndex); - If (I<>-1) then - Result := HTTPFieldNames[I] + ': ' + GetFieldValue(I); + if GetFieldOrigin(AIndex,H,V) then + if H<>hhUnknown then + Result:=HTTPHeaderNames[H]+': '+GetHeader(H) + else if V<>hVUnknown then + Result:=GetVariableHeaderName(V)+': '+GetHTTPVariable(V); +end; + +function THTTPHeader.GetCustomHeaders: TStringList; +begin + If FCustomHeaders=Nil then + FCustomHeaders:=TStringList.Create; + Result:=FCustomHeaders; end; function THTTPHeader.GetSetFieldName(AIndex: Integer): String; -var - I : Integer; + +Var + H : THeader; + V : THTTPVariableType; begin - I:=GetFieldIndex(AIndex); - if (I<>-1) then - Result:=HTTPFieldNames[I]; + if GetFieldOrigin(AIndex,H,V) then + if H<>hhUnknown then + Result:=HTTPHeaderNames[H] + else + Result:=GetVariableHeaderName(V); end; -Function THttpHeader.GetFieldValue(Index : Integer) : String; +function THTTPHeader.GetFieldValue(Index: Integer): String; + +Var + H : THeader; + V : THTTPVariableType; begin - if (Index>=1) and (Index<=NoHTTPFields) then - Result:=FFields[Index] + Result:=''; + H:=IndexToHTTPHeader(Index); + if (H<>hhUnknown) then + Result:=GetHeader(H) else - case Index of - 0 : Result:=FHTTPVersion; - 36 : Result:=FHTTPXRequestedWith; - else - Result := ''; + begin + V:=IndexToHTTPVariable(Index); + if V<>hvUnknown then + Result:=GetHTTPVariable(V) end; end; @@ -902,10 +1026,24 @@ begin end; -Procedure THttpHeader.SetFieldValue(Index : Integer; Value : String); +procedure THTTPHeader.SetFieldValue(Index: Integer; Value: String); + + +Var + H : THeader; + V : THTTPVariableType; begin - if (Index>=1) and (Index<=NoHTTPFields) then + H:=IndexToHTTPHeader(Index); + if (H<>hhUnknown) then + SetHeader(H,Value) + else + begin + V:=IndexToHTTPVariable(Index); + if V<>hvUnknown then + SetHTTPVariable(V,Value) + end; +(* if (Index>=1) and (Index<=NoHTTPFields) then begin FFields[Index]:=Value; If (Index=11) then @@ -922,6 +1060,7 @@ begin 30 : ; // Property ServerPort : Word Read GetServerPort; // Index 30 in TRequest 36 : FHTTPXRequestedWith:=Value; end; +*) end; procedure THTTPHeader.ParseFirstHeaderLine(const line: String); @@ -952,7 +1091,7 @@ begin {$ifdef cgidebug} SendMethodExit('Parsecookies done');{$endif} end; -constructor THttpHeader.Create; +constructor THTTPHeader.Create; begin FCookieFields:=TStringList.Create; FQueryFields:=TStringList.Create; @@ -960,9 +1099,10 @@ begin FHttpVersion := '1.1'; end; -destructor THttpHeader.Destroy; +destructor THTTPHeader.Destroy; begin + FreeAndNil(FCustomHeaders); FreeAndNil(FContentFields); FreeAndNil(FQueryFields); FreeAndNil(FCookieFields); @@ -970,7 +1110,24 @@ begin end; -function THttpHeader.GetFieldByName(const AName: String): String; +function THTTPHeader.HeaderIsSet(AHeader: THeader): Boolean; +begin + Result:=(FFields[AHeader]<>''); +end; + +function THTTPHeader.GetHeader(AHeader: THeader): String; +begin + Result:=FFields[AHeader]; +end; + +procedure THTTPHeader.SetHeader(AHeader: THeader; const AValue: String); +begin + Touch(GetEnumName(TypeInfo(THEader),ORd(AHeader))+'='+AValue); + FFields[AHeader]:=AValue; +end; + + +function THTTPHeader.GetFieldByName(const AName: String): String; var i: Integer; @@ -978,11 +1135,38 @@ begin I:=GetFieldNameIndex(AName); If (I<>0) then Result:=self.GetFieldValue(i) + else + Result:=GetCustomHeader(AName); +end; + +class function THTTPHeader.GetVariableHeaderName(AVariable: THTTPVariableType + ): String; +begin + Case AVariable of + hvSetCookie : Result:=HeaderSetCookie; + hvCookie : Result:=HeaderCookie; + hvXRequestedWith : Result:=HeaderXRequestedWith; + end; +end; + +function THTTPHeader.GetCustomHeader(const Name: String): String; +begin + if Assigned(FCustomHeaders) then + Result:=CustomHeaders.Values[Name] else Result:=''; end; -Function THTTPHeader.LoadFromStream(Stream: TStream; IncludeCommand : Boolean) : Integer; +procedure THTTPHeader.SetCustomHeader(const Name, Value: String); +begin + if GetCustomHeader(Name) = '' then + CustomHeaders.Add(Name + '=' + Value) + else + CustomHeaders.Values[Name] := Value; +end; + +function THTTPHeader.LoadFromStream(Stream: TStream; IncludeCommand: Boolean + ): integer; Var S : TStrings; @@ -997,7 +1181,8 @@ begin end; end; -Function THTTPHeader.LoadFromStrings(Strings: TStrings; IncludeCommand : Boolean) : integer; +function THTTPHeader.LoadFromStrings(Strings: TStrings; IncludeCommand: Boolean + ): integer; Var P : Integer; @@ -1029,14 +1214,16 @@ begin end; end; -procedure THttpHeader.SetFieldByName(const AName, AValue: String); +procedure THTTPHeader.SetFieldByName(const AName, AValue: String); var i: Integer; begin I:=GetFieldNameIndex(AName); If (I<>0) then - SetFieldValue(i,AValue); + SetFieldValue(i,AValue) + else + SetCustomHeader(AName,AValue); end; { --------------------------------------------------------------------- @@ -1617,7 +1804,7 @@ end; procedure TRequest.InitContent(var AContent: String); begin - FContent:=AContent; + FVariables[hvContent]:=AContent; FContentRead:=True; end; @@ -1824,7 +2011,6 @@ begin FreeAndNil(FContentStream); FreeAndNil(FCookies); FreeAndNil(FContents); - FreeAndNil(FCustomHeaders); inherited destroy; end; @@ -1865,18 +2051,6 @@ begin SendContent; end; -function TResponse.GetCustomHeader(const Name: String): String; -begin - Result := FCustomHeaders.Values[Name]; -end; - -procedure TResponse.SetCustomHeader(const Name, Value: String); -begin - if GetCustomHeader(Name) = '' then - FCustomHeaders.Add(Name + '=' + Value) - else - FCustomHeaders.Values[Name] := Value; -end; procedure TResponse.SendRedirect(const TargetURL: String); begin @@ -1964,6 +2138,8 @@ procedure TResponse.CollectHeaders(Headers: TStrings); Var I : Integer; + H : THeader; + N,V : String; begin Headers.add(Format('Status: %d %s',[Code,CodeText])); @@ -1975,11 +2151,17 @@ begin SendInteger('Nr of cookies',FCookies.Count); {$endif} For I:=0 to FCookies.Count-1 do - Headers.Add('Set-Cookie: '+FCookies[i].AsString); - For I:=0 to FieldCount-1 do - Headers.Add(Fields[i]); - For I:=0 to FCustomHeaders.Count - 1 do if FCustomHeaders[I] <> '' then - Headers.Add(FCustomHeaders.Names[I] + ': ' + FCustomHeaders.ValueFromIndex[I]); + Headers.Add(HeaderSetCookie+': '+FCookies[i].AsString); + For H in THeader do + if (hdResponse in HTTPHeaderDirections[H]) and HeaderIsSet(H) then + Headers.Add(HTTPHeaderNames[H]+': '+GetHeader(H)); + if Assigned(FCustomHeaders) then + For I:=0 to FCustomHeaders.Count - 1 do + begin + FCustomHeaders.GetNameValue(I,N,V); + if (V<>'') then + Headers.Add(N+': '+V); + end; Headers.Add(''); {$ifdef cgidebug} SendMethodExit('Collectheaders');{$endif} end; diff --git a/packages/fcl-web/src/base/httpprotocol.pp b/packages/fcl-web/src/base/httpprotocol.pp new file mode 100644 index 0000000000..d081c84627 --- /dev/null +++ b/packages/fcl-web/src/base/httpprotocol.pp @@ -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)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)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. + diff --git a/packages/fcl-web/src/base/webutil.pp b/packages/fcl-web/src/base/webutil.pp index 313a2283a6..71d0d590ab 100644 --- a/packages/fcl-web/src/base/webutil.pp +++ b/packages/fcl-web/src/base/webutil.pp @@ -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('

All possible request headers:

'); + Add('

HTTP 1.1 request headers:

'); Add(''); - 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('
HeaderValue

'); - // Actually sent headers Add('

Actually sent request headers:

'); Add(''); - 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('
HeaderValue

'); // Actually sent headers, as text Add('

Actually sent request headers as text:

'); - For I:=0 to FieldCount-1 do - Add(Fields[I]+'
'); - + Add('
');
+    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('
'); // Additional headers - Add('

Additional headers:

'); + Add('

Additional protocol variables:

'); Add(''); AddNV('PathInfo',PathInfo); AddNV('PathTranslated',PathTranslated);
HeaderValue