HTA: Мультисокетный WEB сервер в HTA

Set Winsock = CreateObject("MSWinsock.Winsock")

Невозможно создание объекта контейнером ActiveX...

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">

<assemblyIdentity
    type="win32"
    name="MSWINSCK.ocx"
    version="1.0.0.0" />

<file name="MSWINSCK.ocx">

    <comClass
        description="Microsoft WinSock Control, version 6.0 (SP6)"
        clsid="{248DD896-BB45-11CF-9ABC-0080C7E7B78D}"
        threadingModel="Apartment"
        progid="MSWinsock.Winsock"
        tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}" />

    <comClass
        description="Microsoft WinSock Control, version 6.0 (SP6)"
        clsid="{39977C62-C383-463D-AF61-C71220634656}"
        threadingModel="Apartment"
        progid="MSWinsock.Winsock"
        tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}" />

    <comClass
        description="Microsoft WinSock Control, version 6.0 (SP6)"
        clsid="{6E5311A1-325D-4FFD-9AF4-B373F02AE458}"
        threadingModel="Apartment"
        progid="MSWinsock.Winsock"
        tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}" />

    <comClass
        description="Winsock General Property Page Object"
        clsid="{248DD897-BB45-11CF-9ABC-0080C7E7B78D}" />

    <typelib tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}"
        version="1.0"
        helpdir="C:\WINDOWS\HELP" />

</file>

<comInterfaceExternalProxyStub
    name="IMSWinsockControl"
    iid="{248DD892-BB45-11CF-9ABC-0080C7E7B78D}"
    proxyStubClsid32="{00020424-0000-0000-C000-000000000046}"
    baseInterface="{00000000-0000-0000-C000-000000000046}"
    tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}" />

<comInterfaceExternalProxyStub
    name="DMSWinsockControlEvents"
    iid="{248DD893-BB45-11CF-9ABC-0080C7E7B78D}"
    proxyStubClsid32="{00020420-0000-0000-C000-000000000046}"
    baseInterface="{00000000-0000-0000-C000-000000000046}"
    tlbid="{248DD890-BB45-11CF-9ABC-0080C7E7B78D}" />

</assembly>

Option Explicit

'Константы объекта MSWinsock.Winsock.1
Const sckClosed = 0 	'				Default. Closed 
Const sckOpen = 1 						'Open 
Const sckListening = 2 					'Listening 
Const sckConnectionPending = 3			'Connection pending 
Const sckResolvingHost = 4 				'Resolving host 
Const sckHostResolved = 5 				'Host resolved 
Const sckConnecting = 6 				'Connecting 
Const sckConnected = 7 					'Connected 
Const sckClosing = 8 					'Peer is closing the connection 
Const sckError = 9 						'Error 

'Константы объекта SAPI.spFileStream
Const SSFMOpenForRead = 0 				'Opens an existing file as read-only.
Const SSFMOpenReadWrite = 1 			'Opens an existing file as read-write. Not supported for wav files.
Const SSFMCreate = 2 					'Opens an existing file as read-write. Else, it creates the file then opens it as read-write. Not supported for wav files.
Const SSFMCreateForWrite = 3 			'Creates file even if file exists and so destroys or overwrites the existing file.

Const SSSPTRelativeToStart = 0			'Calculates the stream offset relative from the start of the stream.
Const SSSPTRelativeToCurrentPosition = 1'Calculates the stream offset relative from the current position.
Const SSSPTRelativeToEnd = 2			'Calculates the stream offset relative from the end of the stream.

'Настройки сервера
Dim LocalPort: LocalPort = 81
Dim RootFolderPath: RootFolderPath = "wwwroot"
Dim SocketsCount: SocketsCount = 10
Dim DefaultDocuments: DefaultDocuments = Array("index.htm","index.html")
Dim ChunkSize: ChunkSize = 204800 '65536
Dim MaxHeaderSize: MaxHeaderSize = 65536 
'Глобальные переменные
Dim FileSystemObject, ExitDo, ScriptFullName, CurrentFolderPath, ContentTypes, WshShell

