Thread safe results, CORS support (for pas2js)

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 ShowMessage(aType : TInsightMessageType; Const Msg : String); virtual;
-    procedure HandleServerLog(Sender: TObject; const aMessage: 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;

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;

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);
+     function ExtractResults(anArray: TJSONArray): TTestInsightResultArray;
-     procedure FreeResults;
+     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 aType : TInsightMessageType; const aMessage : String);
-     Procedure DoLog(Const Fmt : String; Args : Array of const);
+     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
+  if Assigned(FEvent) then
-    OnTestResult(Self,FResultArray);
+    FEvent(FSender,FResult);
-  FResultArray:=Nil;
 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
+        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
+  if not (Assigned(Results) and Assigned(OnTestResult)) then
-    begin
+    Exit;
-    if Assigned(OnTestResult) then
+  Trans:=TTransferTestResult.create(OnTestResult,Self,Results);
-      TThread.Synchronize(TThread.CurrentThread,@DoResultEvent)
+  try
-    else
+    TThread.Synchronize(TThread.CurrentThread,@Trans.DoResultEvent);
-      FreeResults;
+    FreeResults(Results);
+  finally
+    Trans.Free;
   end;
 end;
 
-procedure TTestInsightServer.FreeResults;
+procedure TTestInsightServer.FreeResults(Results : TTestInsightResultArray);
 
 Var
   Res : TTestInsightResult;
 
 begin
-  For Res in FResultArray do
+  For Res in Results do
     Res.Free;
-  SetLength(FResultArray,0);
+  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
@@ -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;