* Common CORS handling

git-svn-id: trunk@44304 -

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

@@ -147,6 +147,7 @@ Type
                             jdoRequireClass, // Require class name (as in Ext.Direct)
                             jdoNotifications, // Allow JSON Notifications
                             jdoStrictNotifications // Error if notification returned result. Default is to discard result.
+
                             );
   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