ReDim Sockets(SocketsCount)

Dim Streams

Initialize

'Процедура инициализации сервера
Sub Initialize()
	Dim FolderExists, TestPath
	Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
	
	'Получаем путь до текущего каталога
	CurrentFolderPath = FileSystemObject.GetParentFolderName(WScript.ScriptFullName)
	
	'Проверяем существование корневого каталога сервера
	if Not FileSystemObject.FolderExists(RootFolderPath) Then
		'Если не нашли, то пробуем достроить путь до полный пути в текущем каталоге
		TestPath = FileSystemObject.BuildPath(CurrentFolderPath,RootFolderPath)
		if FileSystemObject.FolderExists(TestPath) Then
			RootFolderPath = TestPath
		Else
			Err.Raise vbObjectError + 1,"","Корневой каталог не найден."
		End if		
	End if
		
	Set Streams = CreateObject("Scripting.Dictionary")
	'Инициализируем сокеты
	
	'Создаём слушающий сокет
	Set Sockets(0) = WScript.CreateObject("MSWinsock.Winsock.1","Socket_")

	'Включаем слушанье порта
	Sockets(0).localPort = 81
	Sockets(0).Listen

	'Создаём отвечающие сокеты
	Dim i
	For i=1 to SocketsCount
		Set Sockets(i) = WScript.CreateObject("MSWinsock.Winsock.1","Socket_")
	Next

	'Создаём коллекцию типов содержимого
	Set ContentTypes = CreateObject("Scripting.Dictionary")
	
	'Создаём объект для чтения реестра
	Set WshShell = CreateObject("WScript.Shell")

	'RegisterGlobalObject me

	'Начинаем цикл ядра сервера
	Do
		'Делаем паузу, чтобы не нагружать процессор компьютера.
		WScript.Sleep 100
	Loop Until ExitDo 'Err.Number <> 0
End Sub

'Событие получения запроса
Sub Socket_ConnectionRequest(ByVal requestID)
	'On Error Resume Next
	Dim i
	For i = 1 to SocketsCount
		if Sockets(i).State = sckClosed Then 
			Sockets(i).Accept(requestID)
			Exit Sub
		End if
	Next
	if err.Number <> 0 Then AppendToLog "MainSocket_ConnectionRequest " & Err.Description
End Sub

