mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-07 01:05:56 +02:00
* Rework to use new fpdebugcapture unit
This commit is contained in:
parent
652d41a70a
commit
00330a562c
@ -12,7 +12,7 @@ uses
|
|||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
sysutils, classes, fpjson, contnrs, syncobjs, fpmimetypes, custhttpapp, inifiles,
|
sysutils, classes, fpjson, contnrs, syncobjs, fpmimetypes, custhttpapp, inifiles,
|
||||||
fpwebproxy, webutil, fpwebfile, httproute, httpdefs, dirwatch, Pas2JSFSCompiler,
|
fpwebproxy, webutil, fpwebfile, httproute, httpdefs, dirwatch, Pas2JSFSCompiler,
|
||||||
Pas2JSCompilerCfg, ssockets;
|
Pas2JSCompilerCfg, ssockets, fpdebugcapturesvc;
|
||||||
|
|
||||||
Const
|
Const
|
||||||
HTTPCompilerVersion = '1.0';
|
HTTPCompilerVersion = '1.0';
|
||||||
@ -93,8 +93,6 @@ Type
|
|||||||
|
|
||||||
THTTPCompilerApplication = Class(TCustomHTTPApplication)
|
THTTPCompilerApplication = Class(TCustomHTTPApplication)
|
||||||
private
|
private
|
||||||
FCaptureFileName : String;
|
|
||||||
FCaptureStream : TFileStream;
|
|
||||||
FAPI: String;
|
FAPI: String;
|
||||||
FBaseDir: String;
|
FBaseDir: String;
|
||||||
FConfigFile: String;
|
FConfigFile: String;
|
||||||
@ -119,11 +117,7 @@ Type
|
|||||||
procedure DoEcho(ARequest: TRequest; AResponse: TResponse);
|
procedure DoEcho(ARequest: TRequest; AResponse: TResponse);
|
||||||
procedure DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String);
|
procedure DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String);
|
||||||
procedure Doquit(ARequest: TRequest; AResponse: TResponse);
|
procedure Doquit(ARequest: TRequest; AResponse: TResponse);
|
||||||
procedure DoCapture(ARequest: TRequest; AResponse: TResponse);
|
procedure SetupCapture;
|
||||||
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 HandleCompileOptions(aDir: String): Boolean;
|
||||||
function ProcessOptions: Boolean;
|
function ProcessOptions: Boolean;
|
||||||
procedure ReadConfigFile(const ConfigFile: string);
|
procedure ReadConfigFile(const ConfigFile: string);
|
||||||
@ -698,7 +692,7 @@ Const
|
|||||||
|
|
||||||
Var
|
Var
|
||||||
L : TStringList;
|
L : TStringList;
|
||||||
P,U : String;
|
C,P,U : String;
|
||||||
I : Integer;
|
I : Integer;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
@ -723,9 +717,11 @@ begin
|
|||||||
FCrossOriginIsolation:=ReadBool(SConfig,KeyCOI,FCrossOriginIsolation);
|
FCrossOriginIsolation:=ReadBool(SConfig,KeyCOI,FCrossOriginIsolation);
|
||||||
if ValueExists(SConfig,KeyCapture) then
|
if ValueExists(SConfig,KeyCapture) then
|
||||||
begin
|
begin
|
||||||
FCaptureFileName:=ReadString(SConfig,keyCapture,'');
|
C:=ReadString(SConfig,keyCapture,'');
|
||||||
if FCaptureFileName='' then
|
if C='-' then
|
||||||
FCaptureFileName:='-';
|
TDebugCaptureService.Instance.LogToConsole:=True
|
||||||
|
else
|
||||||
|
TDebugCaptureService.Instance.LogFileName:=C;
|
||||||
end;
|
end;
|
||||||
L:=TstringList.Create;
|
L:=TstringList.Create;
|
||||||
ReadSectionValues(SProxy,L,[]);
|
ReadSectionValues(SProxy,L,[]);
|
||||||
@ -753,7 +749,7 @@ end;
|
|||||||
function THTTPCompilerApplication.ProcessOptions: Boolean;
|
function THTTPCompilerApplication.ProcessOptions: Boolean;
|
||||||
|
|
||||||
Var
|
Var
|
||||||
IndexPage,D : String;
|
C,IndexPage,D : String;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result:=False;
|
Result:=False;
|
||||||
@ -805,9 +801,11 @@ begin
|
|||||||
FCrossOriginIsolation:=hasOption('o','coi');
|
FCrossOriginIsolation:=hasOption('o','coi');
|
||||||
if HasOption('u','capture') then
|
if HasOption('u','capture') then
|
||||||
begin
|
begin
|
||||||
FCaptureFileName:=GetOptionValue('u','capture');
|
C:=GetOptionValue('u','capture');
|
||||||
if FCaptureFileName='' then
|
if C='' then
|
||||||
FCaptureFileName:='-';
|
TDebugCaptureService.Instance.LogToConsole:=True
|
||||||
|
else
|
||||||
|
TDebugCaptureService.Instance.LogFileName:=C;
|
||||||
end;
|
end;
|
||||||
Result:=True;
|
Result:=True;
|
||||||
end;
|
end;
|
||||||
@ -849,8 +847,7 @@ begin
|
|||||||
{$endif}
|
{$endif}
|
||||||
end;
|
end;
|
||||||
// Handle options
|
// Handle options
|
||||||
if FCaptureFileName<>'' then
|
SetupCapture;
|
||||||
SetupCapture(FCaptureFileName);
|
|
||||||
if FPassword<>'' then
|
if FPassword<>'' then
|
||||||
HTTPRouter.RegisterRoute('/quit',rmAll,@Doquit,False);
|
HTTPRouter.RegisterRoute('/quit',rmAll,@Doquit,False);
|
||||||
if FEcho then
|
if FEcho then
|
||||||
@ -892,97 +889,23 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function THTTPCompilerApplication.GetCaptureJSON(ARequest: TRequest;
|
|
||||||
AResponse: TResponse; var aJSON: TJSONData): TJSONArray;
|
|
||||||
|
|
||||||
var
|
procedure THTTPCompilerApplication.SetupCapture;
|
||||||
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
|
Var
|
||||||
aJSON : TJSONData;
|
Dest : String;
|
||||||
aArray : TJSONArray;
|
Svc : TDebugCaptureService;
|
||||||
I : Integer;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
aJSON:=Nil;
|
Svc:=TDebugCaptureService.Instance;
|
||||||
aArray:=Nil;
|
Dest:=Svc.LogFileName;
|
||||||
try
|
if (Dest='') and Svc.LogToConsole then
|
||||||
aArray:=GetCaptureJSON(aRequest,aResponse,aJSON);
|
Dest:='Console';
|
||||||
if aArray<>Nil then
|
if Dest<>'' 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
|
begin
|
||||||
FCaptureStream:=TFileStream.Create(aFileName,fmCreate);
|
DoLog(etInfo,Format('Setting up capture on route "%s", writing to %s',[SCaptureRoute,Dest]));
|
||||||
Dest:='file: '+aFileName
|
HTTPRouter.RegisterRoute(SCaptureRoute,rmPost,@Svc.HandleRequest,False);
|
||||||
end
|
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;
|
||||||
|
|
||||||
end.
|
end.
|
||||||
|
Loading…
Reference in New Issue
Block a user