* 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 -

packages/fcl-web/examples/jsonrpc/demo1/demo.lpi

@@ -1,15 +1,15 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="9"/>
+    <Version Value="12"/>
     <General>
       <Flags>
         <SaveOnlyProjectUnits Value="True"/>
         <MainUnitHasCreateFormStatements Value="False"/>
         <Runnable Value="False"/>
+        <CompatibilityMode Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
       <Title Value="FPC JSON-RPC demo "/>
       <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 &apos;Lazarus Run Output&apos; -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
       </local>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default">
+          <local>
+            <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T &apos;Lazarus Run Output&apos; -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">

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

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.
 

packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi

@@ -63,6 +63,7 @@
     </Target>
     <SearchPaths>
       <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../../../src/jsonrpc"/>
     </SearchPaths>
   </CompilerOptions>
   <Debugging>

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 = []

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.

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;

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);

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}

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;

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.

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;
 

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 }

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