'Событие прихода данных
Sub Socket_DataArrival(ByVal bytesTotal)
	'On Error Resume Next
	Dim RequestData, Headers, HeaderParts, method, url, protocol, FilePath, TestPath, DefaultDocument, File, ExtensionName, NewFileStream, StartPos, EndPos, i, Range, ValueParts, ResponseData, buffer
	'Получаем данные запроса
	me.GetData RequestData, vbString, MaxHeaderSize

	AppendToLog "<-" & vbCrlf & RequestData

	'Разбираем заголовок
	Headers = Split(RequestData,vbCrlf)
	'Проверяем верность формата заголовка
	if Ubound(Headers) < 0 Then 
		me.SendData "HTTP/1.0 400 Bad Request" & vbCrlf & vbCrlf & "400 Bad Request"
		Exit Sub
	End if
	'Получаем первый заголовок
	HeaderParts = Split(Headers(0)," ")
	if Ubound(HeaderParts) < 2 Then 
		me.SendData "HTTP/1.0 400 Bad Request" & vbCrlf & vbCrlf & "400 Bad Request"
		Exit Sub
	End if
	'Получаем метод передачи данных
	method = UCase(HeaderParts(0))
	
	Select Case method
	Case "GET"
	Case "HEAD"
	Case Else
		me.SendData "HTTP/1.0 400 Bad Request" & vbCrlf & vbCrlf & "400 Bad Request"
		Exit Sub
	End Select
	
	'Выделяем url
	url = HeaderParts(1)
	'Получаем протокол
	protocol = HeaderParts(2)
	
	'Проверяем - указано ли имя файла
	if FileSystemObject.GetFileName(url) <> "" Then
		'Достраиваем путь до физического файла на диске
		TestPath = FileSystemObject.BuildPath(RootFolderPath,url)
		'Проверяем существование файла
		if FileSystemObject.FileExists(TestPath) Then FilePath = TestPath
	Else
		For Each DefaultDocument in DefaultDocuments
			TestPath = FileSystemObject.BuildPath(RootFolderPath,DefaultDocument)
			if FileSystemObject.FileExists(TestPath) Then
				FilePath = TestPath
				Exit For
			End if
		Next
	End if
	
	'Если файл не найден
	if FilePath = "" Then
		me.sendData protocol & " 404 Not Found" & vbCrlf & vbCrlf & "404 Not Found"
		Exit Sub
	End if

	Set File = FileSystemObject.getfile(FilePath)
	ExtensionName = LCase(FileSystemObject.GetExtensionName(File.Name))

	Set NewFileStream = New clsFileStream
	NewFileStream.OpenFile File.Path
	Set Streams(me.sockethandle) = NewFileStream
	
	StartPos = 0
	EndPos = File.Size
	'Перебираем заголовки начиная со второго
	For i = 1 to Ubound(Headers)
		'Делим заголовок на части
		HeaderParts = Split(Headers(i),":",2)
		'Обрабатываем заголовки
		if Ubound(HeaderParts) = 1 Then
			Select Case LCase(HeaderParts(0))
			Case "range"
				'Ликвидируем пробелы, обрезаем часть bytes= и делим заголовок по "-"
				Range = HeaderParts(1)
				Range = Replace(Range," ","")
				Range = Replace(Range,"bytes=","")
				ValueParts = Split(Range,"-",2)
				if Ubound(ValueParts) = 1 then
					if isNumeric(ValueParts(0)) Then 
						StartPos = CDbl(ValueParts(0))
						if isNumeric(ValueParts(1)) Then EndPos = CDbl(ValueParts(1))
					End if
				End if
			End Select
		End if
	Next

	'Если требуется выполнить докачку
	if Range <> "" Then
		NewFileStream.Position = EndPos
		NewFileStream.SetEOS
		NewFileStream.Position = StartPos
		ResponseData = protocol & " 206 Partial Content" & vbCrlf & _
					   "Content-Type: " & GetContentType(ExtensionName) & vbCrlf & _
					   "Content-Range: bytes " & StartPos & "-" & EndPos - 1 & "/" &  File.Size & vbCrlf & _
					   "Content-Length: " & EndPos - StartPos & vbCrlf
	Else
		ResponseData = protocol & " 200 OK" & vbCrlf & _
					   "Accept-Ranges: bytes" & vbCrlf & _
					   "Content-Type: " & GetContentType(ExtensionName) & vbCrlf & _
					   "Content-Length: " & EndPos & vbCrlf
	End if

	AppendToLog "->" & vbCrlf & ResponseData
	
	me.SendData ResponseData & vbCrlf
	NewFileStream.Read buffer, ChunkSize
	me.sendData buffer

	if err.Number <> 0 Then AppendToLog "ProcessRequest " & Err.Description
End Sub

'Событие окончания отправки данных
Sub Socket_SendComplete()
	'On Error Resume Next
	Dim FileStream, Buffer, sockethandle, Stream
	sockethandle = me.sockethandle
	if Streams.Exists(sockethandle) Then
		Set Stream = Streams(sockethandle)
		if me.state = sckClosing or me.state = sckError or Stream.AtEndOfStream Then 
			Stream.Close
			me.Close
			Exit Sub
		End if
		Stream.Read buffer, ChunkSize
		if me.state = sckConnected Then me.sendData buffer
	End if
	if err.Number <> 0 Then AppendToLog "Socket_SendComplete " & Err.Description
