From c3b58bac34e7b62486994746a4c210d387d5458a Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 23 Aug 2020 09:17:38 +0000 Subject: [PATCH] * Merging revisions r44304,r44305 from trunk: ------------------------------------------------------------------------ r44304 | michael | 2020-03-16 20:38:57 +0100 (Mon, 16 Mar 2020) | 1 line * Common CORS handling ------------------------------------------------------------------------ r44305 | michael | 2020-03-16 20:41:05 +0100 (Mon, 16 Mar 2020) | 1 line * Enable CORS ------------------------------------------------------------------------ git-svn-id: branches/fixes_3_2@46581 - --- .../fcl-web/examples/jsonrpc/demo1/demo.lpi | 44 ++---- .../fcl-web/examples/jsonrpc/demo1/wmdemo.lfm | 11 +- .../fcl-web/examples/jsonrpc/demo1/wmdemo.pp | 43 ++--- .../examples/jsonrpc/extdirect/extdemo.lpi | 1 + .../examples/jsonrpc/extdirect/wmext.lfm | 4 + .../examples/jsonrpc/extdirect/wmext.pp | 15 +- packages/fcl-web/src/base/fphtml.pp | 44 +++--- packages/fcl-web/src/base/fphttp.pp | 23 +++ packages/fcl-web/src/base/fpweb.pp | 53 ++++--- packages/fcl-web/src/base/httpdefs.pp | 149 +++++++++++++++++- packages/fcl-web/src/jsonrpc/fpextdirect.pp | 83 ++++++---- packages/fcl-web/src/jsonrpc/fpjsonrpc.pp | 1 + packages/fcl-web/src/jsonrpc/webjsonrpc.pp | 51 +++--- packages/fcl-web/src/webdata/fpwebdata.pp | 28 ++-- 14 files changed, 385 insertions(+), 165 deletions(-) diff --git a/packages/fcl-web/examples/jsonrpc/demo1/demo.lpi b/packages/fcl-web/examples/jsonrpc/demo1/demo.lpi index 8517a1ddf6..392a6d5353 100644 --- a/packages/fcl-web/examples/jsonrpc/demo1/demo.lpi +++ b/packages/fcl-web/examples/jsonrpc/demo1/demo.lpi @@ -1,15 +1,15 @@ - + - + + - <ResourceType Value="res"/> <UseXPManifest Value="True"/> @@ -17,51 +17,47 @@ <VersionInfo> <Language Value=""/> <CharSet Value=""/> - <StringTable ProductVersion=""/> </VersionInfo> <BuildModes Count="1"> <Item1 Name="default" Default="True"/> </BuildModes> <PublishOptions> <Version Value="2"/> - <IgnoreBinaries Value="False"/> - <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> - <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> </PublishOptions> <RunParams> <local> - <FormatVersion Value="1"/> - <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> </local> + <FormatVersion Value="2"/> + <Modes Count="1"> + <Mode0 Name="default"> + <local> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </Mode0> + </Modes> </RunParams> - <RequiredPackages Count="3"> + <RequiredPackages Count="1"> <Item1> - <PackageName Value="WebLaz"/> - </Item1> - <Item2> - <PackageName Value="LCL"/> - </Item2> - <Item3> <PackageName Value="FCL"/> - </Item3> + </Item1> </RequiredPackages> <Units Count="2"> <Unit0> <Filename Value="demo.lpr"/> <IsPartOfProject Value="True"/> - <UnitName Value="demo"/> </Unit0> <Unit1> <Filename Value="wmdemo.pp"/> <IsPartOfProject Value="True"/> - <ComponentName Value="FPWebModule1"/> + <ComponentName Value="EchoModule"/> + <HasResources Value="True"/> <ResourceBaseClass Value="DataModule"/> - <UnitName Value="wmdemo"/> </Unit1> </Units> </ProjectOptions> <CompilerOptions> - <Version Value="10"/> + <Version Value="11"/> <SearchPaths> <IncludeFiles Value="$(ProjOutDir)"/> </SearchPaths> @@ -70,12 +66,6 @@ <UseHeaptrc Value="True"/> </Debugging> </Linking> - <Other> - <CompilerMessages> - <UseMsgFile Value="True"/> - </CompilerMessages> - <CompilerPath Value="$(CompPath)"/> - </Other> </CompilerOptions> <Debugging> <Exceptions Count="3"> diff --git a/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.lfm b/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.lfm index 22c8cc75b7..ae918c6d47 100644 --- a/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.lfm +++ b/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.lfm @@ -1,4 +1,4 @@ -object FPWebModule1: TFPWebModule1 +object EchoModule: TEchoModule OnCreate = DataModuleCreate OldCreateOrder = False Actions = < @@ -6,41 +6,50 @@ object FPWebModule1: TFPWebModule1 Name = 'Manual' Default = True OnRequest = TFPWebActions0Request + Template.AllowTagParams = False end item Name = 'Dispatch' Default = False OnRequest = TFPWebActions1Request + Template.AllowTagParams = False end item Name = 'Registered' Default = False OnRequest = TFPWebActions2Request + Template.AllowTagParams = False end item Name = 'ExtDirect' Default = False OnRequest = TFPWebActions3Request + Template.AllowTagParams = False end item Name = 'Content' Default = False OnRequest = TFPWebActions4Request + Template.AllowTagParams = False end item Name = 'ExtDirectAPI' Default = False OnRequest = TFPWebActions5Request + Template.AllowTagParams = False end item Name = 'Module' Default = False OnRequest = TFPWebActions6Request + Template.AllowTagParams = False end> ActionVar = 'Action' CreateSession = False + Kind = wkOneShot Height = 260 HorizontalOffset = 578 VerticalOffset = 373 Width = 442 + PPI = 96 end diff --git a/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.pp b/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.pp index 59ee1b7667..47dc1b509a 100644 --- a/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.pp +++ b/packages/fcl-web/examples/jsonrpc/demo1/wmdemo.pp @@ -5,13 +5,14 @@ unit wmdemo; interface uses - Classes, SysUtils, HTTPDefs, websession, fpHTTP, fpWeb; + Classes, SysUtils, HTTPDefs, fpHTTP, fpWeb, jsonreader; type - { TFPWebModule1 } + { TEchoModule } - TFPWebModule1 = class(TFPWebModule) + TEchoModule = class(TFPWebModule) + procedure DataModuleCreate(Sender: TObject); procedure TFPWebActions0Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); procedure TFPWebActions1Request(Sender: TObject; ARequest: TRequest; @@ -33,17 +34,22 @@ type end; var - FPWebModule1: TFPWebModule1; + EchoModule: TEchoModule; implementation {$R *.lfm} -Uses fpjson,jsonparser,fpjsonrpc,webjsonrpc, fpextdirect; +Uses fpjson,jsonparser,fpjsonrpc,webjsonrpc, jsonscanner, fpextdirect; -{ TFPWebModule1 } +{ TEchoModule } -procedure TFPWebModule1.TFPWebActions0Request(Sender: TObject; +procedure TEchoModule.DataModuleCreate(Sender: TObject); +begin + Cors.Enabled:=True; +end; + +procedure TEchoModule.TFPWebActions0Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { Demo 1. Manually do everything. @@ -64,7 +70,7 @@ begin Err:=Nil; ID:=Nil; try - P:=TJSONParser.Create(ARequest.Content); + P:=TJSONParser.Create(ARequest.Content,[joUTF8]); try Req:=P.Parse; try @@ -117,7 +123,7 @@ begin Handled:=True; end; -procedure TFPWebModule1.TFPWebActions1Request(Sender: TObject; +procedure TEchoModule.TFPWebActions1Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { @@ -142,7 +148,7 @@ begin O:=Disp.Options; Include(O,jdoRequireClass); Disp.Options:=O; - P:= TJSONParser.Create(ARequest.Content); + P:= TJSONParser.Create(ARequest.Content,[joUTF8]); try Req:=P.Parse; try @@ -173,7 +179,7 @@ begin end; -procedure TFPWebModule1.TFPWebActions2Request(Sender: TObject; +procedure TEchoModule.TFPWebActions2Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { Demo 3. Use a dispatcher to dispatch the requests. @@ -195,7 +201,7 @@ begin O:=Disp.Options; Include(O,jdoSearchRegistry); Disp.Options:=O; - P:= TJSONParser.Create(ARequest.Content); + P:= TJSONParser.Create(ARequest.Content,[joUTF8]); try Req:=P.Parse; try @@ -225,7 +231,7 @@ begin end; end; -procedure TFPWebModule1.TFPWebActions3Request(Sender: TObject; +procedure TEchoModule.TFPWebActions3Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { @@ -248,7 +254,7 @@ begin O:=Disp.Options; Include(O,jdoSearchRegistry); Disp.Options:=O; - P:= TJSONParser.Create(ARequest.Content); + P:= TJSONParser.Create(ARequest.Content,[joUTF8]); try Req:=P.Parse; try @@ -279,7 +285,7 @@ begin end; end; -procedure TFPWebModule1.TFPWebActions4Request(Sender: TObject; +procedure TEchoModule.TFPWebActions4Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { @@ -317,7 +323,7 @@ begin end; end; -procedure TFPWebModule1.TFPWebActions5Request(Sender: TObject; +procedure TEchoModule.TFPWebActions5Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { Demo 6. Creating an API response for Ext.Direct @@ -327,7 +333,6 @@ procedure TFPWebModule1.TFPWebActions5Request(Sender: TObject; Var D : TExtDirectDispatcher; - I : Integer; begin JSONRpcHandlerManager.RegisterHandler('test','echo',TJSONRPCEcho); @@ -346,7 +351,7 @@ begin end; end; -procedure TFPWebModule1.TFPWebActions6Request(Sender: TObject; +procedure TEchoModule.TFPWebActions6Request(Sender: TObject; ARequest: TRequest; AResponse: TResponse; var Handled: Boolean); { Demo 6. Using a TJSONRPCModule instance to handle the request. @@ -373,6 +378,6 @@ begin end; initialization - RegisterHTTPModule('echo', TFPWebModule1); + RegisterHTTPModule('echo', TEchoModule); end. diff --git a/packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi b/packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi index 85b0e86643..91d3c48fb2 100644 --- a/packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi +++ b/packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi @@ -63,6 +63,7 @@ </Target> <SearchPaths> <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../../../src/jsonrpc"/> </SearchPaths> </CompilerOptions> <Debugging> diff --git a/packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm b/packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm index ecb823236a..8046eca4b3 100644 --- a/packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm +++ b/packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm @@ -1,11 +1,15 @@ object DemoClass: TDemoClass + OnCreate = DataModuleCreate OldCreateOrder = False + DispatchOptions = [jdoSearchRegistry, jdoSearchOwner, jdoJSONRPC1, jdoJSONRPC2, jdoNotifications] APIPath = 'API' RouterPath = 'Router' + CreateSession = False Height = 313 HorizontalOffset = 548 VerticalOffset = 230 Width = 359 + PPI = 96 object Add: TJSONRPCHandler OnExecute = AddExecute Options = [] diff --git a/packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp b/packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp index dba3e0b465..583374838b 100644 --- a/packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp +++ b/packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp @@ -14,13 +14,11 @@ type TDemoClass = class(TExtDirectModule) Add: TJSONRPCHandler; - procedure AddExecute(Sender: TObject; const Params: TJSONData; out - Res: TJSONData); + procedure AddExecute(Sender: TObject; const Params: TJSONData; out Res: TJSONData); + procedure DataModuleCreate(Sender: TObject); private { private declarations } - public - { public declarations } - end; + end; var DemoClass: TDemoClass; @@ -31,6 +29,7 @@ implementation { TDemoClass } + procedure TDemoClass.AddExecute(Sender: TObject; const Params: TJSONData; out Res: TJSONData); @@ -46,6 +45,12 @@ begin end; end; +procedure TDemoClass.DataModuleCreate(Sender: TObject); +begin + Kind:=wkOneShot; + Cors.Enabled:=True; +end; + initialization RegisterHTTPModule('demo', TDemoClass); end. diff --git a/packages/fcl-web/src/base/fphtml.pp b/packages/fcl-web/src/base/fphtml.pp index c9d84804a2..9cd6375a84 100644 --- a/packages/fcl-web/src/base/fphtml.pp +++ b/packages/fcl-web/src/base/fphtml.pp @@ -519,6 +519,7 @@ type Property OnGetContent; Property OnNewSession; Property OnSessionExpired; + Property CORS; end; EHTMLError = Class(EHTTP); @@ -1166,27 +1167,28 @@ begin FWriter:=CreateWriter(FDocument); Try B:=False; - If Assigned(OnGetContent) then - OnGetContent(Self,ARequest,FWriter,B); - If Not B then - Actions.HandleRequest(ARequest,FWriter,B); - If Not B then - Raise EHTMLError.Create(SErrRequestNotHandled); - If (AResponse.ContentStream=Nil) then - begin - M:=TMemoryStream.Create; - AResponse.ContentStream:=M; - AResponse.FreeContentStream:=True; - end; - if not AResponse.ContentSent then - begin - FDocument.SaveToStream(AResponse.ContentStream); - AResponse.ContentStream.Position:=0; - if (AResponse.ContentType='') then - AResponse.ContentType:='text/html'; - AResponse.ContentLength:=AResponse.ContentStream.Size; - AResponse.SendContent; - end; + if Not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then + If Assigned(OnGetContent) then + OnGetContent(Self,ARequest,FWriter,B); + If Not B then + Actions.HandleRequest(ARequest,FWriter,B); + If Not B then + Raise EHTMLError.Create(SErrRequestNotHandled); + If (AResponse.ContentStream=Nil) then + begin + M:=TMemoryStream.Create; + AResponse.ContentStream:=M; + AResponse.FreeContentStream:=True; + end; + if not AResponse.ContentSent then + begin + FDocument.SaveToStream(AResponse.ContentStream); + AResponse.ContentStream.Position:=0; + if (AResponse.ContentType='') then + AResponse.ContentType:='text/html'; + AResponse.ContentLength:=AResponse.ContentStream.Size; + AResponse.SendContent; + end; Finally FreeAndNil(FWriter); end; diff --git a/packages/fcl-web/src/base/fphttp.pp b/packages/fcl-web/src/base/fphttp.pp index cf420b3d00..053024594e 100644 --- a/packages/fcl-web/src/base/fphttp.pp +++ b/packages/fcl-web/src/base/fphttp.pp @@ -109,11 +109,16 @@ Type private FAfterInitModule : TInitModuleEvent; FBaseURL: String; + FCORS: TCORSSupport; FWebModuleKind: TWebModuleKind; + procedure SetCORS(AValue: TCORSSupport); Protected Class Function DefaultModuleName : String; virtual; Class Function DefaultSkipStreaming : Boolean; virtual; + Class Function CreateCORSSUpport : TCORSSupport; virtual; + Property CORS : TCORSSupport Read FCORS Write SetCORS; public + Constructor CreateNew(aOwner : TComponent; CreateMode: Integer); overload; override; Class Procedure RegisterModule(Const AModuleName : String = ''); overload; Class Procedure RegisterModule(Const AModuleName : String; ASkipStreaming : Boolean); overload; Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); virtual; abstract; @@ -124,6 +129,7 @@ Type end; TCustomHTTPModuleClass = Class of TCustomHTTPModule; + { TSessionHTTPModule } TSessionHTTPModule = Class(TCustomHTTPModule) @@ -286,6 +292,12 @@ end; { TCustomHTTPModule } +procedure TCustomHTTPModule.SetCORS(AValue: TCORSSupport); +begin + if FCORS=AValue then Exit; + FCORS.Assign(AValue); +end; + Class Function TCustomHTTPModule.DefaultModuleName: String; begin Result:=ClassName; @@ -296,6 +308,17 @@ begin Result:=False; end; +class function TCustomHTTPModule.CreateCORSSUpport: TCORSSupport; +begin + Result:=TCORSSupport.Create; +end; + +constructor TCustomHTTPModule.CreateNew(aOwner: TComponent; CreateMode: Integer); +begin + inherited CreateNew(aOwner, CreateMode); + FCORS:=CreateCORSSupport; +end; + Class Procedure TCustomHTTPModule.RegisterModule(Const AModuleName: String); begin RegisterModule(AModuleName,DefaultSkipStreaming); diff --git a/packages/fcl-web/src/base/fpweb.pp b/packages/fcl-web/src/base/fpweb.pp index 85cfca4b97..16de58dc1d 100644 --- a/packages/fcl-web/src/base/fpweb.pp +++ b/packages/fcl-web/src/base/fpweb.pp @@ -164,6 +164,7 @@ Type Property OnNewSession; Property OnSessionExpired; Property AfterInitModule; + Property CORS; end; EFPWebError = Class(EHTTP); @@ -488,31 +489,37 @@ begin {$endif cgidebug} FRequest := ARequest; //So everything in the web module can access the current request variables FResponse := AResponse;//So everything in the web module can access the current response variables - CheckSession(ARequest); - DoBeforeRequest(ARequest); - B:=False; - InitSession(AResponse); - DoOnRequest(ARequest,AResponse,B); - If B then - begin - if not AResponse.ContentSent then - AResponse.SendContent; - end - else - if FTemplate.HasContent then - GetTemplateContent(ARequest,AResponse) - else if HandleActions(ARequest) then + try + CheckSession(ARequest); + DoBeforeRequest(ARequest); + B:=False; + InitSession(AResponse); + if not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then begin - Actions.HandleRequest(ARequest,AResponse,B); - FTemplate.Template := '';//if apache mod, then need to clear for next call because it is a webmodule global property, - FTemplate.FileName := '';//so following calls are OK and the above FTemplate.HasContent is not becoming True - If Not B then - Raise EFPWebError.Create(SErrRequestNotHandled); + DoOnRequest(ARequest,AResponse,B); + If B then + begin + if not AResponse.ContentSent then + AResponse.SendContent; + end + else + if FTemplate.HasContent then + GetTemplateContent(ARequest,AResponse) + else if HandleActions(ARequest) then + begin + Actions.HandleRequest(ARequest,AResponse,B); + FTemplate.Template := '';//if apache mod, then need to clear for next call because it is a webmodule global property, + FTemplate.FileName := '';//so following calls are OK and the above FTemplate.HasContent is not becoming True + If Not B then + Raise EFPWebError.Create(SErrRequestNotHandled); + end; end; - DoAfterResponse(AResponse); - UpdateSession(AResponse); - FRequest := Nil; - FResponse := Nil; + DoAfterResponse(AResponse); + UpdateSession(AResponse); + finally + FRequest := Nil; + FResponse := Nil; + end; // Clean up session for the case the webmodule is used again DoneSession; {$ifdef cgidebug} diff --git a/packages/fcl-web/src/base/httpdefs.pp b/packages/fcl-web/src/base/httpdefs.pp index 9579d0865f..0868e43eae 100644 --- a/packages/fcl-web/src/base/httpdefs.pp +++ b/packages/fcl-web/src/base/httpdefs.pp @@ -29,7 +29,7 @@ unit HTTPDefs; interface -uses typinfo,Classes, Sysutils, httpprotocol; +uses typinfo, Classes, Sysutils, httpprotocol, uriparser; const DefaultTimeOut = 15; @@ -586,6 +586,51 @@ type end; HTTPError = EHTTP; + { CORS Support } + + TCORSOption = (coAllowCredentials, // Set Access-Control-Allow-Credentials header + coEmptyDomainToOrigin // If allowedOrigins is empty, try to determine origin from request and echo that + ); + TCORSOptions = Set of TCORSOption; + + THandleCORSOption = (hcDetect, // Detect OPTIONS request, send full headers + hcFull, // Force sending full headers + hcSend // In case of full headers, send response + ); + THandleCORSOptions = set of THandleCORSOption; + + { TCORSSupport } + + TCORSSupport = Class(TPersistent) + private + FAllowedHeaders: String; + FAllowedMethods: String; + FAllowedOrigins: String; + FMaxAge: Integer; + FEnabled: Boolean; + FOptions: TCORSOptions; + procedure SetAllowedMethods(AValue: String); + Public + Constructor Create; virtual; + function ResolvedCORSAllowedOrigins(aRequest: TRequest): String; virtual; + // Handle CORS headers. Returns TRUE if the full headers were added. + Function HandleRequest(aRequest: TRequest; aResponse: TResponse; aOptions : THandleCORSOptions = [hcDetect]) : Boolean; virtual; + Procedure Assign(Source : TPersistent); override; + Published + // Enable CORS Support ? if False, the HandleRequest will exit at once + Property Enabled : Boolean Read FEnabled Write FEnabled; + // Options that control the behaviour + Property Options : TCORSOptions Read FOptions Write FOptions; + // Allowed methods + Property AllowedMethods : String Read FAllowedMethods Write SetAllowedMethods; + // Domains that are allowed to use this RPC service + Property AllowedOrigins: String Read FAllowedOrigins Write FAllowedOrigins; + // Domains that are allowed to use this RPC service + Property AllowedHeaders: String Read FAllowedHeaders Write FAllowedHeaders; + // Access-Control-Max-Age header value. Set to zero not to send the header + Property MaxAge : Integer Read FMaxAge Write FMaxAge; + end; + Function HTTPDecode(const AStr: String): String; Function HTTPEncode(const AStr: String): String; @@ -598,6 +643,11 @@ Var MimeItemsClass : TMimeItemsClass = TMimeItems; MimeItemClass : TMimeItemClass = nil; +Const + DefaultAllowedHeaders = 'x-requested-with, content-type, authorization'; + DefaultAllowedOrigins = '*'; + DefaultAllowedMethods = 'GET, PUT, POST, OPTIONS, HEAD'; + //Procedure Touch(Const AName : String); implementation @@ -678,6 +728,103 @@ Type Procedure Process(Stream : TStream); override; end; +{ TCORSSupport } + +procedure TCORSSupport.SetAllowedMethods(AValue: String); +begin + aValue:=UpperCase(aValue); + if FAllowedMethods=AValue then Exit; + FAllowedMethods:=AValue; +end; + +constructor TCORSSupport.Create; +begin + FOptions:=[coAllowCredentials,coEmptyDomainToOrigin]; + AllowedHeaders:=DefaultAllowedHeaders; + AllowedOrigins:=DefaultAllowedOrigins; + AllowedMethods:=DefaultAllowedMethods; +end; + +procedure TCORSSupport.Assign(Source: TPersistent); + +Var + CS : TCORSSupport absolute source; + +begin + if (Source is TPersistent) then + begin + Enabled:=CS.Enabled; + Options:=CS.Options; + AllowedHeaders:=CS.AllowedHeaders; + AllowedOrigins:=CS.AllowedOrigins; + AllowedMethods:=CS.AllowedMethods; + MaxAge:=CS.MaxAge; + end + else + inherited Assign(Source); +end; + +function TCORSSupport.ResolvedCORSAllowedOrigins(aRequest : TRequest): String; + +Var + URl : String; + uri : TURI; + +begin + Result:=FAllowedOrigins; + if Result='' then + begin + // Sent with CORS request + Result:=aRequest.GetCustomHeader('Origin'); + if (Result='') and (coEmptyDomainToOrigin in Options) then + begin + // Fallback + URL:=aRequest.Referer; + if (URL<>'') then + begin + uri:=ParseURI(URL,'http',0); + Result:=Format('%s://%s',[URI.Protocol,URI.Host]); + if (URI.Port<>0) then + Result:=Result+':'+IntToStr(URI.Port); + end; + end; + end; + if Result='' then + Result:='*'; +end; + +function TCORSSupport.HandleRequest(aRequest: TRequest; aResponse: TResponse; aOptions: THandleCORSOptions): Boolean; + +Var + S : String; + Full : Boolean; + +begin + Result:=False; + if Not Enabled then + exit; + Full:=(hcFull in aOptions) or ((hcDetect in aOptions) and SameText(aRequest.Method,'OPTIONS')); + With aResponse do + begin + SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins(aRequest)); + if (coAllowCredentials in Options) then + SetCustomHeader('Access-Control-Allow-Credentials','true'); + if Full then + begin + SetCustomHeader('Access-Control-Allow-Methods',AllowedMethods); + SetCustomHeader('Access-Control-Allow-Headers',AllowedHeaders); + if MaxAge>0 then + SetCustomHeader('Access-Control-Max-Age',IntToStr(MaxAge)); + if (hcSend in aOptions) then + begin + Code:=200; + CodeText:='OK'; + SendResponse; + end; + end; + end; +end; + { EHTTP } function EHTTP.GetStatusCode: Integer; diff --git a/packages/fcl-web/src/jsonrpc/fpextdirect.pp b/packages/fcl-web/src/jsonrpc/fpextdirect.pp index f2624175f6..c727d83f73 100644 --- a/packages/fcl-web/src/jsonrpc/fpextdirect.pp +++ b/packages/fcl-web/src/jsonrpc/fpextdirect.pp @@ -20,7 +20,7 @@ unit fpextdirect; interface uses - Classes, SysUtils, fpjson, fpjsonrpc, fpdispextdirect, webjsonrpc, httpdefs; + Classes, SysUtils, fpjson, fpjsonrpc, fpdispextdirect, webjsonrpc, httpdefs, uriparser; Const // Redefinition for backwards compatibility @@ -74,7 +74,12 @@ Type TCustomExtDirectModule = Class(TJSONRPCDispatchModule) private FAPIPath: String; + FCORSAllowCredentials: Boolean; + FCORSAllowedOrigins: String; + FCORSEmptyDomainToOrigin: Boolean; + FCORSMaxAge: Integer; FDispatcher: TCustomExtDirectDispatcher; + FHandleCors: Boolean; FNameSpace: String; FOptions: TJSONRPCDispatchOptions; FRequest: TRequest; @@ -115,6 +120,7 @@ Type Property NameSpace; Property OnNewSession; Property OnSessionExpired; + Property CORS; end; implementation @@ -236,7 +242,6 @@ procedure TCustomExtDirectModule.CreateAPI(ADispatcher : TCustomExtDirectDispatc begin AResponse.Content:=ADispatcher.APIAsString; AResponse.ContentLength:=Length(AResponse.Content); - end; procedure TCustomExtDirectModule.HandleRequest(ARequest: TRequest; @@ -248,39 +253,47 @@ Var R : String; begin - {$ifdef extdebug}SendDebug('Ext.Direct handlerequest: checking session');{$endif} - CheckSession(ARequest); - {$ifdef extdebug}SendDebug('Ext.Direct handlerequest: init session ');{$endif} - InitSession(AResponse); - {$ifdef extdebug}SendDebug('Ext.Direct creating dispatcher');{$endif} - If (Dispatcher=Nil) then - Dispatcher:=CreateDispatcher; - {$ifdef extdebug}SendDebugFmt('Ext.Direct handlerequest: dispatcher class is "%s"',[Dispatcher.Classname]);{$endif} - Disp:=Dispatcher as TCustomExtDirectDispatcher; - R:=ARequest.QueryFields.Values['action']; - If (R='') then - R:=ARequest.GetNextPathInfo; - {$ifdef extdebug}SendDebugFmt('Ext.Direct handlerequest: action is "%s"',[R]);{$endif} - If (CompareText(R,APIPath)=0) then - begin - CreateAPI(Disp,ARequest,AResponse); - UpdateSession(AResponse); - AResponse.SendResponse; - end - else if (CompareText(R,RouterPath)=0) then - begin - Res:=DispatchRequest(ARequest,Disp); - try - UpdateSession(AResponse); - If Assigned(Res) then - AResponse.Content:=Res.AsJSON; - AResponse.SendResponse; - finally - Res.Free; - end; - end - else - JSONRPCError(SErrInvalidPath); + Self.FRequest:=aRequest; + Self.FResponse:=aResponse; + try + {$ifdef extdebug}SendDebug('Ext.Direct handlerequest: checking session');{$endif} + CheckSession(ARequest); + {$ifdef extdebug}SendDebug('Ext.Direct handlerequest: init session ');{$endif} + InitSession(AResponse); + {$ifdef extdebug}SendDebug('Ext.Direct creating dispatcher');{$endif} + If (Dispatcher=Nil) then + Dispatcher:=CreateDispatcher; + {$ifdef extdebug}SendDebugFmt('Ext.Direct handlerequest: dispatcher class is "%s"',[Dispatcher.Classname]);{$endif} + Disp:=Dispatcher as TCustomExtDirectDispatcher; + R:=ARequest.QueryFields.Values['action']; + If (R='') then + R:=ARequest.GetNextPathInfo; + {$ifdef extdebug}SendDebugFmt('Ext.Direct handlerequest: action is "%s"',[R]);{$endif} + if not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then + If (CompareText(R,APIPath)=0) then + begin + CreateAPI(Disp,ARequest,AResponse); + UpdateSession(AResponse); + AResponse.SendResponse; + end + else if (CompareText(R,RouterPath)=0) then + begin + Res:=DispatchRequest(ARequest,Disp); + try + UpdateSession(AResponse); + If Assigned(Res) then + AResponse.Content:=Res.AsJSON; + AResponse.SendResponse; + finally + Res.Free; + end; + end + else + JSONRPCError(SErrInvalidPath); + finally + Self.FRequest:=Nil; + Self.FResponse:=Nil; + end; end; end. diff --git a/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp b/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp index 0d04c89aa4..65262436f3 100644 --- a/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp +++ b/packages/fcl-web/src/jsonrpc/fpjsonrpc.pp @@ -195,6 +195,7 @@ Type jdoStrictNotifications, // Error if notification returned result. Default is to discard result. jdoAllowAPI, // Allow client to get API description jdoCacheAPI // Cache the API description + ); TJSONRPCDispatchOptions = set of TJSONRPCDispatchOption; diff --git a/packages/fcl-web/src/jsonrpc/webjsonrpc.pp b/packages/fcl-web/src/jsonrpc/webjsonrpc.pp index b9cb65cc9e..88d8dd8272 100644 --- a/packages/fcl-web/src/jsonrpc/webjsonrpc.pp +++ b/packages/fcl-web/src/jsonrpc/webjsonrpc.pp @@ -20,7 +20,7 @@ unit webjsonrpc; interface uses - Classes, SysUtils, fpjson, fpjsonrpc, httpdefs, fphttp, jsonparser; + Classes, SysUtils, fpjson, fpjsonrpc, httpdefs, fphttp, jsonparser, uriparser; Type { --------------------------------------------------------------------- @@ -106,6 +106,8 @@ Type Property Response: TResponse Read FResponse; // Response Content-Type. If left empty, application/json is used. Property ResponseContentType : String Read FResponseContentType Write FResponseContentType; + // Must we handle CORS ? + Property CORS; end; { TJSONRPCDataModule } @@ -117,6 +119,7 @@ Type Property Dispatcher; Property DispatchOptions; Property ResponseContentType; + Property CORS; end; implementation @@ -239,6 +242,7 @@ begin Result:=S; end; + procedure TCustomJSONRPCModule.Notification(AComponent: TComponent; Operation: TOperation); begin @@ -265,26 +269,31 @@ Var R : TJSONStringType; begin - If (Dispatcher=Nil) then - Dispatcher:=CreateDispatcher; - Disp:=Dispatcher; - Res:=DispatchRequest(ARequest,Disp); - try - If Assigned(Res) then - begin - AResponse.FreeContentStream:=True; - AResponse.ContentStream:=TMemoryStream.Create; - R:=Res.AsJSON; - if Length(R)>0 then - AResponse.ContentStream.WriteBuffer(R[1],Length(R)); - AResponse.ContentLength:=AResponse.ContentStream.Size; - R:=''; // Free up mem - AResponse.ContentType:=GetResponseContentType; - end; - AResponse.SendResponse; - finally - Res.Free; - end; + if SameText(ARequest.Method,'OPTIONS') then + if not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then + begin + If (Dispatcher=Nil) then + Dispatcher:=CreateDispatcher; + Disp:=Dispatcher; + Res:=DispatchRequest(ARequest,Disp); + try + CORS.HandleRequest(aRequest,aResponse,[]); + If Assigned(Res) then + begin + AResponse.FreeContentStream:=True; + AResponse.ContentStream:=TMemoryStream.Create; + R:=Res.AsJSON; + if Length(R)>0 then + AResponse.ContentStream.WriteBuffer(R[1],Length(R)); + AResponse.ContentLength:=AResponse.ContentStream.Size; + R:=''; // Free up mem + AResponse.ContentType:=GetResponseContentType; + end; + AResponse.SendResponse; + finally + Res.Free; + end; + end; end; { TJSONRPCSessionContext } diff --git a/packages/fcl-web/src/webdata/fpwebdata.pp b/packages/fcl-web/src/webdata/fpwebdata.pp index 340e8ec92b..8d3059fc22 100644 --- a/packages/fcl-web/src/webdata/fpwebdata.pp +++ b/packages/fcl-web/src/webdata/fpwebdata.pp @@ -494,6 +494,7 @@ type Property OnContent; Property OnNewSession; Property OnSessionExpired; + property CORS; end; Var @@ -1730,18 +1731,21 @@ begin {$ifdef wmdebug}SendDebug('Handlerequest, providername : '+Providername);{$endif} AProvider:=GetProvider(ProviderName,AContainer); try - A:=GetAdaptor; - A.Request:=ARequest; - A.Reset; // Force. for wmKind=pooled, fastcgi, request can be the same. - Wa:=A.GetAction; - Case WA of - wdaUnknown : Raise EFPHTTPError.CreateFmt(SErrUnknownProviderAction,[ProviderName]); - wdaRead : ReadWebData(AProvider); - wdaUpdate : UpdateWebData(AProvider); - wdaInsert : InsertWebdata(AProvider); - wdaDelete : DeleteWebData(AProvider); - end; - UpdateSession(AResponse); + If not CORS.HandleRequest(aRequest,aResponse,[hcDetect,hcSend]) then + begin + A:=GetAdaptor; + A.Request:=ARequest; + A.Reset; // Force. for wmKind=pooled, fastcgi, request can be the same. + Wa:=A.GetAction; + Case WA of + wdaUnknown : Raise EFPHTTPError.CreateFmt(SErrUnknownProviderAction,[ProviderName]); + wdaRead : ReadWebData(AProvider); + wdaUpdate : UpdateWebData(AProvider); + wdaInsert : InsertWebdata(AProvider); + wdaDelete : DeleteWebData(AProvider); + end; + UpdateSession(AResponse); + end; finally If (AContainer=Nil) then begin