Тема: HTA/VBS: Настройка безопасности DCOM и WMI
Столкнулся с задачей, решение которой, на мой взгляд, заслуживает внимания.
Задача: Подключиться к WMI удаленного компьютера под управлением Windows Vista или 7 c включенным UAC в рабочей группе.
Решение: Настроить разрешения на запуск и активацию DCOM, а также права на необходимые пространства имен WMI.
HTA по мотивам задачи:
<html>
<head>
<title>Настройка</title>
<!-- Настройка DCOM и WMI -->
<meta http-equiv=content-type content="text-html; charset=windows-1251">
<meta http-equiv=MSThemeCompatible content=yes>
<hta:application
icon=comres.dll
scroll=no
version = "1.0"
>
</head>
<style type="text/css">
#usr{width:210px;}
#ok,#cancel{width:103px;}
#cancel{margin-left:4px}
#ns{height:240px; overflow:auto;}
#st{top: expression(ns.scrollTop)"
</style>
<script language="VBScript">
Sub window_onload()
window.resizeTo 250, 430
window.moveTo 20, 20
For Each objNameSpace In GetObject("winmgmts:\\.\root").InstancesOf("__NAMESPACE")
s = s & "<div><input id=""" & objNameSpace.Name & """ type=""checkbox""/>" & objNameSpace.Name & "</div>"
Next
document.getElementById("ns").InnerHTML = s
document.getElementById("usr").focus()
End Sub
Sub cancel_onclick()
window.close
End Sub
Sub ok_onclick()
s = document.getElementById("usr").Value
If s = "" Then
MsgBox "Имя пользователя не может быть пустым",vbInformation
Exit Sub
End If
DACLModify s
End Sub
Function DACLModify(sUserName)
On Error Resume Next
Dim bPartOfDomain, sDomainName 'имя домена (если не в домене - имя локального компьютера)
Dim objWinCS, obj
Dim objWMI
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
If IsPreVista(objWMI) Then
MsgBox "Текущая версия операционной системы не поддерживается",vbExclamation
Exit Function
End If
Set objWinCS = objWMI.ExecQuery("SELECT * FROM Win32_ComputerSystem")
For Each obj In objWinCS
bPartOfDomain = obj.PartOfDomain
If bPartOfDomain Then
sDomainName = obj.Domain
Else
sDomainName = obj.Name
End If
Next
Set objWinCS = Nothing
Dim objCollection
'поиск учетной записи
If bPartOfDomain Then
Set objCollection = objWMI.ExecQuery("SELECT SID FROM Win32_Account WHERE Domain='" & sDomainName & "' AND Name='" & sUserName & "'")
Else
Set objCollection = objWMI.ExecQuery("SELECT SID FROM Win32_Account WHERE Name='" & sUserName & "'")
End If
If objCollection.Count = 0 Then
MsgBox "Учетная запись " & sUserName & " не найдена",vbInformation
Exit Function
End If
Dim strSID
'получаем SID
For Each obj In objCollection
strSID = UCase(obj.SID)
Next
Set objCollection = Nothing
'безопасность DCOM
If document.getElementById("dcom").checked Then
If DCOM_DACL_Modify(sUserName, sDomainName, strSID) <> 0 Then Exit Function
End If
'безопасность пространств имен wmi
For Each n In document.getElementById("ns").childNodes
If n.childNodes(0).checked Then
If WMI_DACL_Modify(sUserName, sDomainName, strSID, n.innerText) <> 0 Then Exit Function
End If
Next
If Err.Number = 0 Then
MsgBox "Настройка безопасности DCOM и WMI завершена",vbInformation
Else
MsgBox "Не удалось настроить безопасность DCOM и WMI",vbCritical
End If
End Function
Function DCOM_DACL_Modify(sUserName, sDomainName, strSID)
On Error Resume Next
Const HKLM = &H80000002
Const KeyPath = "SOFTWARE\Microsoft\Ole"
Const KeyValue = "MachineLaunchRestriction"
Const KeyEnableValue = "EnableDCOM" 'влючено ли использование DCOM
Dim objReg
DCOM_DACL_Modify = 1 'по умолчанию - ошибка
Set objReg = GetObject("winmgmts:\\.\root\default:StdRegProv")
'читаем ключ - разрешен ли DCOM
Dim sEnableValue
If objReg.GetStringValue(HKLM, KeyPath, KeyEnableValue, sEnableValue) <> 0 Then
MsgBox "Не удалось прочитать ключ " & "HKLM\" & KeyPath & "\" & KeyEnableValue,vbCritical
Exit Function
End If
If UCase(sEnableValue) <> "Y" Then
If objReg.SetStringValue(HKLM, KeyPath, KeyEnableValue, "Y") <> 0 Then
MsgBox "Не удалось записать ключ " & "HKLM\" & KeyPath & "\" & KeyEnableValue,vbCritical
Exit Function
End If
End If
'---Права
'читаем ключ
Dim arrSD
If objReg.GetBinaryValue(HKLM, KeyPath, KeyValue, arrSD) <> 0 Then
MsgBox "Не удалось прочитать ключ " & KeyPath & "\" & KeyValue,vbCritical
Exit Function
End If
If Not IsArray(arrSD) Then
MsgBox "Ключ " & "HKLM\" & KeyPath & "\" & KeyValue & " не является массивом",vbCritical
Exit Function
End If
'конвертируем в Win32_SecurityDescriptor - только Vista и 7
Dim objWMI, SDHelper
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
Set SDHelper = objWMI.Get("Win32_SecurityDescriptorHelper")
Dim objSD
If SDHelper.BinarySDToWin32SD(arrSD, objSD) <> 0 Then 'BinarySDToSDDL
MsgBox "Не удалось конвертировать массив в дескриптор безопасности DCOM",vbCritical
Exit Function
End If
Dim arrACE, objACE
Dim bFound 'флаг - SID найден
arrACE = objSD.DACL
'настройка существующих записей
For Each objACE In arrACE 'ищем наш SID
If StrComp(objACE.Trustee.SIDString, strSID, vbTextCompare) = 0 Then 'SID найден
bFound = True
'разрешение на полный доступ
objACE.AceType = 0
objACE.AccessMask = &H1F
Exit For
End If
Next
'если SID не найден
If Not bFound Then
Dim objSID, objTrustee, objNewACE
'формируем новый экземпляра класса Win32_Ace
Set objSID = objWMI.Get("Win32_SID.SID='" & strSID & "'")
Set objTrustee = objWMI.Get("Win32_Trustee").SpawnInstance_()
objTrustee.Domain = sDomainName 'домен или имя локального компа
objTrustee.Name = sUserName
objTrustee.SID = objSID.BinaryRepresentation
objTrustee.SidLength = objSID.SidLength
objTrustee.SIDString = strSID
Set objSID = Nothing
Set objNewACE = objWMI.Get("Win32_Ace").SpawnInstance_()
objNewACE.AceType = 0 'разрешить
objNewACE.AceFlags = 0
objNewACE.AccessMask = &H1F 'полный доступ
objNewACE.Trustee = objTrustee
Set objTrustee = Nothing
'расширяем DACL
ReDim Preserve arrACE(UBound(arrACE) + 1)
Set arrACE(UBound(arrACE)) = objNewACE
Set objNewACE = Nothing
objSD.DACL = arrACE
Erase arrACE
End If
Set objWMI = Nothing
'сохраняем изменения - конвертируем обратно - только Vista и 7
Dim arrSD2
If SDHelper.Win32SDToBinarySD(objSD, arrSD2) <> 0 Then
MsgBox "Не удалось конвертировать дескриптор безопасности DCOM в массив",vbCritical
Exit Function
End If
Set SDHelper = Nothing
If Not IsArray(arrSD2) Then
MsgBox "Конвертирванный дескриптор безопасности DCOM не является массивом",vbCritical
Exit Function
End If
If objReg.SetBinaryValue(HKLM, KeyPath, KeyValue, arrSD2) <> 0 Then
MsgBox "Не удалось записать ключ " & "HKLM\" & KeyPath & "\" & KeyValue,vbCritical
Exit Function
End If
Set objReg = Nothing
DCOM_DACL_Modify = Err.Number
End Function
Function WMI_DACL_Modify(sUserName, sDomainName, strSID, strNameSpace)
On Error Resume Next
Dim objSecurity, objNameSpace
WMI_DACL_Modify = 1 'по умолчанию - ошибка
Set objNameSpace = GetObject("winmgmts:\\.\root\" & strNameSpace)
Set objSecurity = objNameSpace.Get("__SystemSecurity=@")
Dim objSD
'получаем дескриптор безопасности пространства имен - только Vista и 7
If objSecurity.GetSecurityDescriptor(objSD) <> 0 Then 'если не удалось получить дескриптор безопасности
MsgBox "Не удалось получить дескриптор безопасности пространства имен " & strNameSpace,vbCritical
Exit Function
End If
Dim arrACE, objACE
arrACE = objSD.DACL
Dim bFound 'флаг - SID найден
'настройка существующих записей
For Each objACE In arrACE 'ищем наш SID
If StrComp(objACE.Trustee.SIDString, strSID, vbTextCompare) = 0 Then 'SID найден
bFound = True
'разрешение на полный доступ
objACE.AceType = 0
objACE.AccessMask = &H6003F
Exit For
End If
Next
'если SID не найден
If Not bFound Then
Dim objSID, objTrustee, objNewACE, objWMI
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
'формируем новый экземпляра класса Win32_Ace
Set objSID = objWMI.Get("Win32_SID.SID='" & strSID & "'")
Set objTrustee = objWMI.Get("Win32_Trustee").SpawnInstance_()
objTrustee.Domain = sDomainName 'домен или имя локального компа
objTrustee.Name = sUserName
objTrustee.SID = objSID.BinaryRepresentation
objTrustee.SidLength = objSID.SidLength
objTrustee.SIDString = strSID
Set objSID = Nothing
Set objNewACE = objWMI.Get("Win32_Ace").SpawnInstance_()
Set objWMI = Nothing
objNewACE.AceType = 0 'разрешить
objNewACE.AceFlags = 0
objNewACE.AccessMask = &H6003F 'полный доступ
objNewACE.Trustee = objTrustee
Set objTrustee = Nothing
'расширяем DACL
ReDim Preserve arrACE(UBound(arrACE) + 1)
Set arrACE(UBound(arrACE)) = objNewACE
Set objNewACE = Nothing
objSD.DACL = arrACE
Erase arrACE
End If
'сохраняем изменения настроек безопасности пространства имен - только Vista и 7
If objSecurity.SetSecurityDescriptor(objSD) <> 0 Then
MsgBox "Не удалось сохранить изменения в настройке безопасности пространства имен " & strNameSpace,vbCritical
Exit Function
End If
Set objSecurity = Nothing
Set objNameSpace = Nothing
WMI_DACL_Modify = Err.Number
End Function
Function IsPreVista(objWMI)
On Error Resume Next
Dim obj
For Each obj In objWMI.ExecQuery("Select * From Win32_OperatingSystem")
If CInt(Left(obj.Version, 1)) = 5 Then 'XP или ранее
IsPreVista = True
End If
Next
End Function
</script>
<body>
Имя пользователя: <br/><input id="usr" type="text"/><br/>
<input id="dcom" type="checkbox"/>DCOM<br/>
<div id="st">Пространства имен WMI:</div>
<div id="ns"></div><br/>
<input id="ok" type="button" value="OK"/><input id="cancel" type="button" value="Отмена"/>
</body>
</html>Запуск, разумеется, от имени администратора:
With CreateObject("Scripting.FileSystemObject")
f = .BuildPath(.GetParentFolderName(WScript.ScriptFullName),"DCOM'n'WMI_Access_Rights_Adjustment.hta")
If .FileExists(f) Then
CreateObject("Shell.Application").ShellExecute "mshta.exe", Chr(34) & f & Chr(34),, "runas",1
Else
MsgBox "Файл " & f & " не найден",vbExclamation
End If
End WithНаверное на форуме кому-нибудь будет полезно.
p.s.: Настройка Брандмауэра Windows согласно MSDN ни для XP, ни для Vista/7 по моим наблюдениям не помогает - ни netsh, ни скриптом, ни руками - только отключение. Хотелось бы знать, только у меня лыжи не едут?