End Sub

Sub Socket_SendProgress(ByVal bytesSent, ByVal bytesRemaining)
	'On Error Resume Next
	if err.Number <> 0 Then AppendToLog "Socket_SendProgress " & Err.Description
End Sub

Sub Socket_Error(ByVal Number, Description, ByVal Scode, ByVal Source, ByVal HelpFile, ByVal HelpContext, CancelDisplay)
	'On Error Resume Next
	'AppendToLog "Socket error event"
	'me.Close
	if err.Number <> 0 Then AppendToLog "Socket_Error " & Err.Description
End Sub

Sub Socket_Close()
	Dim sockethandle
	sockethandle = me.sockethandle
	AppendToLog "Socket close event"
	if Streams.Exists(sockethandle) Then Streams(sockethandle).Close
End Sub

'Sub Socket_Connect()

'End Sub


Function GetContentType(ext)
	'On Error Resume Next
	GetContentType = ContentTypes(ext)
	if GetContentType = "" Then
		GetContentType = WshShell.RegRead("HKEY_CLASSES_ROOT\." & ext & "\Content Type")
		if GetContentType = "" Then GetContentType = "octet/stream"
		ContentTypes(ext) = GetContentType
	End if
End Function

'Класс для потокового чтения файлов
Class clsFileStream
    Private spFileStream, mvar_size, mvar_Position, mvar_AtEndOfStream, NumberOfBytes

    'Инициализация класса
    Private Sub Class_Initialize()
        Set spFileStream = CreateObject("SAPI.spFileStream")
    End Sub

    'Свойство установки и получения позиции в файле
    Public Property Let Position(byval value)
        mvar_Position = CDbl(spFileStream.Seek(value, SSSPTRelativeToStart))
		If value >= mvar_size Then 
			mvar_AtEndOfStream = True
		Else
			mvar_AtEndOfStream = False
		End if
    End Property

    Public Property Get Position()
        Position = mvar_Position
    End Property

    'Функция открытия файла
    Function OpenFile(FileName)
        On Error Resume Next
        mvar_size = Empty
        mvar_AtEndOfStream = False
        spFileStream.Close
        OpenFile = spFileStream.Open(FileName, SSFMOpenForRead)
        mvar_size = Cdbl(spFileStream.Seek(0, SSSPTRelativeToEnd))
        spFileStream.Seek 0, SSSPTRelativeToStart
    End Function

    'Свойство - размер файла
    Public Property Get Size()
        Size = mvar_size
    End Property
	
	Sub SetEOS
		mvar_size = mvar_Position
	End Sub
	
    'свойство - Флаг окончания данных
    Public Property Get AtEndOfStream()
        'if mvar_Position => mvar_size Then AtEndOfStream = True 
		AtEndOfStream = mvar_AtEndOfStream
    End Property

    Function Read(buffer, ByVal NumberOfBytes)
		On Error Resume Next
    '    mvar_Position = mvar_Position + NumberOfBytes
        'Если позиция чтения превышает размер файла, то смещаем курсор на допустимую позицию
        If mvar_Position + NumberOfBytes > mvar_size Then
            NumberOfBytes = mvar_size - mvar_Position
            mvar_AtEndOfStream = True
        End If
        mvar_Position = mvar_Position + NumberOfBytes
		Read = spFileStream.Read(buffer, NumberOfBytes)
    End Function
	
	Sub Close
		On Error Resume Next
		spFileStream.Close
	End Sub
End Class

Function AppendToLog(Text)
	Dim FSO
	Set FSO = CreateObject("Scripting.FileSystemObject")
	FSO.OpenTextFile(FileSystemObject.BuildPath(CurrentFolderPath,"log.txt"),8,True).WriteLine Now & ":" & Text
End Function