From 9e60c686b42b79ea69b97aa5376e4e71e8fb333c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= Date: Wed, 19 Oct 2022 22:56:07 +0200 Subject: [PATCH] * Add crossoriginisolation and debugcapture --- utils/pas2js/httpcompiler.pp | 148 ++++++++++++++++++++++++++++++++++- 1 file changed, 147 insertions(+), 1 deletion(-) diff --git a/utils/pas2js/httpcompiler.pp b/utils/pas2js/httpcompiler.pp index 977a50690b..ba77c3aa94 100644 --- a/utils/pas2js/httpcompiler.pp +++ b/utils/pas2js/httpcompiler.pp @@ -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.