{ Author: Mattias Gaertner Working: - Start/Stop compileserver - server log - on socketerror find conflicting process (Linux, Windows, Macos) - on socketerror find free port (Linux, Windows, Macos) - option: port - option: interfaceaddress - change port - add/delete location - enable/disable location - list of locations: location, enabled, filepath, lpi - floating/dockable window - IDE menu item: View / Simple Web Server - options frame - apply options: restart server - stop server on close IDE - options: check and warn about wrong values - BindAny - IDE macros SWSPort,SWSAddress, SWSExe - listview - delete button - custom http servers on different ports - check port conflict - changing main port: check conflict with custom servers - list in window - stop all on close - dialog to add user folder ToDos: - log with time and port - ide macro SWSExe param: 'base', 'used' and '' - Windows: add GetUDPTable2 - SSL } unit SimpleWebSrvController; {$mode objfpc}{$H+} interface uses Math, Types, Classes, SysUtils, process, Pipes, Contnrs, fpjson, fphttpclient, Sockets, // lazutils LazLoggerBase, FileUtil, LazUTF8, LazFileUtils, LazMethodList, LazUtilities, LazStringUtils, LazFileCache, // LCL Forms, Dialogs, Controls, LazHelpIntf, LCLIntf, // IDEIntf IDEDialogs, IDEMsgIntf, LazIDEIntf, IDEExternToolIntf, MacroIntf, MacroDefIntf, // sws ProjectIntf, SimpleWebSrvUtils, SimpleWebSrvOptions, SimpleWebSrvStrConsts; type ESimpleWebServerException = class(Exception) end; TSWebServerState = ( swssNone, swssStarting, swssRunning, swssStopping ); TSWebServerStates = set of TSWebServerState; TSWebServerError = ( swseNone, swseBindingOfSocketFailed ); TSWebServerErrors = set of TSWebServerError; { TSWSLocation } TSWSLocation = class(TPersistent) public Location: string; // URL subfolder Path: string; // path on disk Origin: string; // e.g. a lpi file or 'user' Enable: boolean; ErrorDesc: string; end; TSWServerThread = class; TSimpleWebServerController = class; { TSWSInstance } TSWSInstance = class(TPersistent) Private FParams: TStrings; procedure SetParams(AValue: TStrings); public Controller: TSimpleWebServerController; Exe: string; // may contain macros and not expanded ExeUsed: string; // resolved macros, expanded filename Port: word; Path: string; // path on disk, can contain macros PathUsed: string; // path on disk, resolved macros, expanded filename Origin: string; // e.g. a lpi file or 'user' ErrorDesc: string; State: TSWebServerState; Thread: TSWServerThread; ExitCode: integer; constructor Create; destructor Destroy; override; Property Params : TStrings Read FParams Write SetParams; end; TSWServerLogEvent = procedure(Sender: TObject; OutLines: TStrings) of object; TSWServerStateChangedEvent = procedure(Sender: TObject; Instance: TSWSInstance) of object; { TSWServerThread } TSWServerThread = class(TThread) private FOwner: TSWSInstance; protected fSleepEvent: PRTLEvent; FOutLines: TStrings; procedure Execute; override; // this thread procedure HandleOutput; // this thread procedure SynchronizedHandleOuput; // main thread procedure QueuedFinished({%H-}Data: PtrInt); // main thread public TheProcess: TProcess; OnOutput: TSWServerLogEvent; // main thread OnFinished: TNotifyEvent; // main thread constructor Create(TheOwner: TSWSInstance; aProcess: TProcess); destructor Destroy; override; procedure ShutDown(Gracefully: boolean); // main thread procedure TerminateProcess; property Owner: TSWSInstance read FOwner; end; TSWSGetLocationsLocation = record Location: string; // http name Path: string; // path on disk end; TSWSGetLocationsLocationArray = array of TSWSGetLocationsLocation; TSWSGetLocationsResponse = class public Locations: TSWSGetLocationsLocationArray; end; TSWSCHandler = ( swschStateChanged, // TSWServerStateChangedEvent swschLocationsChanged, // TNotifyEvent swschServerLog // TSWServerLogEvent ); TSWSCHandlers = set of TSWSCHandler; { TSimpleWebServerController } TSimpleWebServerController = class(TComponent) private FAPIKey: string; fAPIPath: string; FDestroying: boolean; FMainSrvAddr: string; FMainSrvBindAny: boolean; fHandlers: array[TSWSCHandler] of TMethodList; FInstances: TFPList; // list of TSWSInstance FLocations: TObjectList; // list of TSWSLocation FMainSrvInstance: TSWSInstance; FLogLines: TStrings; FOptions: TSimpleWebServerOptions; FMainSrvError: TSWebServerError; FUtility: TSimpleWebServerUtility; FViewCaption: string; function GetLocationCount: integer; function GetLocations(Index: integer): TSWSLocation; function GetMainSrvExe: string; function GetMainSrvExitCode: integer; function GetMainSrvPort: word; function GetMainSrvState: TSWebServerState; function GetMainSrvThread: TSWServerThread; function GetServerCount: integer; function GetServers(Index: integer): TSWSInstance; function GetSWSAddress(const s: string; const {%H-}Data: PtrInt; var Abort: boolean): string; function GetSWSExe(const s: string; const {%H-}Data: PtrInt; var Abort: boolean ): string; function GetSWSPort(const s: string; const {%H-}Data: PtrInt; var Abort: boolean ): string; procedure OnApplyOptions(Sender: TObject); procedure OnIDEClose(Sender: TObject); procedure OnServerFinished(Sender: TObject); procedure OnServerOutput(Sender: TObject; OutLines: TStrings); protected IDEMacroSWSAddress: TTransferMacro; IDEMacroSWSExe: TTransferMacro; IDEMacroSWSPort: TTransferMacro; function ParseServerResponse(Response: TStream): TSWSGetLocationsResponse; virtual; procedure GetLocationsFromServer; virtual; procedure AddServerLocation(Location, Path: string); virtual; procedure RemoveServerLocation(Location: string); virtual; procedure AddIDEMessageInfo(DbgPrefix, Msg: string); procedure SetServerState(Instance: TSWSInstance; NewState: TSWebServerState); virtual; procedure StateChanged(Instance: TSWSInstance); virtual; procedure LocationsChanged; virtual; procedure ServerLog(OutLines: TStrings); virtual; function StartServerInstance(Instance: TSWSInstance; ResolveMacros, Interactive: boolean): boolean; virtual; function StopServerInstance(Instance: TSWSInstance; Interactive: boolean): boolean; virtual; procedure StopAllServers; virtual; function GetMainServerExeHint: string; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure HookMacros; virtual; procedure UnhookMacros; virtual; public // main server where multiple locations share one port function StartMainServer(Interactive: boolean): boolean; virtual; function StopMainServer(Interactive: boolean): boolean; virtual; function AddLocation(Location, Path, Origin: string; Enable: boolean): TSWSLocation; virtual; function AddProjectLocation(aProject: TLazProject; Location, Path: string; Interactive: boolean): TSWSLocation; virtual; procedure DeleteLocation(Location: string); virtual; procedure EnableLocation(Location: string; Enable: boolean); virtual; function IndexOfLocation(Location: string): integer; virtual; function FindLocation(Location: string): TSWSLocation; virtual; function FindLocationWithOrigin(Origin: string): TSWSLocation; virtual; procedure AddHandlerLocationsChanged(const OnLocationsChanged: TNotifyEvent; AsLast: boolean = false); procedure RemoveHandlerLocationsChanged(const OnLocationsChanged: TNotifyEvent); procedure AddHandlerStateChanged(const OnStateChanged: TSWServerStateChangedEvent; AsLast: boolean = false); procedure RemoveHandlerStateChanged(const OnStateChanged: TSWServerStateChangedEvent); procedure AddHandlerServerLog(const OnServerLog: TSWServerLogEvent; AsLast: boolean = false); procedure RemoveHandlerServerLog(const OnServerLog: TSWServerLogEvent); procedure RemoveAllHandlersOfObject(AnObject: TObject); // custom servers function AddServer(Port: word; Exe: string; Params: TStrings; Path, Origin: string; ResolveMacros, Interactive: boolean): TSWSInstance; virtual; function AddProjectServer(aProject: TLazProject; Port: word; Path: string; Interactive: boolean): TSWSInstance; virtual; function FindServerWithPort(Port: word): TSWSInstance; virtual; function FindServerWithOrigin(Origin: string): TSWSInstance; virtual; function FindFreePort(Interactive, CheckServers: boolean; aStartPort: word = 0): word; virtual; function StopServer(Instance: TSWSInstance; Interactive: boolean): boolean; virtual; function SubstitutePortMacro(aValue, aPort: string): string; function SubstituteURLMacro(aValue, AnURL: string): string; function GetDefaultServerExe: string; virtual; // browser function GetURLWithServer(aServer: TSWSInstance; HTMLFilename: string): string; virtual; function GetURLWithLocation(aLocation: TSWSLocation; HTMLFilename: string): string; virtual; function OpenBrowserWithURL(URL, WorkDir: string): boolean; virtual; function OpenBrowserWithLocation(aLocation: TSWSLocation; HTMLFilename: string): boolean; virtual; function OpenBrowserWithServer(aServer: TSWSInstance; HTMLFilename: string): boolean; virtual; function FindBrowserFile(ShortFilename: string): string; virtual; function FindBrowserPath(Filenames: array of string; URL: string; Params: TStrings): string; virtual; function GetBrowser(URL: string; Params: TStrings): string; virtual; function GetBrowserChrome(URL: string; Params: TStrings): string; virtual; function GetBrowserFirefox(URL: string; Params: TStrings): string; virtual; function GetBrowserOpera(URL: string; Params: TStrings): string; virtual; function GetBrowserVivaldi(URL: string; Params: TStrings): string; virtual; {$IFDEF Darwin} function GetBrowserSafari(URL: string; Params: TStrings): string; virtual; {$ENDIF} {$IFDEF MSWindows} function GetBrowserEdge(URL: string; Params: TStrings): string; virtual; {$ENDIF} public property Destroying: boolean read FDestroying; property LocationCount: integer read GetLocationCount; property Locations[Index: integer]: TSWSLocation read GetLocations; property LogLines: TStrings read FLogLines; property MainSrvAPIKey: string read FAPIKey; property MainSrvAPIPath: string read fAPIPath; property MainSrvPort: word read GetMainSrvPort; property MainSrvBindAny: boolean read FMainSrvBindAny; property MainSrvAddr: string read FMainSrvAddr; property MainSrvError: TSWebServerError read FMainSrvError; property MainSrvExe: string read GetMainSrvExe; property MainSrvExitCode: integer read GetMainSrvExitCode; property MainSrvThread: TSWServerThread read GetMainSrvThread; property MainSrvState: TSWebServerState read GetMainSrvState; property MainSrvInstance: TSWSInstance read FMainSrvInstance; property Options: TSimpleWebServerOptions read FOptions; property ServerCount: integer read GetServerCount; property Servers[Index: integer]: TSWSInstance read GetServers; property Utility: TSimpleWebServerUtility read FUtility; property ViewCaption: string read FViewCaption; // the title in the IDE's Messages window end; var SimpleWebServerController: TSimpleWebServerController; // created by Register function CheckWebServerExeQuality(var ServerExe: string; const BaseDir: string; aSubtituteMacros: boolean): string; // on fail returns errormessage implementation function CheckWebServerExeQuality(var ServerExe: string; const BaseDir: string; aSubtituteMacros: boolean): string; var OutStr, ExpBaseDir: string; begin if aSubtituteMacros then begin if not IDEMacros.SubstituteMacros(ServerExe) then exit('invalid macro'); end; ServerExe:=Trim(ServerExe); if ServerExe='' then exit('file not found'); if ExtractFilePath(ServerExe)='' then begin ExpBaseDir:=BaseDir; if aSubtituteMacros and not IDEMacros.SubstituteMacros(ExpBaseDir) then exit('invalid macro in BaseDir'); if ExpBaseDir='' then begin ExpBaseDir:='$(LazarusDir)'; IDEMacros.SubstituteMacros(ExpBaseDir); end; ServerExe:=FindDefaultExecutablePath(ServerExe,ExpBaseDir); if ServerExe='' then exit('file not found in PATH'); end else ServerExe:=ExpandFileNameUTF8(ServerExe); if not FileExistsUTF8(ServerExe) then exit('file not found'); if not FileIsExecutable(ServerExe) then exit('file is not executable'); if not RunCommand(ServerExe,['--version'],OutStr) then exit('simpleserver does not support --version, maybe this is an old version?'); Result:=''; end; { TSWSInstance } procedure TSWSInstance.SetParams(AValue: TStrings); begin if FParams=AValue then Exit; FParams.Assign(AValue); end; constructor TSWSInstance.Create; begin FParams:=TStringList.Create; end; destructor TSWSInstance.Destroy; begin FreeAndNil(Thread); FreeAndNil(FParams); inherited Destroy; end; { TSimpleWebServerController } function TSimpleWebServerController.GetLocationCount: integer; begin Result:=FLocations.Count; end; function TSimpleWebServerController.GetLocations(Index: integer): TSWSLocation; begin Result:=TSWSLocation(FLocations[Index]); end; function TSimpleWebServerController.GetMainSrvExe: string; begin Result:=FMainSrvInstance.Exe; end; function TSimpleWebServerController.GetMainSrvExitCode: integer; begin Result:=FMainSrvInstance.ExitCode; end; function TSimpleWebServerController.GetMainSrvPort: word; begin Result:=FMainSrvInstance.Port; end; function TSimpleWebServerController.GetMainSrvState: TSWebServerState; begin Result:=FMainSrvInstance.State; end; function TSimpleWebServerController.GetMainSrvThread: TSWServerThread; begin Result:=FMainSrvInstance.Thread; end; function TSimpleWebServerController.GetServerCount: integer; begin Result:=FInstances.Count; end; function TSimpleWebServerController.GetServers(Index: integer): TSWSInstance; begin Result:=TSWSInstance(FInstances[Index]); end; function TSimpleWebServerController.GetSWSAddress(const s: string; const Data: PtrInt; var Abort: boolean): string; begin Abort:=False; if (s<>'') and (ConsoleVerbosity>=0) then debugln(['Hint: (lazarus) [TSimpleWebServerController.GetSWSAddress] ignoring macro SWSAddress parameter "',s,'"']); Result:=MainSrvAddr; if Result='' then Result:='SWSServerAddress'; // always return something to get nicer error messages end; function TSimpleWebServerController.GetSWSExe(const s: string; const Data: PtrInt; var Abort: boolean): string; begin Abort:=False; if (s<>'') and (ConsoleVerbosity>=0) then debugln(['Hint: (lazarus) [TSimpleWebServerController.GetSWSExe] ignoring macro SWSExe parameter "',s,'"']); Result:=MainSrvExe; if Result='' then Result:='SWSServerExe'; // always return something to get nicer error messages end; function TSimpleWebServerController.GetSWSPort(const s: string; const Data: PtrInt; var Abort: boolean): string; begin Abort:=False; if (s<>'') and (ConsoleVerbosity>=0) then debugln(['Hint: (lazarus) [TSimpleWebServerController.GetSWSPort] ignoring macro SWSPort parameter "',s,'"']); Result:=IntToStr(MainSrvPort); if Result='' then Result:='SWSServerPort'; // always return something to get nicer error messages end; procedure TSimpleWebServerController.OnApplyOptions(Sender: TObject); var OldRunning: Boolean; begin OldRunning:=MainSrvState=swssRunning; StopMainServer(true); FMainSrvBindAny:=Options.BindAny; FMainSrvAddr:=Options.ServerAddr; FMainSrvInstance.Exe:=Options.ServerExe; FMainSrvInstance.Port:=Options.ServerPort; if OldRunning then StartMainServer(true); end; procedure TSimpleWebServerController.OnIDEClose(Sender: TObject); begin StopAllServers; end; procedure TSimpleWebServerController.OnServerFinished(Sender: TObject); var aProcDescription: string; aPID, i: integer; r: TModalResult; NewPort: Word; IPAddr: in_addr; Instance: TSWSInstance; begin //debugln(['TSimpleWebServerController.OnServerFinished START']); if Destroying then exit; Instance:=Sender as TSWSInstance; if Instance.State=swssRunning then StopServerInstance(Instance,false); // notify handlers if FMainSrvInstance=Instance then begin // main server finished // error handling if (Instance.State<>swssStopping) and (MainSrvError=swseBindingOfSocketFailed) then begin if MainSrvBindAny then IPAddr.s_addr:=0 else IPAddr:=StrToHostAddr(MainSrvAddr); if not FUtility.FindProcessListeningOnPort(IPAddr,MainSrvPort,aProcDescription,aPID) then begin IDEMessageDialog(rsSWError, ViewCaption+':'+sLineBreak +rsSWBindingOfSocketFailed+': '+MainSrvAddr+':'+IntToStr(MainSrvPort ), mtError, [mbOk]); exit; end; r:=IDEQuestionDialog(rsSWError, ViewCaption+':'+sLineBreak +rsSWBindingOfSocketFailed+': '+MainSrvAddr+':'+IntToStr(MainSrvPort)+ sLineBreak +sLineBreak +rsSWTheFollowingProcessAlreadyListens+sLineBreak +'PID: '+IntToStr(aPID)+sLineBreak +aProcDescription+sLineBreak +sLineBreak +rsSWKillProcess , mtError, [mrYes, Format(rsSWKillPID, [IntToStr(aPID)]), mrRetry, rsSWTryAnotherPort, mrCancel], ''); case r of mrYes: if not FUtility.KillProcess(aPID) then exit; mrRetry: begin NewPort:=FindFreePort(true,false); if NewPort=0 then NewPort:=GetNextIPPort(MainSrvInstance.Port); FMainSrvInstance.Port:=NewPort; end; else exit; end; // try again StartMainServer(true); end; end else begin // custom server finished -> delete FInstances.Remove(Instance); i:=FInstances.IndexOf(Instance); if i>=0 then FInstances.Delete(i); LocationsChanged; end; end; procedure TSimpleWebServerController.OnServerOutput(Sender: TObject; OutLines: TStrings); const BindingOfSocketFailed = 'Binding of socket failed: '; var i: Integer; Line: String; aThread: TSWServerThread; begin //debugln(['TSimpleWebServerController.OnServerOutput checking StdOut=',dbgs(FMainSrvThread.OutLines.Count),' ...']); aThread:=Sender as TSWServerThread; if aThread.Owner=FMainSrvInstance then begin for i:=0 to OutLines.Count-1 do begin Line:=OutLines[i]; //debugln(['Hint: TSimpleWebServerController.OnServerOutput {',Line,'}']); if LeftStr(Line,length(BindingOfSocketFailed))=BindingOfSocketFailed then FMainSrvError:=swseBindingOfSocketFailed; end; end; ServerLog(OutLines); end; function TSimpleWebServerController.ParseServerResponse(Response: TStream ): TSWSGetLocationsResponse; procedure Err(DbgPrefix, Msg: string); begin AddIDEMessageInfo(DbgPrefix,'get location failed: '+Msg); end; var JSON: TJSONData; Obj: TJSONObject; Arr: TJSONArray; i: Integer; Location, Path: String; ok: Boolean; begin Result:=TSWSGetLocationsResponse.Create; ok:=false; try JSON:=GetJSON(Response); if not (JSON is TJSONObject) then begin Err('20210913154156','response is not a JSON object'); exit; end; Obj:=TJSONObject(JSON); JSON:=Obj.Find('data'); if not (JSON is TJSONArray) then begin Err('20210913154715','response data is not a JSON array'); exit; end; Arr:=TJSONArray(JSON); SetLength(Result.Locations,Arr.Count); for i:=0 to Arr.Count-1 do begin JSON:=Arr[i]; if not (JSON is TJSONObject) then begin Err('20210913154923','response data[i] is not a JSON object'); exit; end; Obj:=TJSONObject(JSON); JSON:=Obj.Find('location'); if not (JSON is TJSONString) then begin Err('20210913155015','response data[i].location is not a JSON string'); exit; end; Location:=String(TJSONString(JSON).AsString); JSON:=Obj.Find('path'); if not (JSON is TJSONString) then begin Err('20210913155016','response data[i].path is not a JSON string'); exit; end; Path:=String(TJSONString(JSON).AsString); Result.Locations[i].Location:=Location; Result.Locations[i].Path:=Path; debugln('TSimpleWebServerController.ParseServerResponse ',dbgs(i),' location="',Location,'" path="',Path,'"'); end; ok:=true; finally if not ok then Result.Free; end; end; procedure TSimpleWebServerController.GetLocationsFromServer; procedure Err(Msg: string); begin AddIDEMessageInfo('[20210913154042]','get location failed: '+Msg); end; var Response: TMemoryStream; URL: String; SrvLocations: TSWSGetLocationsResponse; Client: TFPHTTPClient; LocArr: TSWSGetLocationsLocationArray; i: Integer; Loc: TSWSLocation; j: SizeInt; HasChanged: Boolean; begin URL:='http://'+MainSrvAddr+':'+IntToStr(MainSrvPort)+'/'+MainSrvAPIPath+'/?APIKey='+MainSrvAPIKey+'&fmt=1'; Response:=TMemoryStream.Create; SrvLocations:=nil; Client:=TFPHTTPClient.Create(Nil); try HasChanged:=false; Client.Get(URL,Response); Response.Position:=0; SrvLocations:=ParseServerResponse(Response); LocArr:=SrvLocations.Locations; for i:=0 to LocationCount-1 do begin Loc:=Locations[i]; j:=0; while (jLoc.Location) do inc(j); if j=length(LocArr) then begin if Loc.Enable then HasChanged:=true; Loc.Enable:=false; end else begin if not Loc.Enable then HasChanged:=true; Loc.Enable:=true; if Loc.Path<>LocArr[j].Path then AddIDEMessageInfo('20210915144542','path of location "'+Loc.Location+'" differ. IDE="'+Loc.Path+'" Server="'+LocArr[j].Path+'"'); end; end; finally SrvLocations.Free; Response.Free; Client.Free; end; if HasChanged then LocationsChanged; end; procedure TSimpleWebServerController.AddServerLocation(Location, Path: string); var SrvAddr, URL: String; JSON: TStringStream; Response: TMemoryStream; Client: TFPHTTPClient; begin if MainSrvState<>swssRunning then exit; SrvAddr:='http://'+MainSrvAddr+':'+IntToStr(MainSrvPort)+'/'; URL:=SrvAddr+MainSrvAPIPath+'/?APIKey='+MainSrvAPIKey+'&fmt=1'; JSON:=TStringStream.Create('{' +'"location" : "'+StringToJSONString(Location)+'",' +'"path": "'+StringToJSONString(Path)+'"' +'}'); Response:=TMemoryStream.Create; Client:=TFPHTTPClient.Create(Nil); try Client.RequestBody:=JSON; Client.AddHeader('Content-Type','application/json'); AddIDEMessageInfo('20210913104107','adding "'+SrvAddr+Location+'", path="'+Path+'"'); try Client.HTTPMethod('POST',URL,Response,[201,200]); except on E: Exception do begin AddIDEMessageInfo('20220108152508','Failed: '+E.Message); end; end; Response.Position:=0; // maybe: check response finally Response.Free; JSON.Free; Client.Free; end; end; procedure TSimpleWebServerController.RemoveServerLocation(Location: string); var URL: String; Response: TMemoryStream; Client: TFPHTTPClient; begin if MainSrvState<>swssRunning then exit; URL:='http://'+MainSrvAddr+':'+IntToStr(MainSrvPort)+'/'+MainSrvAPIPath+'/'+Location+'?APIKey='+MainSrvAPIKey+'&fmt=1'; Response:=TMemoryStream.Create; Client:=TFPHTTPClient.Create(Nil); try AddIDEMessageInfo('20210915112101','removing location "'+Location+'"'); try Client.HTTPMethod('DELETE',URL,Response,[204,200]); except on E: EHTTPClient do begin if E.StatusCode=404 then // already gone else AddIDEMessageInfo('20210915113102','removing location "'+Location+'" failed: '+E.Message); end; on E: Exception do begin AddIDEMessageInfo('20210915112928','removing location "'+Location+'" failed: '+E.Message); end; end; Response.Position:=0; // maybe: check response finally Response.Free; Client.Free; end; end; procedure TSimpleWebServerController.AddIDEMessageInfo(DbgPrefix, Msg: string); var OutLines: TStringListUTF8Fast; begin debugln(['Hint: [',DbgPrefix,'] ',Msg]); if ViewCaption='' then ; OutLines:=TStringListUTF8Fast.Create; try OutLines.Add('IDE: '+Msg); ServerLog(OutLines); finally OutLines.Free; end; if IDEMessagesWindow<>nil then IDEMessagesWindow.AddCustomMessage(mluImportant,Msg,'',0,0,ViewCaption); end; procedure TSimpleWebServerController.SetServerState(Instance: TSWSInstance; NewState: TSWebServerState); begin if Instance.State=NewState then exit; Instance.State:=NewState; StateChanged(Instance); end; procedure TSimpleWebServerController.StateChanged(Instance: TSWSInstance); var h: TMethodList; i: Integer; begin h:=fHandlers[swschStateChanged]; i:=0; while (iSWSLogMaxLines then begin // delete old messages sl:=TStringListUTF8Fast.Create; try for i:=FLogLines.Count-SWSLogMaxLines to FLogLines.Count-1 do sl.Add(FLogLines[i]); FLogLines.Assign(sl); finally sl.Free; end; end; h:=fHandlers[swschServerLog]; i:=0; while (i1 then debugln(['Hint: TSimpleWebServerController.StartServerInstance START']); Params:=TStringList.Create; try if ResolveMacros then begin // resolve macros if not SubstituteMacro('Executable',Instance.Exe,ExeUsed) then exit; if not SubstituteMacro('Local Directory',Instance.Path,PathUsed) then exit; if Instance.Params<>nil then begin for i:=0 to Instance.Params.Count-1 do begin if not SubstituteMacro('Params['+IntToStr(i)+']',Instance.Params[i],Value) then exit; Params.Add(Value); end; end; end else begin ExeUsed:=Instance.Exe; PathUsed:=Instance.Path; Params.AddStrings(Instance.Params); end; // check for empty values if ExeUsed='' then begin Instance.ErrorDesc:='missing server exe. '+LinePostfix; AddIDEMessageInfo('20220127115641',Instance.ErrorDesc); if Interactive then ErrDlg(rsSWError, rsSWMissingServerExecutable, true); exit; end; if PathUsed='' then begin Instance.ErrorDesc:='missing local directory. '+LinePostfix; AddIDEMessageInfo('20220127115738',Instance.ErrorDesc); if Interactive then ErrDlg(rsSWError, rsSWMissingLocalDirectory, false); exit; end; // expand local dir PathUsed:=ChompPathDelim(ExpandFileNameUTF8(PathUsed)); if not DirectoryExistsUTF8(PathUsed) then begin // Note: main server does not need a main dir, the locations have their own dirs Instance.ErrorDesc:='server directory not found "'+PathUsed+'". '+LinePostfix; AddIDEMessageInfo('20220127122933',Instance.ErrorDesc); if Interactive then ErrDlg(rsSWError, Format(rsSWServerDirectoryNotFound, [PathUsed]), false ); exit; end; // check exe if ExtractFilePath(ExeUsed)='' then begin LazDir:='$(LazarusDir)'; IDEMacros.SubstituteMacros(LazDir); s:=FindDefaultExecutablePath(ExeUsed,LazDir); if s='' then begin Instance.ErrorDesc:='server exe "'+ExeUsed+'" not found in PATH. '+LinePostfix; AddIDEMessageInfo('20220127115917',Instance.ErrorDesc); if Interactive then ErrDlg(rsSWError, Format(rsSWServerExecutableNotFoundInPATH, [ExeUsed] ), true); exit; end; ExeUsed:=s; end else ExeUsed:=ExpandFileNameUTF8(ExeUsed); debugln(['Hint: [simplewebserver_startserver] ',ViewCaption,' Exe="',ExeUsed,'" LocalDir="',PathUsed,'"', ' Params=[',MergeCmdLineParams(Params),'] ',LinePostfix]); if not FileExistsUTF8(ExeUsed) then begin AddIDEMessageInfo('20220127114637','Error: server exe not found "'+ExeUsed+'"'); if Interactive then ErrDlg(rsSWError, Format(rsSWFileNotFound, [ExeUsed]), true); exit; end; if not FileIsExecutable(ExeUsed) then begin AddIDEMessageInfo('20220127121636','Error: server exe not executable "'+ExeUsed+'"'); if Interactive then ErrDlg(rsSWError, Format(rsSWServerExeIsNotExecutable, [ExeUsed]), true ); exit; end; // let's get to work Instance.ExeUsed:=ExeUsed; Instance.PathUsed:=PathUsed; SetServerState(Instance,swssStarting); // start process AddIDEMessageInfo('20210909125756','run: '+MaybeQuote(ExeUsed)+' '+MergeCmdLineParams(Params)); TheProcess := TProcess.Create(nil); try TheProcess.Executable:=ExeUsed; TheProcess.Parameters.Assign(Params); ProcOpts:=[poUsePipes]; TheProcess.Options:= ProcOpts; TheProcess.ShowWindow := swoHide; // needed by Windows, ignored by Unix TheProcess.StartupOptions:=[suoUseShowWindow]; // needed by Windows, ignored by Unix TheProcess.CurrentDirectory:=PathUsed; TheProcess.Execute; except on E: Exception do begin AddIDEMessageInfo('20210909125752', 'unable to run '+MaybeQuote(ExeUsed)+' '+MergeCmdLineParams(Params)+': '+E.Message); TheProcess.Free; exit; end; end; Result:=true; finally Params.Free; if not Result then begin SetServerState(Instance,swssNone); if ConsoleVerbosity>1 then debugln(['Hint: TSimpleWebServerController.StartServerInstance END']); end; end; try // start thread aThread:=TSWServerThread.Create(Instance,TheProcess); Instance.Thread:=aThread; aThread.OnOutput:=@OnServerOutput; aThread.OnFinished:=@OnServerFinished; aThread.FreeOnTerminate:=false; aThread.Start; SetServerState(Instance,swssRunning); finally if ConsoleVerbosity>1 then debugln(['Hint: TSimpleWebServerController.StartServerInstance END']); end; end; function TSimpleWebServerController.StopServerInstance(Instance: TSWSInstance; Interactive: boolean): boolean; var aThread: TSWServerThread; begin Result:=false; if Interactive then ; case Instance.State of swssNone: exit(true); swssStarting: exit(false); swssRunning: ; swssStopping: exit(false); end; if ConsoleVerbosity>1 then debugln(['Hint: TSimpleWebServerController.StopServer START Port=',Instance.Port,' Origin=',Instance.Origin,' ',MaybeQuote(Instance.ExeUsed)]); SetServerState(Instance,swssStopping); try aThread:=Instance.Thread; if aThread=nil then begin Result:=true; exit; end; aThread.ShutDown(true); if aThread.TheProcess<>nil then begin Instance.ExitCode:=aThread.TheProcess.ExitCode; if (Instance=FMainSrvInstance) and (Instance.ExitCode=1) then FMainSrvError:=swseBindingOfSocketFailed; end else Instance.ExitCode:=0; FreeAndNil(Instance.Thread); Instance.ExeUsed:=''; Instance.PathUsed:=''; Result:=true; finally SetServerState(Instance,swssNone); end; if ConsoleVerbosity>1 then debugln(['Hint: TSimpleWebServerController.StopServer END']); end; procedure TSimpleWebServerController.StopAllServers; function CleanUp: boolean; var i: Integer; Instance: TSWSInstance; aThread: TSWServerThread; begin for i:=ServerCount-1 downto 0 do begin Instance:=Servers[i]; aThread:=Instance.Thread; if (Instance.State<>swssRunning) or ((aThread<>nil) and aThread.Finished) then begin FInstances.Remove(Instance); if Instance=FMainSrvInstance then FMainSrvInstance:=nil; Instance.Free; end; end; Result:=ServerCount=0; end; procedure TerminateSrv(Instance: TSWSInstance); var aThread: TSWServerThread; begin aThread:=Instance.Thread; if (Instance.State=swssRunning) and (aThread<>nil) then begin Instance.State:=swssStopping; aThread.TerminateProcess; aThread.Terminate; end; end; var i: Integer; Instance: TSWSInstance; begin // terminate all processes and threads for i:=0 to ServerCount-1 do TerminateSrv(Servers[i]); if CleanUp then exit; // wait for all threads (max 2 seconds) i:=0; repeat sleep(15); // windows sleep has a resolution of 1/64th of a second CheckSynchronize(1); inc(i); until CleanUp or (i=140); // free all instances FMainSrvInstance:=nil; for i:=ServerCount-1 downto 0 do begin Instance:=Servers[i]; Instance.Free; end; FInstances.Clear; end; function TSimpleWebServerController.GetMainServerExeHint: string; begin Result:='see Tools / Options / Environment / Simple Web Server / Simpleserver'; end; constructor TSimpleWebServerController.Create(AOwner: TComponent); var h: TSWSCHandler; begin inherited Create(AOwner); FUtility:=TSimpleWebServerUtility.Create; FViewCaption:='Simple Web Server'; FUtility.ViewCaption:=FViewCaption; FMainSrvBindAny:=false; FMainSrvAddr:=SWSDefaultServerAddr; fAPIPath:=SWSDefaultAPIPath; FLocations:=TObjectList.Create; FLogLines:=TStringListUTF8Fast.Create; FInstances:=TFPList.Create; FMainSrvInstance:=TSWSInstance.Create; FInstances.Add(FMainSrvInstance); FMainSrvInstance.Controller:=Self; FMainSrvInstance.Port:=SWSDefaultServerPort; FMainSrvInstance.Exe:='simpleserver'+GetExeExt; for h in TSWSCHandler do fHandlers[h]:=TMethodList.Create; FOptions:=TSimpleWebServerOptions.Create; FOptions.AddHandlerApply(@OnApplyOptions); LazarusIDE.AddHandlerOnIDEClose(@OnIDEClose); end; destructor TSimpleWebServerController.Destroy; var h: TSWSCHandler; begin FDestroying:=true; StopAllServers; UnhookMacros; FreeAndNil(FInstances); FreeAndNil(FOptions); for h in TSWSCHandler do FreeAndNil(fHandlers[h]); FreeAndNil(FLogLines); FreeAndNil(FLocations); FreeAndNil(FUtility); inherited Destroy; end; function TSimpleWebServerController.StartMainServer(Interactive: boolean ): boolean; function ErrDlg(aCaption, aMsg: string; IsExe: boolean): TModalResult; var s: String; begin s:=ViewCaption+':'+sLineBreak +aMsg+sLineBreak; if IsExe then s:=s+GetMainServerExeHint; Result:=IDEMessageDialog(aCaption,s,mtError,[mbOk]); end; var LazCfgDir, PathUsed, IniFilename, ErrMsg, ExeUsed: String; IniLines: TStringListUTF8Fast; MsgResult: TModalResult; SecretGUID: TGUID; i: Integer; Loc: TSWSLocation; begin Result:=false; case MainSrvState of swssNone: ; swssStopping: exit(false); swssStarting: exit(false); swssRunning: exit(true); end; if ConsoleVerbosity>1 then debugln(['Hint: TSimpleWebServerController.StartMainServer START']); LazCfgDir:=AppendPathDelim(LazarusIDE.GetPrimaryConfigPath); PathUsed:=LazCfgDir+SWSMainServerPath; IniFilename:=LazCfgDir+SWSCompileServerIni; CreateGUID(SecretGUID); FAPIKey:=''; for i:=0 to 15 do FAPIKey:=FAPIKey+HexStr(PByte(@SecretGUID)[i],2); if not ForceDirectoriesUTF8(PathUsed) then begin ErrMsg:=rsSWErrorCreatingDirectory+' "'+PathUsed+'"'; AddIDEMessageInfo('20220414180151',ErrMsg); if Interactive then ErrDlg(rsSWError, ErrMsg, false); exit; end; FMainSrvInstance.Params.Free; FMainSrvInstance.Params:=TStringListUTF8Fast.Create; FMainSrvInstance.Params.Add('-c'); FMainSrvInstance.Params.Add(IniFilename); // append custom options last FMainSrvInstance.Params.AddStrings(Options.ServerOpts); FMainSrvInstance.Path:=PathUsed; ExeUsed:=Options.ServerExe; ErrMsg:=CheckWebServerExeQuality(ExeUsed,'',false); FMainSrvInstance.Exe:=ExeUsed; if ErrMsg<>'' then begin if Options.ServerExe<>ExeUsed then ErrMsg:=ErrMsg+'. Path="'+ExeUsed+'"'; debugln(['Error: [TSimpleWebServerController.StartServerInstance] invalid ServerExe="',Options.ServerExe,'".']); AddIDEMessageInfo('20220118164525',ErrMsg); if Interactive then ErrDlg(rsSWError, Format(rsSWWrongCompileserverExe, [ErrMsg]), true); exit; end; // create workdir while not DirectoryExistsUTF8(PathUsed) do begin if CreateDirUTF8(PathUsed) then break; MsgResult:=IDEMessageDialog(rsSWError, ViewCaption+':'+sLineBreak +rsSWErrorCreatingDirectory+sLineBreak +'"'+PathUsed+'"'+sLineBreak, mtError,[mbRetry,mbCancel]); case MsgResult of mrRetry: ; else exit(false); end; end; // write main server ini IniLines:=TStringListUTF8Fast.Create; try IniLines.Add('[Server]'); IniLines.Add('SimpleServer=1'); IniLines.Add('NoIndexPage=1'); if MainSrvBindAny then IniLines.Add('Interface=0.0.0.0') else IniLines.Add('Interface='+MainSrvAddr); IniLines.Add('Port='+IntToStr(MainSrvPort)); IniLines.Add('Directory='+PathUsed); IniLines.Add('API='+MainSrvAPIPath+','+MainSrvAPIKey); IniLines.Add('[Locations]'); for i:=0 to LocationCount-1 do begin Loc:=Locations[i]; if not Loc.Enable then continue; if not DirectoryExists(Loc.Path) then begin AddIDEMessageInfo('20220118165651','Warn: location "'+Loc.Location+'" directory not found: "'+Loc.Path+'"'); Loc.ErrorDesc:=rsSWDirectoryNotFound; continue; end else Loc.ErrorDesc:=''; IniLines.Add(Loc.Location+'='+Loc.Path); end; repeat Result:=false; try if ConsoleVerbosity>=0 then debugln(['Hint: [simplewebserver_startserver] writing ',IniFilename]); IniLines.SaveToFile(IniFilename); Result:=true; except on E: Exception do begin FMainSrvInstance.ErrorDesc:='Error writing server ini "'+IniFilename+'".'; AddIDEMessageInfo('20220127123435',FMainSrvInstance.ErrorDesc); if Interactive then begin MsgResult:=IDEMessageDialog(rsSWError, ViewCaption+':'+sLineBreak +Format(rsSWErrorWriting, [IniFilename])+sLineBreak +E.Message, mtError,[mbRetry,mbCancel]); case MsgResult of mrRetry: continue; else exit(false); end; end; end; end; until Result; finally IniLines.Free; end; Result:=StartServerInstance(FMainSrvInstance,true,Interactive); end; function TSimpleWebServerController.StopMainServer(Interactive: boolean ): boolean; begin Result:=StopServerInstance(FMainSrvInstance,Interactive); end; function TSimpleWebServerController.AddLocation(Location, Path, Origin: string; Enable: boolean): TSWSLocation; var i: Integer; ExpPath: String; DirNotFound: Boolean; begin Result:=nil; debugln(['Hint: (TSimpleWebServerController.AddLocation) Location="',Location,'" Path="',Path,'" Origin="',Origin,'" Enable=',Enable]); ExpPath:=ExpandFileNameUTF8(Path); if Location=SWSDefaultAPIPath then begin AddIDEMessageInfo('20220119150200','invalid location "'+Location+'"'); exit; end; DirNotFound:=not DirectoryExistsUTF8(ExpPath); if DirNotFound then begin AddIDEMessageInfo('20220110182017','Directory not found "'+ExpPath+'"'); Enable:=false; end; i:=IndexOfLocation(Location); if i<0 then begin Result:=TSWSLocation.Create; Result.Location:=Location; Result.Path:=ExpPath; Result.Origin:=Origin; Result.Enable:=Enable; if DirNotFound then Result.ErrorDesc:='Directory not found'; FLocations.Add(Result); end else begin // already exists Result:=Locations[i]; if DirNotFound then Result.ErrorDesc:=rsSWDirectoryNotFound; if (Result.Enable=Enable) and (Result.Path=ExpPath) and (Result.Origin=Origin) then exit; if Result.Enable then begin if Result.Path=ExpPath then begin Result.Origin:=Origin; LocationsChanged; if not Enable then RemoveServerLocation(Location); exit; end else begin // active location, ExpPath change end; end else begin // location was not active end; Result.Enable:=Enable; Result.Path:=ExpPath; Result.Origin:=Origin; end; LocationsChanged; if Enable then AddServerLocation(Location,ExpPath); end; function TSimpleWebServerController.AddProjectLocation(aProject: TLazProject; Location, Path: string; Interactive: boolean): TSWSLocation; var aServer: TSWSInstance; function StopOldServer(ID: int64; const Msg: string): boolean; begin if not StopServer(aServer,Interactive) then begin debugln(['Error: TSimpleWebServerController.AddProjectLocation ',ID,': ',Msg,', unable to stop old server']); exit(false); end; aServer:=nil; Result:=true; end; var Origin: String; begin Result:=nil; if aProject.IsVirtual then Origin:=SWSTestprojectOrigin else Origin:=aProject.ProjectInfoFile; aServer:=FindServerWithOrigin(Origin); if (aServer<>nil) and (aServer<>MainSrvInstance) then if not StopOldServer(20220423152004,'Path changed') then exit; Result:=AddLocation(Location,Path,Origin,true); if not StartMainServer(Interactive) then exit(nil); end; procedure TSimpleWebServerController.DeleteLocation(Location: string); var i: Integer; Loc: TSWSLocation; WasEnabled: Boolean; begin if Destroying then exit; i:=IndexOfLocation(Location); if i<0 then begin debugln(['Warn: (TSimpleWebServerController.DeleteLocation) Location not found "',Location,'" ']); exit; end; Loc:=Locations[i]; debugln(['Hint: (TSimpleWebServerController.DeleteLocation) Location="',Loc.Location,'" Path="',Loc.Path,'" Origin="',Loc.Origin,'" Enabled=',Loc.Enable]); WasEnabled:=Loc.Enable; FLocations.Delete(i); LocationsChanged; if WasEnabled then RemoveServerLocation(Location); end; procedure TSimpleWebServerController.EnableLocation(Location: string; Enable: boolean); var i: Integer; Loc: TSWSLocation; begin if Destroying then exit; i:=IndexOfLocation(Location); if i<0 then begin debugln(['Warn: (TSimpleWebServerController.EnableLocation) Location not found "',Location,'" ']); exit; end; Loc:=Locations[i]; if Loc.Enable=Enable then exit; debugln(['Hint: (TSimpleWebServerController.EnableLocation) Location="',Loc.Location,'" Path="',Loc.Path,'" Origin="',Loc.Origin,'" Enable=',Enable]); Loc.Enable:=Enable; LocationsChanged; if Enable then begin AddServerLocation(Loc.Location,Loc.Path); end else begin RemoveServerLocation(Loc.Location); end; end; function TSimpleWebServerController.IndexOfLocation(Location: string): integer; begin Result:=0; repeat if Result=LocationCount then exit(-1); if Locations[Result].Location=Location then exit; inc(Result); until false; end; function TSimpleWebServerController.FindLocation(Location: string ): TSWSLocation; var i: Integer; begin i:=IndexOfLocation(Location); if i<0 then Result:=nil else Result:=Locations[i]; end; function TSimpleWebServerController.FindLocationWithOrigin(Origin: string ): TSWSLocation; var i: Integer; begin for i:=0 to LocationCount-1 do begin Result:=Locations[i]; if Result.Origin=Origin then exit; end; Result:=nil; end; procedure TSimpleWebServerController.AddHandlerLocationsChanged( const OnLocationsChanged: TNotifyEvent; AsLast: boolean); begin fHandlers[swschLocationsChanged].Add(TMethod(OnLocationsChanged),AsLast); end; procedure TSimpleWebServerController.RemoveHandlerLocationsChanged( const OnLocationsChanged: TNotifyEvent); begin fHandlers[swschLocationsChanged].Remove(TMethod(OnLocationsChanged)); end; procedure TSimpleWebServerController.AddHandlerStateChanged( const OnStateChanged: TSWServerStateChangedEvent; AsLast: boolean); begin fHandlers[swschStateChanged].Add(TMethod(OnStateChanged),AsLast); end; procedure TSimpleWebServerController.RemoveHandlerStateChanged( const OnStateChanged: TSWServerStateChangedEvent); begin fHandlers[swschStateChanged].Remove(TMethod(OnStateChanged)); end; procedure TSimpleWebServerController.AddHandlerServerLog( const OnServerLog: TSWServerLogEvent; AsLast: boolean); begin fHandlers[swschServerLog].Add(TMethod(OnServerLog),AsLast); end; procedure TSimpleWebServerController.RemoveHandlerServerLog( const OnServerLog: TSWServerLogEvent); begin fHandlers[swschServerLog].Remove(TMethod(OnServerLog)); end; procedure TSimpleWebServerController.RemoveAllHandlersOfObject(AnObject: TObject); var h: TSWSCHandler; begin for h in TSWSCHandler do fHandlers[h].RemoveAllMethodsOfObject(AnObject); end; function TSimpleWebServerController.AddServer(Port: word; Exe: string; Params: TStrings; Path, Origin: string; ResolveMacros, Interactive: boolean ): TSWSInstance; begin Result:=nil; try if Port=0 then Port:=FindFreePort(Interactive,true); if FindServerWithPort(Port)<>nil then raise ESimpleWebServerException.Create('port '+IntToStr(Port)+' already in use'); Result:=TSWSInstance.Create; Result.Controller:=Self; Result.Port:=Port; Result.Exe:=Exe; Result.Params:=Params; Result.Path:=Path; Result.Origin:=Origin; FInstances.Add(Result); finally if Result=nil then Params.Free; end; try StartServerInstance(Result,ResolveMacros,Interactive); finally LocationsChanged; end; end; function TSimpleWebServerController.AddProjectServer(aProject: TLazProject; Port: word; Path: string; Interactive: boolean): TSWSInstance; var aServer: TSWSInstance; function StopOldServer(ID: int64; const Msg: string): boolean; begin if not StopServer(aServer,Interactive) then begin debugln(['Error: TSimpleWebServerController.AddProjectServer ',ID,': ',Msg,', unable to stop old server']); exit(false); end; aServer:=nil; Result:=true; end; var Exe, Origin, aProcDescription, SrvAddr: String; Params: TStringList; ConflictServer: TSWSInstance; IPAddr: in_addr; aPID: integer; r: TModalResult; aLocation: TSWSLocation; begin Result:=nil; if aProject.IsVirtual then Origin:=SWSTestprojectOrigin else Origin:=aProject.ProjectInfoFile; aLocation:=FindLocationWithOrigin(Origin); if aLocation<>nil then DeleteLocation(aLocation.Location); aServer:=FindServerWithOrigin(Origin); if (aServer=nil) and not aProject.IsVirtual then aServer:=FindServerWithOrigin(SWSTestprojectOrigin); if aServer=FMainSrvInstance then begin debugln(['Error: TSimpleWebServerController.AddProjectServer 20220423165802 origin=mainsrv origin']); IDEMessageDialog('Error','Conflict with main server',mtError,[mbOk]); exit; end; if (aServer<>nil) and (aServer.Path<>Path) then if not StopOldServer(20220410145323,'Path changed') then exit; if (aServer<>nil) and (Port>0) and (aServer.Port<>Port) then if not StopOldServer(20220410145340,'Port changed') then exit; Exe:=GetDefaultServerExe; if (aServer<>nil) and (aServer.Exe<>Exe) then if not StopOldServer(20220410145357,'ServerExe changed') then exit; if Port=0 then begin if aServer<>nil then Port:=aServer.Port // keep port else Port:=FindFreePort(Interactive,true); end else begin ConflictServer:=FindServerWithPort(Port); if (ConflictServer<>nil) and (ConflictServer<>aServer) then begin // conflicting server if (ConflictServer=MainSrvInstance) or not Interactive then r:=mrRetry else r:=IDEQuestionDialog(rsSWError, Format(rsSWThereIsAlreadyAServerOnPortOriginPath, [IntToStr(Port), sLineBreak, ConflictServer.Origin+sLineBreak, ConflictServer.Path+ sLineBreak]), mtError,[mrYes, rsSWStopServer, mrRetry, rsSWTryAnotherPort, mrCancel], ''); case r of mrYes: if not StopServer(ConflictServer,Interactive) then exit; mrRetry: Port:=FindFreePort(Interactive,true); else exit; end; end else if (aServer=nil) or (aServer.ErrorDesc<>'') then begin SrvAddr:='127.0.0.1'; IPAddr:=StrToHostAddr(SrvAddr); if FUtility.FindProcessListeningOnPort(IPAddr,Port,aProcDescription,aPID) then begin // conflicting foreign process r:=IDEQuestionDialog(rsSWError, ViewCaption+':'+sLineBreak +rsSWBindingOfSocketFailed+': '+SrvAddr+':'+IntToStr(Port)+sLineBreak +sLineBreak +rsSWTheFollowingProcessAlreadyListens+sLineBreak +'PID: '+IntToStr(aPID)+sLineBreak +aProcDescription+sLineBreak +sLineBreak +rsSWKillProcess , mtError, [mrYes, Format(rsSWKillPID, [IntToStr(aPID)]), mrRetry, rsSWTryAnotherPort, mrCancel], ''); case r of mrYes: if not FUtility.KillProcess(aPID) then exit; mrRetry: begin Port:=FindFreePort(true,true); end; else exit; end; end; end; end; Params:=TStringList.Create; try Params.Add('-s'); Params.Add('-n'); Params.Add('-I'); Params.Add('127.0.0.1'); Params.Add('--port='+IntToStr(Port)); if (aServer<>nil) and not Params.Equals(aServer.Params) then if not StopOldServer(20220410145559,'Params changed') then exit; if aServer<>nil then begin aServer.Origin:=Origin; Result:=aServer; exit; end; Result:=AddServer(Port,Exe,Params,Path,Origin,false,Interactive); finally Params.Free; end; end; function TSimpleWebServerController.FindServerWithPort(Port: word): TSWSInstance; var i: Integer; begin for i:=0 to ServerCount-1 do if Servers[i].Port=Port then exit(Servers[i]); Result:=nil; end; function TSimpleWebServerController.FindServerWithOrigin(Origin: string ): TSWSInstance; var i: Integer; begin for i:=0 to ServerCount-1 do if Servers[i].Origin=Origin then exit(Servers[i]); Result:=nil; end; function TSimpleWebServerController.FindFreePort(Interactive, CheckServers: boolean; aStartPort: word): word; var AvoidPorts: TWordDynArray; i: Integer; begin if aStartPort=0 then aStartPort:=MainSrvPort; if CheckServers then begin Setlength(AvoidPorts{%H-},ServerCount); for i:=0 to ServerCount-1 do AvoidPorts[i]:=Servers[i].Port; end else AvoidPorts:=nil; Result:=FUtility.FindFreePort(aStartPort,Interactive,AvoidPorts); end; function TSimpleWebServerController.StopServer(Instance: TSWSInstance; Interactive: boolean): boolean; begin if Instance=FMainSrvInstance then Result:=StopMainServer(Interactive) else Result:=StopServerInstance(Instance,Interactive); end; function TSimpleWebServerController.SubstitutePortMacro(aValue, aPort: string ): string; var l, i: SizeInt; begin Result:=aValue; //debugln(['TSimpleWebServerController.SubstitutePortMacro Value="',aValue,'" Port=',aPort]); l:=length('$(port)'); for i:=length(Result)-l+1 downto 1 do begin if (Result[i]='$') and SameText(copy(Result,i,l),'$(port)') then LazStringUtils.ReplaceSubstring(Result,i,l,aPort); end; //debugln(['TSimpleWebServerController.SubstitutePortMacro Result="',Result,'"']); end; function TSimpleWebServerController.SubstituteURLMacro(aValue, AnURL: string ): string; var l, i: SizeInt; begin Result:=aValue; l:=length('$(url)'); for i:=length(Result)-l+1 downto 1 do begin if (Result[i]='$') and SameText(copy(Result,i,l),'$(url)') then LazStringUtils.ReplaceSubstring(Result,i,l,AnURL); end; end; function TSimpleWebServerController.GetDefaultServerExe: string; begin Result:=Options.ServerExe; if IDEMacros.SubstituteMacros(Result) then exit; debugln(['TSimpleWebServerController.GetDefaultServerExe Options.ServerExe=[',Options.ServerExe,']']); raise Exception.Create('TSimpleWebServerController.GetDefaultServerExe: invalid macro'); end; function TSimpleWebServerController.GetURLWithServer(aServer: TSWSInstance; HTMLFilename: string): string; begin if HTMLFilename<>'' then begin Result:=CreateRelativePath(HTMLFilename,aServer.Path); Result:=FilenameToURLPath(Result); end else Result:=''; Result:='http://'+MainSrvAddr+':'+IntToStr(aServer.Port)+'/'+Result; end; function TSimpleWebServerController.GetURLWithLocation(aLocation: TSWSLocation; HTMLFilename: string): string; begin if HTMLFilename<>'' then begin Result:=CreateRelativePath(HTMLFilename,aLocation.Path); Result:=FilenameToURLPath(Result); end else Result:=''; Result:='http://'+MainSrvAddr+':'+IntToStr(MainSrvPort)+'/'+aLocation.Location+'/'+Result; end; function TSimpleWebServerController.OpenBrowserWithURL(URL, WorkDir: string ): boolean; var Params: TStringList; Exe: String; Tool: TIDEExternalToolOptions; begin Params:=TStringList.Create; try Exe:=GetBrowser(URL,Params); if Exe='' then begin IDEMessageDialog(rsSWError, rsSWCannotFindBrowserSee+sLineBreak +rsSWToolsOptionsSimpleWebServerBrowser,mtError,[mbOk]); exit(false); end; Tool:=TIDEExternalToolOptions.Create; Tool.Title:='Browser('+ExtractFileName(Exe)+')'; Tool.Executable:=Exe; Tool.CmdLineParams:=MergeCmdLineParams(Params); Tool.WorkingDirectory:=WorkDir; Tool.MaxIdleInMS:=1000; Result:=RunExternalTool(Tool); finally Params.Free; end; end; function TSimpleWebServerController.OpenBrowserWithLocation( aLocation: TSWSLocation; HTMLFilename: string): boolean; var URL: String; begin if aLocation=nil then raise Exception.Create('TSimpleWebServerController.OpenBrowserWithLocation 20220423153505'); if not FilenameIsAbsolute(HTMLFilename) then raise Exception.Create('TSimpleWebServerController.OpenBrowserWithLocation 20220423153507'); URL:=GetURLWithLocation(aLocation,HTMLFilename); Result:=OpenBrowserWithURL(URL,ExtractFilePath(HTMLFilename)); end; function TSimpleWebServerController.OpenBrowserWithServer( aServer: TSWSInstance; HTMLFilename: string): boolean; var URL: String; begin if aServer=nil then raise Exception.Create('TSimpleWebServerController.OpenBrowserWithServer 20220410185207'); if not FilenameIsAbsolute(HTMLFilename) then raise Exception.Create('TSimpleWebServerController.OpenBrowserWithServer 20220410185208'); URL:=GetURLWithServer(aServer,HTMLFilename); Result:=OpenBrowserWithURL(URL,ExtractFilePath(HTMLFilename)); end; function TSimpleWebServerController.FindBrowserFile(ShortFilename: string ): string; begin Result := SearchFileInPath(ShortFilename + GetExeExt, '', GetEnvironmentVariableUTF8('PATH'), PathSeparator, [sffDontSearchInBasePath]); end; function TSimpleWebServerController.FindBrowserPath(Filenames: array of string; URL: string; Params: TStrings): string; var i: Integer; aFilename: String; begin Result:=''; for i:=low(Filenames) to high(Filenames) do begin aFilename:=Filenames[i]; if FilenameIsAbsolute(aFilename) then begin if FileExistsCached(aFilename) then begin Result:=aFilename; break; end; end else begin Result := FindBrowserFile(aFilename); if Result<>'' then break; end; end; if Result<>'' then begin Params.Add(URL); end; end; function TSimpleWebServerController.GetBrowser(URL: string; Params: TStrings ): string; var Cmd: String; begin Result:=''; case Options.BrowserKind of swsbkCustom: begin Cmd:=Options.BrowserCmd; Cmd:=SubstituteURLMacro(Cmd,URL); if not IDEMacros.SubstituteMacros(Cmd) then begin IDEMessageDialog(rsSWError, rsSWInvalidMacroSee+sLineBreak + rsSWToolsOptionsSimpleWebServerBrowser,mtError,[mbOk]); exit; end; SplitCmdLineParams(Cmd,Params); if Params.Count>0 then begin Result:=Params[0]; Params.Delete(0); end; end; swsbkFirefox: Result:=GetBrowserFirefox(URL,Params); swsbkChrome: Result:=GetBrowserChrome(URL,Params); swsbkOpera: Result:=GetBrowserOpera(URL,Params); swsbkVivaldi: Result:=GetBrowserVivaldi(URL,Params); {$IFDEF Darwin} swsbkSafari: Result:=GetBrowserSafari(URL,Params); {$ENDIF} {$IFDEF MSWindows} swsbkEdge: Result:=GetBrowserEdge(URL,Params); {$ENDIF} else begin FindDefaultBrowser(Result,Cmd); Cmd:=Format(Cmd,[URL]); SplitCmdLineParams(Cmd,Params); end; end; end; function TSimpleWebServerController.GetBrowserChrome(URL: string; Params: TStrings): string; begin Result := FindBrowserPath([ {$IFDEF Darwin}'/Applications/Google Chrome.app/Contents/MacOS/Google Chrome',{$ENDIF} {$IFDEF MSWindows}'C:\Program Files (x86)\Google\Chrome\Application\chrome.exe',{$ENDIF} 'google-chrome'],URL,Params); end; function TSimpleWebServerController.GetBrowserFirefox(URL: string; Params: TStrings): string; begin Result := FindBrowserPath([ {$IFDEF Darwin}'/Applications/Firefox.app/Contents/MacOS/firefox',{$ENDIF} {$IFDEF MSWindows}'C:\Program Files\Mozilla Firefox\firefox.exe',{$ENDIF} 'firefox','mozilla'],URL,Params); end; function TSimpleWebServerController.GetBrowserOpera(URL: string; Params: TStrings): string; begin Result := FindBrowserPath([ {$IFDEF Darwin}'/Applications/Opera.app/Contents/MacOS/Opera',{$ENDIF} 'opera'],URL,Params); end; function TSimpleWebServerController.GetBrowserVivaldi(URL: string; Params: TStrings): string; begin Result := FindBrowserPath([ {$IFDEF Darwin}'/Applications/Vivaldi.app/Contents/MacOS/Vivaldi',{$ENDIF} 'vivaldi'],URL,Params); end; {$IFDEF Darwin} function TSimpleWebServerController.GetBrowserSafari(URL: string; Params: TStrings ): string; begin Result := FindBrowserPath(['/Applications/Safari.app/Contents/MacOS/Safari','safari'],URL,Params); end; {$ENDIF} {$IFDEF MSWindows} function TSimpleWebServerController.GetBrowserEdge(URL: string; Params: TStrings ): string; begin Result := FindBrowserPath([ 'C:\Program Files (x86)\Microsoft\Edge\Application\msedge.exe', 'edge'],URL,Params); end; {$ENDIF} procedure TSimpleWebServerController.HookMacros; function Add(const AName, ADescription: string; AMacroFunction: TMacroFunction): TTransferMacro; begin Result:=TTransferMacro.Create(AName, '', ADescription, AMacroFunction, []); IDEMacros.Add(Result); end; begin IDEMacroSWSAddress:=Add('SWSAddress', rsSWSimpleWebServerAddress, @GetSWSAddress); IDEMacroSWSPort:=Add('SWSPort', rsSWSimpleWebServerPort, @GetSWSPort); IDEMacroSWSExe:=Add('SWSExe', rsSWSimpleWebServerExecutable, @GetSWSExe); end; procedure TSimpleWebServerController.UnhookMacros; begin // nothing at the moment end; { TSWServerThread } procedure TSWServerThread.Execute; var Buf: string; function ReadInputPipe(aStream: TInputPipeStream; var LineBuf: string; IsStdErr: boolean): boolean; // true if some bytes have been read var Count: DWord; StartPos: Integer; i: DWord; begin Result:=false; if Terminated or (aStream=nil) then exit; Count:=aStream.NumBytesAvailable; if Count=0 then exit; Count:=aStream.Read(Buf[1],Min(length(Buf),Count)); if Count=0 then exit; Result:=true; StartPos:=1; i:=1; while i<=Count do begin if Buf[i] in [#10,#13] then begin LineBuf:=LineBuf+copy(Buf,StartPos,i-StartPos); if IsStdErr then ; FOutLines.Add(LineBuf); LineBuf:=''; if (iBuf[i+1]) then inc(i); StartPos:=i+1; end; inc(i); end; LineBuf:=LineBuf+copy(Buf,StartPos,Count-StartPos+1); end; var OutputLine, StdErrLine: String; HasOutput: Boolean; begin OutputLine:=''; StdErrLine:=''; Buf:=''; SetLength(Buf,4096); try repeat if Terminated then exit; HasOutput:=ReadInputPipe(TheProcess.Stderr,StdErrLine,true) or ReadInputPipe(TheProcess.Output,OutputLine,false); if (not HasOutput) then begin // no more pending output HandleOutput; if Terminated then exit; if not TheProcess.Running then break; // no more pending output and process is still running -> wait a bit RTLEventWaitFor(fSleepEvent,500); end; until false; // add rest of output if (OutputLine<>'') then FOutLines.Add(OutputLine); if (StdErrLine<>'') then FOutLines.Add(StdErrLine); if not Terminated then FOutLines.Add('ExitCode='+IntToStr(TheProcess.ExitCode)+' ExitStatus='+IntToStr(TheProcess.ExitStatus)); HandleOutput; //DebugLn(['Hint: [simplewebserver_serverthread] ExitCode=',TheProcess.ExitCode,' ExitStatus=',TheProcess.ExitStatus]); finally Application.QueueAsyncCall(@QueuedFinished,0); end; end; procedure TSWServerThread.HandleOutput; begin if Terminated then exit; if (FOutLines.Count=0) then exit; Synchronize(@SynchronizedHandleOuput); end; procedure TSWServerThread.SynchronizedHandleOuput; begin if Assigned(OnOutput) then OnOutput(Self,FOutLines); FOutLines.Clear; end; procedure TSWServerThread.QueuedFinished(Data: PtrInt); begin if Assigned(OnFinished) then OnFinished(Owner); end; constructor TSWServerThread.Create(TheOwner: TSWSInstance; aProcess: TProcess); begin inherited Create(true); FOwner:=TheOwner; TheProcess:=aProcess; FOutLines:=TStringList.Create; fSleepEvent:=RTLEventCreate; end; destructor TSWServerThread.Destroy; begin ShutDown(false); Application.RemoveAsyncCalls(Self); FreeAndNil(TheProcess); RTLEventDestroy(fSleepEvent); FreeAndNil(FOutLines); inherited Destroy; end; procedure TSWServerThread.ShutDown(Gracefully: boolean); begin if Finished then exit; TerminateProcess; if not Gracefully then Terminate; RTLEventSetEvent(fSleepEvent); // wake up thread while not Finished do begin Application.ProcessMessages; if Finished then break; sleep(20); end; end; procedure TSWServerThread.TerminateProcess; begin if TheProcess<>nil then TheProcess.Terminate(0); end; finalization FreeAndNil(SimpleWebServerController); end.