paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 17:19:33 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Merging revisions r44304,r44305 from trunk:

Browse Source 
------------------------------------------------------------------------
    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 -
This commit is contained in:
michael 2020-08-23 09:17:38 +00:00
parent c6fafb7325
commit c3b58bac34
14 changed files with 385 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
packages/fcl-web/examples/jsonrpc/demo1/demo.lpi
View File

@ -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">

11
packages/fcl-web/examples/jsonrpc/demo1/wmdemo.lfm
View File

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

43
packages/fcl-web/examples/jsonrpc/demo1/wmdemo.pp
View File

@ -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.

1
packages/fcl-web/examples/jsonrpc/extdirect/extdemo.lpi
View File

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

4
packages/fcl-web/examples/jsonrpc/extdirect/wmext.lfm
View File

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

15
packages/fcl-web/examples/jsonrpc/extdirect/wmext.pp
View File

@ -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.

44
packages/fcl-web/src/base/fphtml.pp
View File

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

23
packages/fcl-web/src/base/fphttp.pp
View File

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

53
packages/fcl-web/src/base/fpweb.pp
View File

@ -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}

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

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

83
packages/fcl-web/src/jsonrpc/fpextdirect.pp
View File

@ -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.

1
packages/fcl-web/src/jsonrpc/fpjsonrpc.pp
View File

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

51
packages/fcl-web/src/jsonrpc/webjsonrpc.pp
View File

@ -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 }

28
packages/fcl-web/src/webdata/fpwebdata.pp
View File

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