From 6802746529c111dcc0afb0d4f99ced88dd6d7a49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= Date: Tue, 26 Dec 2023 17:42:57 +0100 Subject: [PATCH] Thread safe results, CORS support (for pas2js) --- components/fpcunit/ide/frmtestinsight.pas | 23 ++-- components/fpcunit/ide/regtestinsight.pas | 14 +- components/fpcunit/ide/testinsightserver.pas | 130 +++++++++++++------ 3 files changed, 110 insertions(+), 57 deletions(-) diff --git a/components/fpcunit/ide/frmtestinsight.pas b/components/fpcunit/ide/frmtestinsight.pas index ea13f0904e..23adee5aec 100644 --- a/components/fpcunit/ide/frmtestinsight.pas +++ b/components/fpcunit/ide/frmtestinsight.pas @@ -174,8 +174,8 @@ type function CreateServer(aOwner : TComponent) : TTestInsightServer; virtual; procedure NavigateTo(const {%H-}aClass, {%H-}aMethod,{%H-}aUnit,{%H-}aLocationFile : String; {%H-}aLocationLine : Integer); virtual; procedure DoneServer(aServer :TTestInsightServer); virtual; - procedure ShowMessage(Const Msg : String); virtual; - procedure HandleServerLog(Sender: TObject; const aMessage: String); virtual; + procedure ShowMessage(aType : TInsightMessageType; Const Msg : String); virtual; + procedure HandleServerLog(Sender: TObject; const aType : TInsightMessageType; const aMessage: String); virtual; Property Server : TTestInsightServer Read FServer; public end; @@ -393,7 +393,7 @@ end; procedure TTestInsightForm.NavigateTo(const aClass,aMethod, aUnit, aLocationFile: String; aLocationLine: Integer); begin - ShowMessage(SNavigationNotAvailable); + ShowMessage(imtInfo,SNavigationNotAvailable); end; procedure TTestInsightForm.DoneServer(aServer: TTestInsightServer); @@ -401,7 +401,7 @@ begin aServer.Free; end; -procedure TTestInsightForm.ShowMessage(const Msg: String); +procedure TTestInsightForm.ShowMessage(aType: TInsightMessageType; const Msg: String); begin Dialogs.ShowMessage(Msg); end; @@ -630,7 +630,7 @@ begin begin If not ExtractMethod(Itm.TestPath,aClass,aMethod) then begin - ShowMessage(Format(rsCouldNotDete, [Itm.TestPath])); + ShowMessage(imtInfo,Format(rsCouldNotDete, [Itm.TestPath])); exit; end; aUnit:=''; @@ -748,6 +748,7 @@ begin begin Res:=aResult[i]; aName:=Res.TestName; + Writeln('Analyizing test result',Res.TestClassName,' : ',Res.TestName); N:=FindNode(aName); if N=Nil then Res.Free @@ -760,6 +761,8 @@ begin rtError : AddError(N,Itm); rtWarning : AddFailure(N,Itm); rtPassed : EndTest(N,Itm); + else + Writeln('Unknown test result',Res.TestClassName,' : ',Res.TestName); end; end; end; @@ -795,9 +798,9 @@ begin pbBar.Refresh; end; -procedure TTestInsightForm.HandleServerLog(Sender: TObject; const aMessage: String); +procedure TTestInsightForm.HandleServerLog(Sender: TObject; const aType: TInsightMessageType; const aMessage: String); begin - ShowMessage(aMessage); + ShowMessage(atype,aMessage); end; @@ -1276,12 +1279,12 @@ procedure TTestInsightForm.RunTestProject(aExecutable: String; SendNamesOnly: Bo begin if TestRunning then begin - ShowMessage(Format('The test project %s is still running',[aExecutable])); + ShowMessage(imtInfo,Format('The test project %s is still running',[aExecutable])); Exit; end; if not FileExists(aExecutable) then begin - ShowMessage(Format(SNoExecutableAvailable,[aExecutable])); + ShowMessage(imtError,Format(SNoExecutableAvailable,[aExecutable])); Exit; end; CreateTestRunConfigFile(FConfStoreFile,SendNamesOnly); @@ -1290,7 +1293,7 @@ begin PTest.Execute; except On E : Exception do - ShowMessage(Format('Error %s while running test project %s: %s',[E.ClassName,aExecutable,E.Message])); + ShowMessage(imtError,Format('Error %s while running test project %s: %s',[E.ClassName,aExecutable,E.Message])); end; FSelectedTestSuite:=Nil; end; diff --git a/components/fpcunit/ide/regtestinsight.pas b/components/fpcunit/ide/regtestinsight.pas index 82c7e9e405..873ecc4854 100644 --- a/components/fpcunit/ide/regtestinsight.pas +++ b/components/fpcunit/ide/regtestinsight.pas @@ -21,7 +21,7 @@ Type TLazTestInsightForm = class(TTestInsightForm) private Public - procedure ShowMessage(Const Msg : String); override; + procedure ShowMessage(aType: TInsightMessageType; Const Msg : String); override; Function GetTestProject : String; override; procedure RunTestProject(aExecutable : string; SendNamesOnly : Boolean); override; procedure NavigateTo(const aClass, aMethod, aUnit, aLocationFile: String; aLocationLine: Integer); override; @@ -265,11 +265,15 @@ end; { TLazTestInsightForm } -procedure TLazTestInsightForm.ShowMessage(const Msg: String); +procedure TLazTestInsightForm.ShowMessage(aType: TInsightMessageType; const Msg: String); + +Const + MLU : Array[TInsightMessageType] of TMessageLineUrgency = (TMessageLineUrgency.mluImportant,TMessageLineUrgency.mluError); + begin - Writeln('Message : ',Msg); if Assigned(IDEMessagesWindow) then - IDEMessagesWindow.AddCustomMessage(TMessageLineUrgency.mluError,Msg,'',0,0,rsTestInsightTitle) + + IDEMessagesWindow.AddCustomMessage(MLU[aType],Msg,'',0,0,rsTestInsightTitle) end; function TLazTestInsightForm.GetTestProject: String; @@ -313,7 +317,7 @@ begin if not NavOK then NavOK:=ShowMethod(aClass,aMethod,aUnit); if not NavOK then - ShowMessage(Format('Failed to navigate to test %s.%s in unit %s',[aClass,aMethod,aUnit])); + ShowMessage(imtError,Format('Failed to navigate to test %s.%s in unit %s',[aClass,aMethod,aUnit])); end; function TLazTestInsightForm.ShowRefreshTestproject: Boolean; diff --git a/components/fpcunit/ide/testinsightserver.pas b/components/fpcunit/ide/testinsightserver.pas index ac4e83757c..e17b3234fc 100644 --- a/components/fpcunit/ide/testinsightserver.pas +++ b/components/fpcunit/ide/testinsightserver.pas @@ -5,7 +5,7 @@ unit TestInsightServer; interface uses - Classes, SysUtils, types, fphttpserver, fpJSON, testinsightprotocol; + Classes, SysUtils, types, httpdefs, syncobjs, fphttpserver, fpJSON, testinsightprotocol; Type TTestItem = Class; @@ -57,7 +57,8 @@ Type TTestResultEvent = Procedure(Sender : TObject; aResult : TTestInsightResultArray) of object; TTestsStartedEvent = Procedure(Sender : TObject; aCount : Integer) of object; TTestsOptionsEvent = Procedure(Sender : TObject; aOptions : TTestInsightOptions) of object; - TTestInsightLogEvent = Procedure(Sender : TObject; const aMessage : String) of object; + TInsightMessageType = (imtInfo,imtError); + TTestInsightLogEvent = Procedure(Sender : TObject; const aType : TInsightMessageType; const aMessage : String) of object; TTestInsightServer = class(TComponent) private @@ -70,7 +71,6 @@ Type FOnSelectedTests: TSelectedTestsEvent; FOnSetTestNames: TTestNamesEvent; FOnTestResult: TtestResultEvent; - FResultArray : TTestInsightResultArray; FSelectedTests : String; FTestInsightResultClass: TTestInsightResultClass; FTestSuite : TTestItem; @@ -80,21 +80,22 @@ Type FThread: TThread; FServerPort : Word; FServerActive : Boolean; + FCorsSupport : TCORSSupport; procedure CreateServer; - procedure ExtractResults(anArray: TJSONArray); - procedure FreeResults; + function ExtractResults(anArray: TJSONArray): TTestInsightResultArray; + procedure FreeResults(Results: TTestInsightResultArray); function GetPort: Word; procedure HandleStartThreadTerminate(Sender: TObject); procedure SetBasePath(AValue: String); + procedure SetCorsSupport(AValue: TCORSSupport); procedure SetPort(AValue: Word); Protected - Procedure DoLog(Const aMessage : String); - Procedure DoLog(Const Fmt : String; Args : Array of const); + Procedure DoLog(const aType : TInsightMessageType; const aMessage : String); + Procedure DoLog(const aType : TInsightMessageType; const Fmt : String; Args : Array of const); // Override if you want to create a descendent. function CreateTestInsightOptions: TTestInsightOptions; virtual; // these are called in the main thread procedure DoGetSelectedTests; virtual; - procedure DoResultEvent; virtual; procedure DoSetTestNames; virtual; procedure DoTestsStarted; virtual; procedure DoTestsFinished; virtual; @@ -128,6 +129,8 @@ Type property Port: Word Read GetPort Write SetPort; // First part of URL. By default: /tests Property BasePath : String Read FBasePath Write SetBasePath; + // CORS Support ? + Property CorsSupport : TCORSSupport Read FCorsSupport Write SetCorsSupport; // Set the list of tests. Event handler must free JSON object. Property OnSetTestNames : TTestNamesEvent Read FOnSetTestNames Write FOnSetTestNames; // Get the list of selected tests. The server will free the received object. @@ -271,12 +274,32 @@ end; { TTestInsightServer } -procedure TTestInsightServer.DoResultEvent; +Type + + { TTransferTestResult } + + TTransferTestResult = Class + Private + FEvent: TTestResultEvent; + FSender : TObject; + FResult : TTestInsightResultArray; + Public + constructor create (aEvent: TTestResultEvent; aSender : TObject; aResult : TTestInsightResultArray); + procedure DoResultEvent; + end; + +constructor TTransferTestResult.create(aEvent: TTestResultEvent; aSender: TObject; aResult: TTestInsightResultArray); +begin + FEvent:=aEvent; + FSender:=aSender; + FResult:=aResult; +end; + +procedure TTransferTestResult.DoResultEvent; begin - if Assigned(OnTestResult) then - OnTestResult(Self,FResultArray); - FResultArray:=Nil; + if Assigned(FEvent) then + FEvent(FSender,FResult); end; procedure TTestInsightServer.DoSetTestNames; @@ -352,15 +375,16 @@ begin end; end; -procedure TTestInsightServer.ExtractResults(anArray : TJSONArray); +Function TTestInsightServer.ExtractResults(anArray : TJSONArray) : TTestInsightResultArray; Var i,aLen : Integer; Res: TTestInsightResult; + begin aLen:=0; - SetLength(FResultArray,anArray.Count); + SetLength(Result,anArray.Count); For I:=0 to anArray.Count-1 do begin if anArray.Types[i]=jtObject then @@ -369,11 +393,15 @@ begin try Res.FromJSOn(anArray.Objects[i]); except - FreeAndNil(res); + on E : Exception do + begin + FreeAndNil(res); + DoLog(imtError,'Error %s extracting test result: %s',[E.ClassName, E.Message]); + end; end; if Assigned(Res) then begin - FResultArray[aLen]:=Res; + Result[aLen]:=Res; Inc(aLen); end; end; @@ -384,9 +412,11 @@ procedure TTestInsightServer.DoTestResults(ARequest: TFPHTTPConnectionRequest; a Var D : TJSONData; + Results : TTestInsightResultArray; + Trans : TTransferTestResult; begin - FreeResults; + Results:=Nil; try D:=GetJSON(aRequest.Content); except @@ -400,36 +430,38 @@ begin if D is TJSONArray then begin Send200(aResponse); - ExtractResults(D as TJSONArray); + Results:=ExtractResults(D as TJSONArray); end else if (D is TJSONObject) and (D.Count=1) and (D.Items[0] is TJSONArray) then begin Send200(aResponse); - ExtractResults(TJSONObject(D).Extract(0) as TJSONArray); + Results:=ExtractResults(TJSONObject(D).Extract(0) as TJSONArray); end else Send400(aResponse,'Bad JSON message'); finally D.Free; end; - if Assigned(FResultArray) then - begin - if Assigned(OnTestResult) then - TThread.Synchronize(TThread.CurrentThread,@DoResultEvent) - else - FreeResults; - end; + if not (Assigned(Results) and Assigned(OnTestResult)) then + Exit; + Trans:=TTransferTestResult.create(OnTestResult,Self,Results); + try + TThread.Synchronize(TThread.CurrentThread,@Trans.DoResultEvent); + FreeResults(Results); + finally + Trans.Free; + end; end; -procedure TTestInsightServer.FreeResults; +procedure TTestInsightServer.FreeResults(Results : TTestInsightResultArray); Var Res : TTestInsightResult; begin - For Res in FResultArray do - Res.Free; - SetLength(FResultArray,0); + For Res in Results do + Res.Free; + SetLength(Results,0); end; @@ -519,10 +551,13 @@ Var begin aPath:=aRequest.PathInfo; + DoLog(imtInfo,'Handling request %s %s',[aRequest.Method,aPath]); if not SameText(Copy(aPath,1,Length(BasePath)),BasePath) then Send404(aResponse) else begin + if FCorsSupport.HandleRequest(aRequest,aResponse,[hcDetect, hcsend]) then + exit; Delete(aPath,1,Length(BasePath)); if (aPath='') then // '/tests' begin @@ -542,7 +577,7 @@ begin if SameText(aPath,pathStarted) then begin if CheckMethod('POST') then - DoStartTests(aResponse,StrToIntDef(aRequest.QueryFields.Values[qryTotalCount],-1)); + DoStartTests(aResponse,StrToIntDef(aRequest.QueryFields.Values[qryTotalCount],-1)); end else if SameText(aPath,pathFinished) then begin @@ -585,7 +620,7 @@ begin ErrClass:=SThread.StartErrorClass; ErrMsg:=SThread.StartErrorMessage; if ErrClass<>'' then - DoLog('Error %s starting server: %s',[ErrClass,ErrMsg]); + DoLog(imtError,'Error %s starting server: %s',[ErrClass,ErrMsg]); FThread:=Nil; FServerActive:=False; @@ -611,21 +646,28 @@ begin FBasePath:=AValue; end; +procedure TTestInsightServer.SetCorsSupport(AValue: TCORSSupport); +begin + if FCorsSupport=AValue then Exit; + FCorsSupport.Assign(AValue); +end; + procedure TTestInsightServer.SetPort(AValue: Word); begin FServer.Port:=aValue; FServerPort:=aValue; end; -procedure TTestInsightServer.DoLog(const aMessage: String); + +procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const aMessage: String); begin If Assigned(FOnLog) then - FOnLog(Self,aMessage); + FOnLog(Self,aType,aMessage); end; -procedure TTestInsightServer.DoLog(const Fmt: String; Args: array of const); +procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const Fmt: String; Args: array of const); begin - DoLog(Format(Fmt,Args)); + DoLog(aType,Format(Fmt,Args)); end; procedure TTestInsightServer.Send400(aResponse: TFPHTTPConnectionResponse; aText : String); @@ -673,6 +715,8 @@ begin BasePath:=pathTests; FTestInsightResultClass:=TTestInsightResult; FInsightOptions:=CreateTestInsightOptions; + FCorsSupport:=TCORSSupport.Create; + FCorsSupport.Enabled:=True; end; @@ -681,10 +725,11 @@ begin StopServer; FreeAndNil(FServer); FreeAndNil(FInsightOptions); + FreeAndNil(FCorsSupport); inherited destroy; end; -Procedure TTestInsightServer.CreateServer; +procedure TTestInsightServer.CreateServer; begin FServer:=TFPHttpServer.Create(Self); @@ -706,6 +751,7 @@ begin FServer.OnRequest:=@DoRequest; FServerActive:=True; FThread:=TStartServerThread.Create(FServer,@HandleStartThreadTerminate); + DoLog(imtInfo,'Starting test insight server on port %d',[Port]); end; procedure TTestInsightServer.StopServer; @@ -717,19 +763,19 @@ begin exit; FServer.OnRequest:=Nil; FServerActive:=False; - DoLog('Deactivating server'); + DoLog(imtInfo,'Deactivating server'); FServer.Active:=False; - DoLog('Fake request'); + DoLog(imtInfo,'Fake request'); Try TInetSocket.Create('localhost',FServer.Port,10,Nil).Free; except on E : Exception do - DoLog('Fake request resulted in %s: %s',[E.ClassName,E.Message]); + DoLog(imtError,'Fake request resulted in %s: %s',[E.ClassName,E.Message]); end; - DoLog('Waiting for server thread to stop'); + DoLog(imtInfo,'Waiting for server thread to stop'); If Assigned(FThread) then FThread.WaitFor; - DoLog('Server thread stopped'); + DoLog(imtInfo,'Server thread stopped'); end;