* Add crossoriginisolation and debugcapture

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.