paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 05:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add crossoriginisolation and debugcapture

Browse Source
This commit is contained in:
Michaël Van Canneyt 2022-10-19 22:56:07 +02:00
parent e142953c6d
commit 9e60c686b4
1 changed files with 147 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
utils/pas2js/httpcompiler.pp
View File

@ -79,10 +79,19 @@ Type
Destructor Destroy; override;
end;
{ TMySimpleFileModule }
TMySimpleFileModule = class(TSimpleFileModule)
Public
Procedure SendFile(const AFileName: String; AResponse: TResponse); override;
end;
{ THTTPCompilerApplication }
THTTPCompilerApplication = Class(TCustomHTTPApplication)
private
FCaptureFileName : String;
FCaptureStream : TFileStream;
FAPI: String;
FBaseDir: String;
FConfigFile: String;
@ -101,11 +110,17 @@ Type
FPassword:String;
FEcho:Boolean;
FMaxAge: integer;
FCrossOriginIsolation : Boolean;
FInterfaceAddress : String;
procedure AddToStatus(O: TJSONObject);
procedure DoEcho(ARequest: TRequest; AResponse: TResponse);
procedure DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String);
procedure Doquit(ARequest: TRequest; AResponse: TResponse);
procedure DoCapture(ARequest: TRequest; AResponse: TResponse);
function GetCaptureJSON(ARequest: TRequest; AResponse: TResponse; var aJSON: TJSONData): TJSONArray;
procedure SetupCapture(const aFileName: string);
procedure ShowCaptureOutput(aJSON: TJSONData);
function HandleCompileOptions(aDir: String): Boolean;
function ProcessOptions: Boolean;
procedure ReadConfigFile(const ConfigFile: string);
@ -143,6 +158,17 @@ Implementation
uses strutils;
{ TMySimpleFileModule }
procedure TMySimpleFileModule.SendFile(const AFileName: String; AResponse: TResponse);
begin
AResponse.SetCustomHeader('Cross-Origin-Embedder-Policy','require-corp');
AResponse.SetCustomHeader('Cross-Origin-Opener-Policy','same-origin');
inherited SendFile(AFileName, AResponse);
end;
{ TCompileThread }
procedure TCompileThread.SetItem(AValue: TCompileItem);
@ -288,9 +314,12 @@ begin
Writeln('-I --interface=IP Listen on this interface address only.');
Writeln('-m --mimetypes=file Set Filename for loading mimetypes. Default is ',GetDefaultMimeTypesFile);
Writeln('-n --noindexpage Do not allow index page.');
Writeln('-o --coi Enable Cross-Origin Isolation headers');
Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)');
Writeln('-q --quiet Do not write diagnostic messages');
Writeln('-s --simpleserver Only serve files, do not enable compilation.');
Writeln('-u --capture[=FILE] Set up /debugcapture route to capture output sent by browser.');
Writeln(' If FILE is specified, write to file. If not specified, writes to STDOUT.');
Writeln('-w --watch Watch directory for changes');
Halt(Ord(Msg<>''));
{AllowWriteln-}
@ -638,6 +667,9 @@ begin
end;
end;
Const
SCaptureRoute = '/debugcapture';
procedure THTTPCompilerApplication.ReadConfigFile(Const ConfigFile : string);
Const
@ -659,6 +691,9 @@ Const
KeyBackground = 'background';
KeyMaxAge = 'MaxAge';
KeyAPI = 'API';
KeyCOI = 'CrossOriginIsolation';
KeyCapture = 'DebugCapture';
Var
L : TStringList;
@ -684,6 +719,13 @@ begin
FEcho:=ReadBool(SConfig,KeyEcho,FEcho);
FMaxAge:=ReadInteger(SConfig,KeyMaxAge,FMaxAge);
FAPI:=ReadString(SConfig,keyAPI,'');
FCrossOriginIsolation:=ReadBool(SConfig,KeyCOI,FCrossOriginIsolation);
if ValueExists(SConfig,KeyCapture) then
begin
FCaptureFileName:=ReadString(SConfig,keyCapture,'');
if FCaptureFileName='' then
FCaptureFileName:='-';
end;
L:=TstringList.Create;
ReadSectionValues(SProxy,L,[]);
For I:=0 to L.Count-1 do
@ -759,6 +801,13 @@ begin
Log(etInfo,'Using index page %s',[IndexPage]);
TSimpleFileModule.IndexPageName:=IndexPage;
end;
FCrossOriginIsolation:=hasOption('o','coi');
if HasOption('u','capture') then
begin
FCaptureFileName:=GetOptionValue('u','capture');
if FCaptureFileName='' then
FCaptureFileName:='-';
end;
Result:=True;
end;
@ -768,7 +817,7 @@ Var
S : String;
begin
S:=Checkoptions('shqVd:ni:p:wP::cm:A:I:',['help','quiet','version','noindexpage','directory:','port:','indexpage:','watch','project::','config:','simpleserver','mimetypes:','api:','interface:']);
S:=Checkoptions('shqVd:ni:p:wP::cm:A:I:u::',['help','quiet','version','noindexpage','directory:','port:','indexpage:','watch','project::','config:','simpleserver','mimetypes:','api:','interface:','capture']);
if (S<>'') or HasOption('h','help') then
Usage(S);
if HasOption('V','version') then
@ -799,6 +848,8 @@ begin
{$endif}
end;
// Handle options
if FCaptureFileName<>'' then
SetupCapture(FCaptureFileName);
if FPassword<>'' then
HTTPRouter.RegisterRoute('/quit',rmAll,@Doquit,False);
if FEcho then
@ -820,6 +871,8 @@ begin
{$ELSE}
Log(etError,'API support missing, Compile with fpc 3.3.1+');
{$ENDIF}
if FCrossOriginIsolation then
TSimpleFileModule.DefaultSimpleFileModuleClass:=TMySimpleFileModule;
TSimpleFileModule.RegisterDefaultRoute;
if InterfaceAddress<>'' then
HTTPHandler.Address:=InterfaceAddress;
@ -834,4 +887,97 @@ begin
end;
end;
function THTTPCompilerApplication.GetCaptureJSON(ARequest: TRequest;
AResponse: TResponse; var aJSON: TJSONData): TJSONArray;
var
aJSONObj : TJSONObject absolute aJSON;
Cont : String;
begin
Result:=Nil;
aJSON:=Nil;
try
Cont:=aRequest.Content;
aJSON:=GetJSON(Cont);
if aJSON.JSONType<>jtObject then
Raise EHTTP.Create('No JSON object in capture JSON');
Result:=aJSONObj.Get('lines',TJSONArray(Nil));
if Result=Nil then
begin
FreeAndNil(aJSON);
Raise EHTTP.Create('No lines element in capture JSON');
end;
except
On E : Exception do
begin
DoLog(etError,Format('Exception %s (%s) : Invalid capture content: not valid JSON: %s',[E.ClassName,E.Message,Copy(Cont,1,255)]));
aResponse.Code:=400;
aResponse.CodeText:='INVALID PARAM';
aResponse.SendResponse;
end;
end;
end;
procedure THTTPCompilerApplication.ShowCaptureOutput(aJSON : TJSONData);
var
S : TJSONStringType;
begin
if aJSON.JSONType in StructuredJSONTypes then
S:=aJSON.AsJSON
else
S:=aJSON.AsString;
if Assigned(FCaptureStream) then
begin
S:=S+sLineBreak;
FCaptureStream.WriteBuffer(S[1],Length(S)*SizeOf(TJSONCharType));
end
else
DoLog(etInfo,'Capture : '+S);
end;
procedure THTTPCompilerApplication.DoCapture(ARequest: TRequest; AResponse: TResponse);
Var
aJSON : TJSONData;
aArray : TJSONArray;
I : Integer;
begin
aJSON:=Nil;
aArray:=Nil;
try
aArray:=GetCaptureJSON(aRequest,aResponse,aJSON);
if aArray<>Nil then
begin
For I:=0 to aArray.Count-1 do
ShowCaptureOutput(aArray[i]);
aResponse.Code:=200;
aResponse.CodeText:='OK';
aResponse.SendResponse;
end;
finally
aJSON.Free;
end;
end;
procedure THTTPCompilerApplication.SetupCapture(Const aFileName : string);
Var
Dest : String;
begin
if (aFileName<>'') and (aFileName<>'-') then
begin
FCaptureStream:=TFileStream.Create(aFileName,fmCreate);
Dest:='file: '+aFileName
end
else
Dest:='console';
DoLog(etInfo,Format('Setting up capture on route "%s", writing to %s',[SCaptureRoute,Dest]));
HTTPRouter.RegisterRoute(SCaptureRoute,rmPost,@DoCapture,False);
end;
end.