mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-04-05 09:58:06 +02:00
804 lines
21 KiB
ObjectPascal
804 lines
21 KiB
ObjectPascal
unit TestInsightServer;
|
|
|
|
{$mode ObjFPC}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, types, httpdefs, syncobjs, fphttpserver, fpJSON, testinsightprotocol;
|
|
|
|
{$IF DECLARED(TCORSSUPPORT)}
|
|
{$DEFINE USECORS}
|
|
{$ENDIF}
|
|
|
|
|
|
Type
|
|
TTestItem = Class;
|
|
|
|
{ TTestItem }
|
|
|
|
TTestItem = Class
|
|
Public
|
|
TestParent : TTestItem;
|
|
TestName : String;
|
|
Tests : Array of TTestItem;
|
|
TestResult : TTestInsightResult;
|
|
Constructor Create(aParent : TTestItem; const aTestName : String);
|
|
Destructor Destroy; override;
|
|
Procedure FromJSON(aJSON : TJSONObject);
|
|
Function TestPath : String;
|
|
Function CountTestCases : Integer;
|
|
Function IsTestSuite : Boolean;
|
|
Function IsTestCase : Boolean;
|
|
end;
|
|
|
|
(*
|
|
// Incoming
|
|
{
|
|
"name" : null
|
|
"suite" : {
|
|
"name1" : null,
|
|
"name2" : null
|
|
}
|
|
}
|
|
// Internal
|
|
|
|
{
|
|
"name" : { "$Result" : { }, "$Path" : "name" }
|
|
"suite" : {
|
|
"$path'
|
|
name1 : { $Result : {} , "$Path" : "suite.name1" }
|
|
name1 : { $Result : {} , "$Path" : "suite.name2"}
|
|
}
|
|
}
|
|
*)
|
|
|
|
|
|
{ TTestInsightServer }
|
|
|
|
// Object Receiver frees received object.
|
|
TTestNamesEvent = Procedure(Sender : TObject; Tests : TTestItem) of object;
|
|
TSelectedTestsEvent = Procedure(Sender : TObject; var Tests: TStringDynArray) of object;
|
|
TTestResultEvent = Procedure(Sender : TObject; aResult : TTestInsightResultArray) of object;
|
|
TTestsStartedEvent = Procedure(Sender : TObject; aCount : Integer) of object;
|
|
TTestsOptionsEvent = Procedure(Sender : TObject; aOptions : TTestInsightOptions) of object;
|
|
TInsightMessageType = (imtInfo,imtError);
|
|
TTestInsightLogEvent = Procedure(Sender : TObject; const aType : TInsightMessageType; const aMessage : String) of object;
|
|
|
|
TTestInsightServer = class(TComponent)
|
|
private
|
|
FBasePath: String;
|
|
FOnClearTests: TNotifyEvent;
|
|
FOnLog: TTestInsightLogEvent;
|
|
FOnTestsFinished: TNotifyEvent;
|
|
FOnTestsStarted: TTestsStartedEvent;
|
|
FServer : TFPHttpServer;
|
|
FOnSelectedTests: TSelectedTestsEvent;
|
|
FOnSetTestNames: TTestNamesEvent;
|
|
FOnTestResult: TtestResultEvent;
|
|
FSelectedTests : String;
|
|
FTestInsightResultClass: TTestInsightResultClass;
|
|
FTestSuite : TTestItem;
|
|
FTestCount : Integer;
|
|
FInsightOptions : TTestInsightOptions;
|
|
FOnGetOptions: TTestsOptionsEvent;
|
|
FThread: TThread;
|
|
FServerPort : Word;
|
|
FServerActive : Boolean;
|
|
{$IFDEF USECORS}
|
|
FCorsSupport : TCORSSupport;
|
|
{$ENDIF}
|
|
procedure CreateServer;
|
|
function ExtractResults(anArray: TJSONArray): TTestInsightResultArray;
|
|
procedure FreeResults(Results: TTestInsightResultArray);
|
|
function GetPort: Word;
|
|
procedure HandleStartThreadTerminate(Sender: TObject);
|
|
procedure SetBasePath(AValue: String);
|
|
{$IFDEF USECORS}
|
|
procedure SetCorsSupport(AValue: TCORSSupport);
|
|
{$ENDIF}
|
|
procedure SetPort(AValue: Word);
|
|
Protected
|
|
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 DoSetTestNames; virtual;
|
|
procedure DoTestsStarted; virtual;
|
|
procedure DoTestsFinished; virtual;
|
|
procedure DoClearTests; virtual;
|
|
procedure DoOptions; virtual;
|
|
procedure Send400(aResponse: TFPHTTPConnectionResponse; aText: String);
|
|
Procedure Send404(aResponse : TFPHTTPConnectionResponse);
|
|
Procedure Send405(aResponse : TFPHTTPConnectionResponse);
|
|
Procedure Send200(aResponse : TFPHTTPConnectionResponse);
|
|
procedure SetTestList(ARequest: TFPHTTPConnectionRequest; aResponse: TFPHTTPConnectionResponse);
|
|
procedure DoTestResults(ARequest: TFPHTTPConnectionRequest; aResponse: TFPHTTPConnectionResponse);
|
|
procedure ClearTestList(aResponse: TFPHTTPConnectionResponse); virtual;
|
|
procedure DoFinishTests(aResponse: TFPHTTPConnectionResponse); virtual;
|
|
procedure DoStartTests(aResponse: TFPHTTPConnectionResponse; aCount: Integer); virtual;
|
|
procedure SendSelectedTestList(aResponse: TFPHTTPConnectionResponse); virtual;
|
|
procedure DoGetOptions(aResponse: TFPHTTPConnectionResponse); virtual;
|
|
procedure DoRequest(Sender: TObject;
|
|
var ARequest: TFPHTTPConnectionRequest;
|
|
var AResponse: TFPHTTPConnectionResponse);
|
|
Public
|
|
constructor create(aOwner : TComponent); override;
|
|
destructor destroy; override;
|
|
procedure StartServer;
|
|
procedure StopServer;
|
|
Property Active : Boolean Read FServerActive;
|
|
// TestResultClass
|
|
Property TestInsightResultClass : TTestInsightResultClass Read FTestInsightResultClass Write FTestInsightResultClass;
|
|
// Options sent to the client.
|
|
property InsightOptions : TTestInsightOptions Read FInsightOptions;
|
|
// Port on which to listen
|
|
property Port: Word Read GetPort Write SetPort;
|
|
// First part of URL. By default: /tests
|
|
Property BasePath : String Read FBasePath Write SetBasePath;
|
|
// CORS Support ?
|
|
{$IFDEF USECORS}
|
|
Property CorsSupport : TCORSSupport Read FCorsSupport Write SetCorsSupport;
|
|
{$ENDIF}
|
|
// 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.
|
|
Property OnGetSelectedTests : TSelectedTestsEvent Read FOnSelectedTests Write FOnSelectedTests;
|
|
// Results of run tests. Event handler must free result array.
|
|
Property OnTestResult : TTestResultEvent Read FOnTestResult Write FOnTestResult;
|
|
// Tests started.
|
|
Property OnTestsStarted : TTestsStartedEvent Read FOnTestsStarted Write FOnTestsStarted;
|
|
// Tests finished.
|
|
Property OnTestsFinished : TNotifyEvent Read FOnTestsFinished Write FOnTestsFinished;
|
|
// Clear tests.
|
|
Property OnClearTests : TNotifyEvent Read FOnClearTests Write FOnClearTests;
|
|
// Last change to set options before sending to the client. If not, Options are sent as-is.
|
|
Property OnGetOptions : TTestsOptionsEvent Read FOnGetOptions Write FOnGetOptions;
|
|
// Diagnostic messages
|
|
Property OnLog : TTestInsightLogEvent Read FOnLog Write FOnLog;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
Uses ssockets;
|
|
|
|
Type
|
|
|
|
{ TStartServerThread }
|
|
|
|
TStartServerThread = Class(TThread)
|
|
Private
|
|
FServer : TFPHttpServer;
|
|
FStartErrorClass: String;
|
|
FStartErrorMessage: String;
|
|
Public
|
|
constructor Create(aServer: TFPHttpServer; aOnTerminate: TNotifyEvent);
|
|
Procedure Execute; override;
|
|
Property StartErrorMessage : String Read FStartErrorMessage;
|
|
Property StartErrorClass : String Read FStartErrorClass;
|
|
end;
|
|
|
|
{ TTestItem }
|
|
|
|
constructor TTestItem.Create(aParent: TTestItem; const aTestName: String);
|
|
begin
|
|
TestParent:=aParent;
|
|
TestName:=aTestName;
|
|
end;
|
|
|
|
destructor TTestItem.Destroy;
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
For I:=0 to Length(Tests)-1 do
|
|
FreeAndNil(Tests[i]);
|
|
SetLength(Tests,0);
|
|
FreeAndNil(TestResult);
|
|
Inherited;
|
|
end;
|
|
|
|
procedure TTestItem.FromJSON(aJSON: TJSONObject);
|
|
|
|
Var
|
|
I : Integer;
|
|
|
|
begin
|
|
SetLength(Tests,aJSON.Count);
|
|
For I:=0 to aJSON.Count-1 do
|
|
begin
|
|
Tests[i]:=TTestItem.Create(Self, aJSON.Names[i]);
|
|
if aJSON.Items[i].JSONType=jtObject then
|
|
Tests[i].FromJSON(TJSONObject(aJSON.Items[i]));
|
|
end;
|
|
end;
|
|
|
|
function TTestItem.TestPath: String;
|
|
|
|
Var
|
|
P : TTestItem;
|
|
|
|
begin
|
|
if Self=Nil then exit('');
|
|
Result:=TestName;
|
|
P:=TestParent;
|
|
While (P<>Nil) do
|
|
begin
|
|
if P.TestName<>'' then
|
|
Result:=P.TestName+'.'+Result;
|
|
P:=P.TestParent;
|
|
end;
|
|
end;
|
|
|
|
function TTestItem.CountTestCases: Integer;
|
|
|
|
Var
|
|
I : integer;
|
|
|
|
begin
|
|
if Self=Nil then exit(0);
|
|
Result:=0;
|
|
for I:=0 to Length(Tests)-1 do
|
|
Result:=Result+Tests[i].CountTestCases;
|
|
If (Result=0) and (TestName<>'') then
|
|
Inc(Result);
|
|
end;
|
|
|
|
function TTestItem.IsTestSuite: Boolean;
|
|
begin
|
|
if Self=Nil then exit(False);
|
|
Result:=Length(Tests)>0;
|
|
end;
|
|
|
|
function TTestItem.IsTestCase: Boolean;
|
|
begin
|
|
if Self=Nil then exit(False);
|
|
Result:=Length(Tests)=0;
|
|
end;
|
|
|
|
{ TStartServerThread }
|
|
|
|
constructor TStartServerThread.Create(aServer: TFPHttpServer; aOnTerminate : TNotifyEvent);
|
|
begin
|
|
FServer:=aServer;
|
|
FreeOnTerminate:=True;
|
|
OnTerminate:=aOnTerminate;
|
|
Inherited Create(False);
|
|
end;
|
|
|
|
procedure TStartServerThread.Execute;
|
|
begin
|
|
try
|
|
FServer.Active:=true;
|
|
except
|
|
On E : Exception do
|
|
begin
|
|
FStartErrorClass:=E.ClassName;
|
|
FStartErrorMessage:=E.Message;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{ TTestInsightServer }
|
|
|
|
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(FEvent) then
|
|
FEvent(FSender,FResult);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoSetTestNames;
|
|
begin
|
|
if Assigned(FOnSetTestNames) then
|
|
FOnSetTestNames(Self,FTestSuite);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoTestsStarted;
|
|
begin
|
|
if Assigned(FOnTestsStarted) then
|
|
FOnTestsStarted(Self,Self.FTestCount);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoTestsFinished;
|
|
begin
|
|
if Assigned(FOnTestsFinished) then
|
|
FOnTestsFinished(Self);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoClearTests;
|
|
begin
|
|
if Assigned(FOnClearTests) then
|
|
FOnClearTests(Self);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoOptions;
|
|
begin
|
|
if Assigned(FOnGetOptions) then
|
|
FOnGetOptions(Self,FInsightOptions);
|
|
end;
|
|
|
|
|
|
procedure TTestInsightServer.SetTestList(ARequest: TFPHTTPConnectionRequest; aResponse: TFPHTTPConnectionResponse);
|
|
|
|
Var
|
|
D : TJSONData;
|
|
|
|
begin
|
|
D:=Nil;
|
|
try
|
|
if SameText(aRequest.ContentType,'application/json') then
|
|
D:=GetJSON(aRequest.Content)
|
|
else if SameText(aRequest.ContentType,'text/text') then
|
|
D:=TestStringsToJSON(aRequest.Content)
|
|
else
|
|
Send400(aResponse,'Invalid content type. Need application/json or text/text');
|
|
if (D<>Nil) and not (D is TJSONObject) then
|
|
begin
|
|
Send400(aResponse,'Invalid JSON, need object');
|
|
FreeAndNil(D);
|
|
end;
|
|
except
|
|
on E : exception do
|
|
begin
|
|
Send400(aResponse,E.Message);
|
|
Raise;
|
|
end;
|
|
end;
|
|
if D=nil then
|
|
Exit;
|
|
// Here we have a valid test list
|
|
Send200(aResponse);
|
|
if Assigned(D) then
|
|
begin
|
|
FTestSuite:=TtestItem.Create(Nil,'');
|
|
FTestSuite.FromJSON(D as TJSONObject);
|
|
if Assigned(OnSetTestNames) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoSetTestNames)
|
|
else
|
|
FTestSuite.Free;
|
|
D.Free;
|
|
end;
|
|
end;
|
|
|
|
Function TTestInsightServer.ExtractResults(anArray : TJSONArray) : TTestInsightResultArray;
|
|
|
|
Var
|
|
i,aLen : Integer;
|
|
Res: TTestInsightResult;
|
|
|
|
|
|
begin
|
|
aLen:=0;
|
|
SetLength(Result,anArray.Count);
|
|
For I:=0 to anArray.Count-1 do
|
|
begin
|
|
if anArray.Types[i]=jtObject then
|
|
begin
|
|
Res:=TestInsightResultClass.Create;
|
|
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
|
|
Result[aLen]:=Res;
|
|
Inc(aLen);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoTestResults(ARequest: TFPHTTPConnectionRequest; aResponse: TFPHTTPConnectionResponse);
|
|
|
|
Var
|
|
D : TJSONData;
|
|
Results : TTestInsightResultArray;
|
|
Trans : TTransferTestResult;
|
|
|
|
begin
|
|
Results:=Nil;
|
|
try
|
|
D:=GetJSON(aRequest.Content);
|
|
except
|
|
on E : exception do
|
|
begin
|
|
Send400(aResponse,E.Message);
|
|
Raise;
|
|
end;
|
|
end;
|
|
try
|
|
if D is TJSONArray then
|
|
begin
|
|
Send200(aResponse);
|
|
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);
|
|
Results:=ExtractResults(TJSONObject(D).Extract(0) as TJSONArray);
|
|
end
|
|
else
|
|
Send400(aResponse,'Bad JSON message');
|
|
finally
|
|
D.Free;
|
|
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(Results : TTestInsightResultArray);
|
|
|
|
Var
|
|
Res : TTestInsightResult;
|
|
|
|
begin
|
|
For Res in Results do
|
|
Res.Free;
|
|
SetLength(Results,0);
|
|
end;
|
|
|
|
|
|
procedure TTestInsightServer.DoGetSelectedTests;
|
|
|
|
Var
|
|
aTests : TStringDynArray;
|
|
D : TJSONObject;
|
|
A : TJSONArray;
|
|
S : String;
|
|
|
|
begin
|
|
aTests:=Nil;
|
|
if Assigned(FOnSelectedTests) then
|
|
FOnselectedTests(Self,aTests);
|
|
A:=TJSONArray.Create;
|
|
try
|
|
D:=TJSONObject.Create(['tests',A]);
|
|
For S in aTests do
|
|
A.Add(S);
|
|
FSelectedTests:=D.asJSON;
|
|
Finally
|
|
D.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TTestInsightServer.SendSelectedTestList(aResponse: TFPHTTPConnectionResponse);
|
|
begin
|
|
FSelectedTests:='';
|
|
if Assigned(FOnSelectedTests) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoGetSelectedTests);
|
|
if FSelectedTests='' then
|
|
FSelectedTests:='{ "tests" : [] }';
|
|
aResponse.Content:=FSelectedTests;
|
|
aResponse.ContentType:='application/json';
|
|
send200(aResponse);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoGetOptions(aResponse: TFPHTTPConnectionResponse);
|
|
begin
|
|
if Assigned(FONGetOptions) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoOptions);
|
|
aResponse.Content:=FInsightOptions.ToJSON;
|
|
aResponse.ContentType:='application/json';
|
|
send200(aResponse);
|
|
end;
|
|
|
|
procedure TTestInsightServer.ClearTestList(aResponse: TFPHTTPConnectionResponse);
|
|
|
|
begin
|
|
Send200(aResponse);
|
|
if Assigned(FOnClearTests) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoClearTests);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoStartTests(aResponse: TFPHTTPConnectionResponse; aCount : Integer);
|
|
|
|
begin
|
|
Send200(aResponse);
|
|
FTestCount:=aCount;
|
|
if Assigned(FOnTestsStarted) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoTestsStarted);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoFinishTests(aResponse: TFPHTTPConnectionResponse);
|
|
|
|
begin
|
|
Send200(aResponse);
|
|
if Assigned(FonTestsFinished) then
|
|
TThread.Synchronize(TThread.CurrentThread,@DoTestsFinished);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoRequest(Sender: TObject;
|
|
var ARequest: TFPHTTPConnectionRequest;
|
|
var AResponse: TFPHTTPConnectionResponse);
|
|
|
|
function CheckMethod(aMethod : String) : Boolean;
|
|
|
|
begin
|
|
Result:=SameText(aMethod,aRequest.Method);
|
|
if not Result then
|
|
Send405(aResponse);
|
|
end;
|
|
|
|
Var
|
|
aPath : String;
|
|
|
|
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
|
|
{$IFDEF USECORS}
|
|
if FCorsSupport.HandleRequest(aRequest,aResponse,[hcDetect, hcsend]) then
|
|
exit;
|
|
{$ENDIF}
|
|
Delete(aPath,1,Length(BasePath));
|
|
if (aPath='') then // '/tests'
|
|
begin
|
|
if SameText(aRequest.Method,'POST') then
|
|
SetTestList(aRequest,aResponse)
|
|
else if SameText(aRequest.Method,'get') then
|
|
SendSelectedTestList(aResponse)
|
|
else if SameText(aRequest.Method,'delete') then
|
|
ClearTestList(aResponse)
|
|
else
|
|
Send405(aResponse)
|
|
end
|
|
else
|
|
begin
|
|
If aPath[1]='/' then
|
|
delete(aPath,1,1);
|
|
if SameText(aPath,pathStarted) then
|
|
begin
|
|
if CheckMethod('POST') then
|
|
DoStartTests(aResponse,StrToIntDef(aRequest.QueryFields.Values[qryTotalCount],-1));
|
|
end
|
|
else if SameText(aPath,pathFinished) then
|
|
begin
|
|
if CheckMethod('POST') then
|
|
DoFinishTests(aResponse);
|
|
end
|
|
else if SameText(aPath,PathResults) then
|
|
begin
|
|
if CheckMethod('POST') then
|
|
DoTestResults(aRequest,aResponse);
|
|
end
|
|
else if SameText(aPath,PathOptions) then
|
|
begin
|
|
if CheckMethod('GET') then
|
|
DoGetOptions(aResponse);
|
|
end
|
|
else
|
|
Send404(aResponse);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TTestInsightServer.GetPort: Word;
|
|
begin
|
|
if Assigned(FServer) then
|
|
Result:=FServer.Port
|
|
else
|
|
Result:=FServerPort;
|
|
end;
|
|
|
|
procedure TTestInsightServer.HandleStartThreadTerminate(Sender: TObject);
|
|
|
|
var
|
|
SThread : TStartServerThread ;
|
|
ErrClass,ErrMsg : String;
|
|
|
|
begin
|
|
If Sender<>FThread then exit;
|
|
SThread:=Sender as TStartServerThread;
|
|
ErrClass:=SThread.StartErrorClass;
|
|
ErrMsg:=SThread.StartErrorMessage;
|
|
if ErrClass<>'' then
|
|
DoLog(imtError,'Error %s starting server: %s',[ErrClass,ErrMsg]);
|
|
FThread:=Nil;
|
|
FServerActive:=False;
|
|
|
|
end;
|
|
|
|
|
|
procedure TTestInsightServer.SetBasePath(AValue: String);
|
|
|
|
var
|
|
len : integer;
|
|
|
|
begin
|
|
// Make sure it starts with /
|
|
if (AValue<>'') and (AValue[1]<>'/') then
|
|
AValue:='/'+AValue;
|
|
// Make sure it does not end with /
|
|
Len:=Length(AValue);
|
|
if (Len>1) and (AValue[Len]='/') then
|
|
AValue:=Copy(AValue,1,Len-1)
|
|
else if Len<2 then
|
|
Raise ETestInsight.Create('Basepath cannot be empty');
|
|
if FBasePath=AValue then Exit;
|
|
FBasePath:=AValue;
|
|
end;
|
|
|
|
{$IFDEF USECORS}
|
|
procedure TTestInsightServer.SetCorsSupport(AValue: TCORSSupport);
|
|
begin
|
|
if FCorsSupport=AValue then Exit;
|
|
FCorsSupport.Assign(AValue);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TTestInsightServer.SetPort(AValue: Word);
|
|
begin
|
|
FServer.Port:=aValue;
|
|
FServerPort:=aValue;
|
|
end;
|
|
|
|
|
|
procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const aMessage: String);
|
|
begin
|
|
If Assigned(FOnLog) then
|
|
FOnLog(Self,aType,aMessage);
|
|
end;
|
|
|
|
procedure TTestInsightServer.DoLog(const aType : TInsightMessageType;const Fmt: String; Args: array of const);
|
|
begin
|
|
DoLog(aType,Format(Fmt,Args));
|
|
end;
|
|
|
|
procedure TTestInsightServer.Send400(aResponse: TFPHTTPConnectionResponse; aText : String);
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='400 BAD REQUEST';
|
|
if aText<>'' then
|
|
aResponse.Content:=aText
|
|
else
|
|
aResponse.Content:='The requested URL is invalid';
|
|
aResponse.ContentType:='text/text';
|
|
aResponse.SendResponse;
|
|
end;
|
|
|
|
procedure TTestInsightServer.Send404(aResponse: TFPHTTPConnectionResponse);
|
|
begin
|
|
aResponse.Code:=404;
|
|
aResponse.CodeText:='NOT FOUND';
|
|
aResponse.Content:='The requested URL is invalid';
|
|
aResponse.ContentType:='text/text';
|
|
aResponse.SendResponse;
|
|
end;
|
|
|
|
procedure TTestInsightServer.Send405(aResponse: TFPHTTPConnectionResponse);
|
|
begin
|
|
aResponse.Code:=405;
|
|
aResponse.CodeText:='METHOD NOT ALLOWED';
|
|
aResponse.Content:='The requested HTTP method is invalid';
|
|
aResponse.ContentType:='text/text';
|
|
aResponse.SendResponse;
|
|
end;
|
|
|
|
procedure TTestInsightServer.Send200(aResponse: TFPHTTPConnectionResponse);
|
|
begin
|
|
aResponse.Code:=200;
|
|
aResponse.CodeText:='OK';
|
|
aResponse.ContentType:='application/json';
|
|
aResponse.SendResponse;
|
|
end;
|
|
|
|
constructor TTestInsightServer.create(aOwner: TComponent);
|
|
begin
|
|
inherited create(aOwner);
|
|
CreateServer;
|
|
BasePath:=pathTests;
|
|
FTestInsightResultClass:=TTestInsightResult;
|
|
FInsightOptions:=CreateTestInsightOptions;
|
|
{$IFDEF USECORS}
|
|
FCorsSupport:=TCORSSupport.Create;
|
|
FCorsSupport.Enabled:=True;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
|
|
destructor TTestInsightServer.destroy;
|
|
begin
|
|
StopServer;
|
|
FreeAndNil(FServer);
|
|
FreeAndNil(FInsightOptions);
|
|
{$IFDEF USECORS}
|
|
FreeAndNil(FCorsSupport);
|
|
{$ENDIF}
|
|
inherited destroy;
|
|
end;
|
|
|
|
procedure TTestInsightServer.CreateServer;
|
|
|
|
begin
|
|
FServer:=TFPHttpServer.Create(Self);
|
|
FServer.Threaded:=True;
|
|
if FServerPort>0 then
|
|
FServer.Port:=FServerPort;
|
|
end;
|
|
|
|
function TTestInsightServer.CreateTestInsightOptions: TTestInsightOptions;
|
|
|
|
begin
|
|
Result:=TTestInsightOptions.Create;
|
|
end;
|
|
|
|
procedure TTestInsightServer.StartServer;
|
|
begin
|
|
if FServerActive then
|
|
exit;
|
|
FServer.OnRequest:=@DoRequest;
|
|
FServerActive:=True;
|
|
FThread:=TStartServerThread.Create(FServer,@HandleStartThreadTerminate);
|
|
DoLog(imtInfo,'Starting test insight server on port %d',[Port]);
|
|
end;
|
|
|
|
procedure TTestInsightServer.StopServer;
|
|
begin
|
|
|
|
if not Assigned(FServer) then
|
|
exit;
|
|
if not FServer.Active then
|
|
exit;
|
|
FServer.OnRequest:=Nil;
|
|
FServerActive:=False;
|
|
DoLog(imtInfo,'Deactivating server');
|
|
FServer.Active:=False;
|
|
DoLog(imtInfo,'Fake request');
|
|
Try
|
|
TInetSocket.Create('localhost',FServer.Port,10,Nil).Free;
|
|
except
|
|
on E : Exception do
|
|
DoLog(imtError,'Fake request resulted in %s: %s',[E.ClassName,E.Message]);
|
|
end;
|
|
DoLog(imtInfo,'Waiting for server thread to stop');
|
|
If Assigned(FThread) then
|
|
FThread.WaitFor;
|
|
DoLog(imtInfo,'Server thread stopped');
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
|