Code improvements

Fixed memory leak in the installer
Added diagnostics info to configuration app
This commit is contained in:
binarymaster 2014-11-22 21:17:39 +03:00
parent edbff7bedd
commit 61f6adf1f2
3 changed files with 468 additions and 25 deletions

View File

@ -676,6 +676,7 @@ begin
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;

View File

@ -3,8 +3,8 @@ object MainForm: TMainForm
Top = 0
BorderStyle = bsDialog
Caption = 'RDP Wrapper Configuration'
ClientHeight = 245
ClientWidth = 326
ClientHeight = 326
ClientWidth = 351
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
@ -15,18 +15,19 @@ object MainForm: TMainForm
Position = poDesktopCenter
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lRDPPort: TLabel
Left = 203
Top = 33
Left = 225
Top = 103
Width = 47
Height = 13
Caption = 'RDP Port:'
end
object bOK: TButton
Left = 45
Top = 212
Left = 10
Top = 293
Width = 75
Height = 25
Caption = 'OK'
@ -35,8 +36,8 @@ object MainForm: TMainForm
OnClick = bOKClick
end
object bCancel: TButton
Left = 126
Top = 212
Left = 91
Top = 293
Width = 75
Height = 25
Caption = 'Cancel'
@ -45,8 +46,8 @@ object MainForm: TMainForm
OnClick = bCancelClick
end
object bApply: TButton
Left = 207
Top = 212
Left = 172
Top = 293
Width = 75
Height = 25
Caption = 'Apply'
@ -56,7 +57,7 @@ object MainForm: TMainForm
end
object cbSingleSessionPerUser: TCheckBox
Left = 8
Top = 31
Top = 112
Width = 130
Height = 17
Caption = 'Single Session Per User'
@ -65,8 +66,8 @@ object MainForm: TMainForm
end
object rgNLA: TRadioGroup
Left = 8
Top = 54
Width = 310
Top = 135
Width = 335
Height = 73
Caption = 'Security Mode'
Items.Strings = (
@ -78,7 +79,7 @@ object MainForm: TMainForm
end
object cbAllowTSConnections: TCheckBox
Left = 8
Top = 8
Top = 89
Width = 174
Height = 17
Caption = 'Enable Remote Desktop Protocol'
@ -87,20 +88,20 @@ object MainForm: TMainForm
end
object rgShadow: TRadioGroup
Left = 8
Top = 133
Width = 310
Top = 214
Width = 335
Height = 73
Caption = 'Session Shadowing Mode'
Items.Strings = (
'Disable Shadowing'
'Shadowing will request user permission'
'Shadowing sessions immediately')
'Shadowing will request user'#39's permission'
'Shadow sessions immediately')
TabOrder = 6
OnClick = cbAllowTSConnectionsClick
end
object seRDPPort: TSpinEdit
Left = 256
Top = 30
Left = 278
Top = 100
Width = 62
Height = 22
MaxValue = 65535
@ -110,12 +111,96 @@ object MainForm: TMainForm
OnChange = seRDPPortChange
end
object bLicense: TButton
Left = 224
Top = 6
Width = 94
Height = 21
Left = 253
Top = 293
Width = 87
Height = 25
Caption = 'View license...'
TabOrder = 8
OnClick = bLicenseClick
end
object gbDiag: TGroupBox
Left = 8
Top = 6
Width = 335
Height = 77
Caption = 'Diagnostics'
TabOrder = 9
object lListener: TLabel
Left = 11
Top = 55
Width = 70
Height = 13
Caption = 'Listener state:'
end
object lService: TLabel
Left = 11
Top = 36
Width = 67
Height = 13
Caption = 'Service state:'
end
object lsListener: TLabel
Left = 91
Top = 55
Width = 44
Height = 13
Caption = 'Unknown'
end
object lsService: TLabel
Left = 91
Top = 36
Width = 44
Height = 13
Caption = 'Unknown'
end
object lsTSVer: TLabel
Left = 206
Top = 36
Width = 44
Height = 13
Caption = 'Unknown'
end
object lsWrapper: TLabel
Left = 91
Top = 17
Width = 44
Height = 13
Caption = 'Unknown'
end
object lsWrapVer: TLabel
Left = 206
Top = 17
Width = 44
Height = 13
Caption = 'Unknown'
end
object lTSVer: TLabel
Left = 182
Top = 36
Width = 20
Height = 13
Caption = 'ver.'
end
object lWrapper: TLabel
Left = 11
Top = 17
Width = 74
Height = 13
Caption = 'Wrapper state:'
end
object lWrapVer: TLabel
Left = 182
Top = 17
Width = 20
Height = 13
Caption = 'ver.'
end
end
object Timer: TTimer
Interval = 250
OnTimer = TimerTimer
Left = 280
Top = 19
end
end

View File

@ -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