Code improvements
Fixed memory leak in the installer Added diagnostics info to configuration app
This commit is contained in:
binarymaster
@ -20,7 +20,7 @@ interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls, Spin, ExtCtrls, Registry;
|
||||
Dialogs, StdCtrls, Spin, ExtCtrls, Registry, WinSvc;
|
||||
|
||||
type
|
||||
TMainForm = class(TForm)
|
||||
@ -33,7 +33,19 @@ type
|
||||
rgShadow: TRadioGroup;
|
||||
seRDPPort: TSpinEdit;
|
||||
lRDPPort: TLabel;
|
||||
lService: TLabel;
|
||||
lListener: TLabel;
|
||||
lWrapper: TLabel;
|
||||
lsListener: TLabel;
|
||||
lsService: TLabel;
|
||||
lsWrapper: TLabel;
|
||||
Timer: TTimer;
|
||||
lTSVer: TLabel;
|
||||
lsTSVer: TLabel;
|
||||
lWrapVer: TLabel;
|
||||
lsWrapVer: TLabel;
|
||||
bLicense: TButton;
|
||||
gbDiag: TGroupBox;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure cbAllowTSConnectionsClick(Sender: TObject);
|
||||
procedure seRDPPortChange(Sender: TObject);
|
||||
@ -42,6 +54,8 @@ type
|
||||
procedure bOKClick(Sender: TObject);
|
||||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
procedure bLicenseClick(Sender: TObject);
|
||||
procedure TimerTimer(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
public
|
||||
@ -49,10 +63,36 @@ type
|
||||
procedure ReadSettings;
|
||||
procedure WriteSettings;
|
||||
end;
|
||||
FILE_VERSION = record
|
||||
Version: record case Boolean of
|
||||
True: (dw: DWORD);
|
||||
False: (w: record
|
||||
Minor, Major: Word;
|
||||
end;)
|
||||
end;
|
||||
Release, Build: Word;
|
||||
bDebug, bPrerelease, bPrivate, bSpecial: Boolean;
|
||||
end;
|
||||
WTS_SESSION_INFOW = record
|
||||
SessionId: DWORD;
|
||||
Name: packed array [0..33] of WideChar;
|
||||
State: DWORD;
|
||||
end;
|
||||
WTS_SESSION = Array[0..0] of WTS_SESSION_INFOW;
|
||||
PWTS_SESSION_INFOW = ^WTS_SESSION;
|
||||
|
||||
const
|
||||
winstadll = 'winsta.dll';
|
||||
var
|
||||
MainForm: TMainForm;
|
||||
Ready: Boolean = False;
|
||||
Arch: Byte;
|
||||
OldWow64RedirectionValue: LongBool;
|
||||
|
||||
function WinStationEnumerateW(hServer: THandle;
|
||||
var ppSessionInfo: PWTS_SESSION_INFOW; var pCount: DWORD): BOOL; stdcall;
|
||||
external winstadll name 'WinStationEnumerateW';
|
||||
function WinStationFreeMemory(P: Pointer): BOOL; stdcall; external winstadll;
|
||||
|
||||
implementation
|
||||
|
||||
@ -62,6 +102,214 @@ implementation
|
||||
uses
|
||||
LicenseUnit;
|
||||
|
||||
function ExpandPath(Path: String): String;
|
||||
var
|
||||
Str: Array[0..511] of Char;
|
||||
begin
|
||||
Result := '';
|
||||
FillChar(Str, 512, 0);
|
||||
if Arch = 64 then
|
||||
Path := StringReplace(Path, '%ProgramFiles%', '%ProgramW6432%', [rfReplaceAll, rfIgnoreCase]);
|
||||
if ExpandEnvironmentStrings(PWideChar(Path), Str, 512) > 0 then
|
||||
Result := Str;
|
||||
end;
|
||||
|
||||
function DisableWowRedirection: Boolean;
|
||||
type
|
||||
TFunc = function(var Wow64FsEnableRedirection: LongBool): LongBool; stdcall;
|
||||
var
|
||||
hModule: THandle;
|
||||
Wow64DisableWow64FsRedirection: TFunc;
|
||||
begin
|
||||
Result := False;
|
||||
hModule := GetModuleHandle(kernel32);
|
||||
if hModule <> 0 then
|
||||
Wow64DisableWow64FsRedirection := GetProcAddress(hModule, 'Wow64DisableWow64FsRedirection')
|
||||
else
|
||||
Exit;
|
||||
if @Wow64DisableWow64FsRedirection <> nil then
|
||||
Result := Wow64DisableWow64FsRedirection(OldWow64RedirectionValue);
|
||||
end;
|
||||
|
||||
function RevertWowRedirection: Boolean;
|
||||
type
|
||||
TFunc = function(var Wow64RevertWow64FsRedirection: LongBool): LongBool; stdcall;
|
||||
var
|
||||
hModule: THandle;
|
||||
Wow64RevertWow64FsRedirection: TFunc;
|
||||
begin
|
||||
Result := False;
|
||||
hModule := GetModuleHandle(kernel32);
|
||||
if hModule <> 0 then
|
||||
Wow64RevertWow64FsRedirection := GetProcAddress(hModule, 'Wow64RevertWow64FsRedirection')
|
||||
else
|
||||
Exit;
|
||||
if @Wow64RevertWow64FsRedirection <> nil then
|
||||
Result := Wow64RevertWow64FsRedirection(OldWow64RedirectionValue);
|
||||
end;
|
||||
|
||||
function GetFileVersion(const FileName: TFileName; var FileVersion: FILE_VERSION): Boolean;
|
||||
type
|
||||
VS_VERSIONINFO = record
|
||||
wLength, wValueLength, wType: Word;
|
||||
szKey: Array[1..16] of WideChar;
|
||||
Padding1: Word;
|
||||
Value: VS_FIXEDFILEINFO;
|
||||
Padding2, Children: Word;
|
||||
end;
|
||||
PVS_VERSIONINFO = ^VS_VERSIONINFO;
|
||||
const
|
||||
VFF_DEBUG = 1;
|
||||
VFF_PRERELEASE = 2;
|
||||
VFF_PRIVATE = 8;
|
||||
VFF_SPECIAL = 32;
|
||||
var
|
||||
hFile: HMODULE;
|
||||
hResourceInfo: HRSRC;
|
||||
VersionInfo: PVS_VERSIONINFO;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
hFile := LoadLibraryEx(PWideChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE);
|
||||
if hFile = 0 then
|
||||
Exit;
|
||||
|
||||
hResourceInfo := FindResource(hFile, PWideChar(1), PWideChar($10));
|
||||
if hResourceInfo = 0 then
|
||||
Exit;
|
||||
|
||||
VersionInfo := Pointer(LoadResource(hFile, hResourceInfo));
|
||||
if VersionInfo = nil then
|
||||
Exit;
|
||||
|
||||
FileVersion.Version.dw := VersionInfo.Value.dwFileVersionMS;
|
||||
FileVersion.Release := Word(VersionInfo.Value.dwFileVersionLS shr 16);
|
||||
FileVersion.Build := Word(VersionInfo.Value.dwFileVersionLS);
|
||||
FileVersion.bDebug := (VersionInfo.Value.dwFileFlags and VFF_DEBUG) = VFF_DEBUG;
|
||||
FileVersion.bPrerelease := (VersionInfo.Value.dwFileFlags and VFF_PRERELEASE) = VFF_PRERELEASE;
|
||||
FileVersion.bPrivate := (VersionInfo.Value.dwFileFlags and VFF_PRIVATE) = VFF_PRIVATE;
|
||||
FileVersion.bSpecial := (VersionInfo.Value.dwFileFlags and VFF_SPECIAL) = VFF_SPECIAL;
|
||||
|
||||
FreeLibrary(hFile);
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
function IsWrapperInstalled(var WrapperPath: String): ShortInt;
|
||||
var
|
||||
TermServiceHost,
|
||||
TermServicePath: String;
|
||||
Reg: TRegistry;
|
||||
begin
|
||||
Result := -1;
|
||||
WrapperPath := '';
|
||||
Reg := TRegistry.Create;
|
||||
Reg.RootKey := HKEY_LOCAL_MACHINE;
|
||||
if not Reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Services\TermService') then begin
|
||||
Reg.Free;
|
||||
Exit;
|
||||
end;
|
||||
TermServiceHost := Reg.ReadString('ImagePath');
|
||||
Reg.CloseKey;
|
||||
if Pos('svchost.exe', LowerCase(TermServiceHost)) = 0 then
|
||||
begin
|
||||
Result := 2;
|
||||
Reg.Free;
|
||||
Exit;
|
||||
end;
|
||||
if not Reg.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Services\TermService\Parameters') then
|
||||
begin
|
||||
Reg.Free;
|
||||
Exit;
|
||||
end;
|
||||
TermServicePath := Reg.ReadString('ServiceDll');
|
||||
Reg.CloseKey;
|
||||
Reg.Free;
|
||||
if (Pos('termsrv.dll', LowerCase(TermServicePath)) = 0)
|
||||
and (Pos('rdpwrap.dll', LowerCase(TermServicePath)) = 0) then
|
||||
begin
|
||||
Result := 2;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if Pos('rdpwrap.dll', LowerCase(TermServicePath)) > 0 then begin
|
||||
WrapperPath := TermServicePath;
|
||||
Result := 1;
|
||||
end else
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
function GetTermSrvState: ShortInt;
|
||||
type
|
||||
SERVICE_STATUS_PROCESS = record
|
||||
dwServiceType,
|
||||
dwCurrentState,
|
||||
dwControlsAccepted,
|
||||
dwWin32ExitCode,
|
||||
dwServiceSpecificExitCode,
|
||||
dwCheckPoint,
|
||||
dwWaitHint,
|
||||
dwProcessId,
|
||||
dwServiceFlags: DWORD;
|
||||
end;
|
||||
PSERVICE_STATUS_PROCESS = ^SERVICE_STATUS_PROCESS;
|
||||
const
|
||||
SvcName = 'TermService';
|
||||
var
|
||||
hSC: SC_HANDLE;
|
||||
hSvc: THandle;
|
||||
lpServiceStatusProcess: PSERVICE_STATUS_PROCESS;
|
||||
Buf: Pointer;
|
||||
cbBufSize, pcbBytesNeeded: Cardinal;
|
||||
begin
|
||||
Result := -1;
|
||||
hSC := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_CONNECT);
|
||||
if hSC = 0 then
|
||||
Exit;
|
||||
|
||||
hSvc := OpenService(hSC, PWideChar(SvcName), SERVICE_QUERY_STATUS);
|
||||
if hSvc = 0 then
|
||||
begin
|
||||
CloseServiceHandle(hSC);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if QueryServiceStatusEx(hSvc, SC_STATUS_PROCESS_INFO, nil, 0, pcbBytesNeeded) then
|
||||
Exit;
|
||||
|
||||
cbBufSize := pcbBytesNeeded;
|
||||
GetMem(Buf, cbBufSize);
|
||||
|
||||
if not QueryServiceStatusEx(hSvc, SC_STATUS_PROCESS_INFO, Buf, cbBufSize, pcbBytesNeeded) then begin
|
||||
FreeMem(Buf, cbBufSize);
|
||||
CloseServiceHandle(hSvc);
|
||||
CloseServiceHandle(hSC);
|
||||
Exit;
|
||||
end else begin
|
||||
lpServiceStatusProcess := Buf;
|
||||
Result := ShortInt(lpServiceStatusProcess^.dwCurrentState);
|
||||
end;
|
||||
FreeMem(Buf, cbBufSize);
|
||||
CloseServiceHandle(hSvc);
|
||||
CloseServiceHandle(hSC);
|
||||
end;
|
||||
|
||||
function IsListenerWorking: Boolean;
|
||||
var
|
||||
pCount: DWORD;
|
||||
SessionInfo: PWTS_SESSION_INFOW;
|
||||
I: Integer;
|
||||
begin
|
||||
Result := False;
|
||||
if not WinStationEnumerateW(0, SessionInfo, pCount) then
|
||||
Exit;
|
||||
for I := 0 to pCount - 1 do
|
||||
if SessionInfo^[I].Name = 'RDP-Tcp' then begin
|
||||
Result := True;
|
||||
Break;
|
||||
end;
|
||||
WinStationFreeMemory(SessionInfo);
|
||||
end;
|
||||
|
||||
function ExtractResText(ResName: String): String;
|
||||
var
|
||||
ResStream: TResourceStream;
|
||||
@ -192,6 +440,98 @@ begin
|
||||
Reg.Free;
|
||||
end;
|
||||
|
||||
procedure TMainForm.TimerTimer(Sender: TObject);
|
||||
var
|
||||
WrapperPath: String;
|
||||
FV: FILE_VERSION;
|
||||
begin
|
||||
case IsWrapperInstalled(WrapperPath) of
|
||||
-1: begin
|
||||
lsWrapper.Caption := 'Unknown';
|
||||
lsWrapper.Font.Color := clGrayText;
|
||||
end;
|
||||
0: begin
|
||||
lsWrapper.Caption := 'Not installed';
|
||||
lsWrapper.Font.Color := clGrayText;
|
||||
end;
|
||||
1: begin
|
||||
lsWrapper.Caption := 'Installed';
|
||||
lsWrapper.Font.Color := clGreen;
|
||||
end;
|
||||
2: begin
|
||||
lsWrapper.Caption := '3rd-party';
|
||||
lsWrapper.Font.Color := clRed;
|
||||
end;
|
||||
end;
|
||||
case GetTermSrvState of
|
||||
-1, 0: begin
|
||||
lsService.Caption := 'Unknown';
|
||||
lsService.Font.Color := clGrayText;
|
||||
end;
|
||||
SERVICE_STOPPED: begin
|
||||
lsService.Caption := 'Stopped';
|
||||
lsService.Font.Color := clRed;
|
||||
end;
|
||||
SERVICE_START_PENDING: begin
|
||||
lsService.Caption := 'Starting...';
|
||||
lsService.Font.Color := clGrayText;
|
||||
end;
|
||||
SERVICE_STOP_PENDING: begin
|
||||
lsService.Caption := 'Stopping...';
|
||||
lsService.Font.Color := clGrayText;
|
||||
end;
|
||||
SERVICE_RUNNING: begin
|
||||
lsService.Caption := 'Running';
|
||||
lsService.Font.Color := clGreen;
|
||||
end;
|
||||
SERVICE_CONTINUE_PENDING: begin
|
||||
lsService.Caption := 'Resuming...';
|
||||
lsService.Font.Color := clGrayText;
|
||||
end;
|
||||
SERVICE_PAUSE_PENDING: begin
|
||||
lsService.Caption := 'Suspending...';
|
||||
lsService.Font.Color := clGrayText;
|
||||
end;
|
||||
SERVICE_PAUSED: begin
|
||||
lsService.Caption := 'Suspended';
|
||||
lsService.Font.Color := clWindowText;
|
||||
end;
|
||||
end;
|
||||
if IsListenerWorking then begin
|
||||
lsListener.Caption := 'Listening';
|
||||
lsListener.Font.Color := clGreen;
|
||||
end else begin
|
||||
lsListener.Caption := 'Not listening';
|
||||
lsListener.Font.Color := clRed;
|
||||
end;
|
||||
if WrapperPath = '' then begin
|
||||
lsWrapVer.Caption := 'N/A';
|
||||
lsWrapVer.Font.Color := clGrayText;
|
||||
end else
|
||||
if not GetFileVersion(ExpandPath(WrapperPath), FV) then begin
|
||||
lsWrapVer.Caption := 'N/A';
|
||||
lsWrapVer.Font.Color := clGrayText;
|
||||
end else begin
|
||||
lsWrapVer.Caption :=
|
||||
IntToStr(FV.Version.w.Major)+'.'+
|
||||
IntToStr(FV.Version.w.Minor)+'.'+
|
||||
IntToStr(FV.Release)+'.'+
|
||||
IntToStr(FV.Build);
|
||||
lsWrapVer.Font.Color := clWindowText;
|
||||
end;
|
||||
if not GetFileVersion('termsrv.dll', FV) then begin
|
||||
lsTSVer.Caption := 'N/A';
|
||||
lsTSVer.Font.Color := clGrayText;
|
||||
end else begin
|
||||
lsTSVer.Caption :=
|
||||
IntToStr(FV.Version.w.Major)+'.'+
|
||||
IntToStr(FV.Version.w.Minor)+'.'+
|
||||
IntToStr(FV.Release)+'.'+
|
||||
IntToStr(FV.Build);
|
||||
lsTSVer.Font.Color := clWindowText;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMainForm.bLicenseClick(Sender: TObject);
|
||||
begin
|
||||
LicenseForm.mText.Text := ExtractResText('LICENSE');
|
||||
@ -212,11 +552,28 @@ begin
|
||||
end;
|
||||
|
||||
procedure TMainForm.FormCreate(Sender: TObject);
|
||||
var
|
||||
SI: TSystemInfo;
|
||||
begin
|
||||
GetNativeSystemInfo(SI);
|
||||
case SI.wProcessorArchitecture of
|
||||
0: Arch := 32;
|
||||
6: Arch := 64; // Itanium-based x64
|
||||
9: Arch := 64; // Intel/AMD x64
|
||||
else Arch := 0;
|
||||
end;
|
||||
if Arch = 64 then
|
||||
DisableWowRedirection;
|
||||
ReadSettings;
|
||||
Ready := True;
|
||||
end;
|
||||
|
||||
procedure TMainForm.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
if Arch = 64 then
|
||||
RevertWowRedirection;
|
||||
end;
|
||||
|
||||
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||||
begin
|
||||
if bApply.Enabled then
|
||||
|
||||
Reference in New Issue
Block a user