From 61f6adf1f2cc1c5be8cb4ae7421e52dd92ed506d Mon Sep 17 00:00:00 2001 From: binarymaster Date: Sat, 22 Nov 2014 21:17:39 +0300 Subject: [PATCH] Code improvements Fixed memory leak in the installer Added diagnostics info to configuration app --- src-installer/RDPWInst.dpr | 1 + src-rdpconfig/MainUnit.dfm | 133 +++++++++++--- src-rdpconfig/MainUnit.pas | 359 ++++++++++++++++++++++++++++++++++++- 3 files changed, 468 insertions(+), 25 deletions(-) diff --git a/src-installer/RDPWInst.dpr b/src-installer/RDPWInst.dpr index 3d4527c..34f402b 100644 --- a/src-installer/RDPWInst.dpr +++ b/src-installer/RDPWInst.dpr @@ -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; diff --git a/src-rdpconfig/MainUnit.dfm b/src-rdpconfig/MainUnit.dfm index 7e06d8a..f342a77 100644 --- a/src-rdpconfig/MainUnit.dfm +++ b/src-rdpconfig/MainUnit.dfm @@ -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 diff --git a/src-rdpconfig/MainUnit.pas b/src-rdpconfig/MainUnit.pas index a236689..306a7b7 100644 --- a/src-rdpconfig/MainUnit.pas +++ b/src-rdpconfig/MainUnit.pas @@ -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