| '----------------------------------------------------------------------
'Start of Class Module: clsWebServer
Option Explicit
Private m_nPortNumber As Long
Private m_sAuthUser As String
Private m_sAuthPass As String
Private m_sAuthRealm As String
Private m_bAuth As Boolean
Private m_frm As Form
Public Event GetPage(sPath As String, wsr As clsWebServerResponse)
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Const BASE64_CHARS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklm" & _
"nopqrstuvwxyz0123456789+/"
Private WithEvents wsk As Winsock
Private m_wpMain As clsWebServerParent
Private WithEvents m_wpMainWatcher As clsWebServerParent
Private m_cWinsocks As Collection
Private m_nID As Long
Private WithEvents m_Timer As Timer
Public Property Set ParentForm(frmNew As Form)
Set m_frm = frmNew
End Property
Public Property Let PortNumber(nPort As Long)
m_nPortNumber = nPort
End Property
Public Property Let AuthMode(bAuth As Boolean)
m_bAuth = bAuth
End Property
Public Property Get AuthMode() As Boolean
AuthMode = m_bAuth
End Property
Public Property Let AuthRealm(sAuthRealm As String)
m_sAuthRealm = sAuthRealm
End Property
Public Property Get AuthRealm() As String
AuthRealm = m_sAuthRealm
End Property
Public Property Let AuthUser(sAuthUser As String)
m_sAuthUser = sAuthUser
End Property
Public Property Let AuthPass(sAuthPass As String)
m_sAuthPass = sAuthPass
End Property
Public Property Get AuthString() As String
AuthString = "Basic " & EncodeBase64(m_sAuthUser & ":" & m_sAuthPass)
End Property
Public Sub Start()
Debug.Assert Not m_frm Is Nothing
Debug.Assert m_nPortNumber > 0
Dim sName As String
Set m_wpMain = New clsWebServerParent
Set m_wpMainWatcher = m_wpMain
Set m_cWinsocks = New Collection
sName = "wsk_" & Format(GetTickCount) & "_0"
Set m_Timer = m_frm.Controls.Add("VB.Timer", sName & "_timer", m_frm)
m_Timer.Enabled = True
m_Timer.Interval = 60000
Set wsk = m_frm.Controls.Add("MSWinsock.Winsock.1", sName, m_frm)
wsk.LocalPort = m_nPortNumber
wsk.Listen
End Sub
Private Sub Class_Initialize()
m_nPortNumber = 80
m_bAuth = False
m_sAuthRealm = "Protected content"
End Sub
Private Sub m_Timer_Timer()
Dim obj As clsWebServerClient
Dim nMinTick As Long
Dim i As Long
nMinTick = GetTickCount - 60000
For i = m_cWinsocks.Count To 1 Step -1
Set obj = m_cWinsocks.Item(i)
If obj.LastTick < nMinTick Then
obj.wsk.Close
m_wpMainWatcher_Closed obj
End If
Next
End Sub
Private Sub m_wpMainWatcher_Closed(wsk As clsWebServerClient)
Dim obj As clsWebServerClient
Dim i As Long
For i = m_cWinsocks.Count To 1 Step -1
Set obj = m_cWinsocks.Item(i)
If obj Is wsk Then
m_cWinsocks.Remove i
Exit For
End If
Next
End Sub
Private Sub m_wpMainWatcher_GetID(nID As Long)
m_nID = m_nID + 1
nID = m_nID
End Sub
Private Sub m_wpMainWatcher_GetPage(sPath As String, wsr As _
clsWebServerResponse)
RaiseEvent GetPage(sPath, wsr)
End Sub
Private Sub wsk_ConnectionRequest(ByVal requestID As Long)
Dim obj As clsWebServerClient
Set obj = New clsWebServerClient
obj.Start m_frm, m_wpMain, Me
obj.wsk.Accept requestID
m_cWinsocks.Add obj
End Sub
Function EncodeBase64(sToEncode As String)
Dim i As Long
Dim cOut As String
For i = 1 To Len(sToEncode) Step 3
Dim nGroup As Long
Dim sGroup As String
nGroup = &H10000 * Asc(Mid(sToEncode, i, 1)) + _
&H100 * Asc(Mid(sToEncode, i + 1, 1) & Chr(0)) + _
Asc(Mid(sToEncode, i + 2, 1) & Chr(0))
sGroup = Oct(nGroup)
sGroup = String(8 - Len(sGroup), "0") & sGroup
EncodeBase64 = EncodeBase64 & _
Mid(BASE64_CHARS, CLng("&o" & Mid(sGroup, 1, 2)) + 1, 1) + _
Mid(BASE64_CHARS, CLng("&o" & Mid(sGroup, 3, 2)) + 1, 1) + _
Mid(BASE64_CHARS, CLng("&o" & Mid(sGroup, 5, 2)) + 1, 1) + _
Mid(BASE64_CHARS, CLng("&o" & Mid(sGroup, 7, 2)) + 1, 1)
Next
Select Case Len(sToEncode) Mod 3
Case 1: '8 bit final
EncodeBase64 = Left(EncodeBase64, Len(EncodeBase64) - 2) + "=="
Case 2: '16 bit final
EncodeBase64 = Left(EncodeBase64, Len(EncodeBase64) - 1) + "="
End Select
End Function
'End of Class Module: clsWebServer
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'Start of Class Module: clsWebServerClient
Option Explicit
Public WithEvents wsk As Winsock
Public LastTick As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private m_sData As String
Private m_wpMain As clsWebServerParent
Private m_wpSettings As clsWebserver
Private m_frm As Form
Private m_sGetPath As String
Private m_sGetAuth As String
Private m_sOut As String
Public Sub Start(frm As Form, wp As clsWebServerParent, wpm As _
clsWebserver)
LastTick = GetTickCount
Dim nID As Long
Dim sName As String
Set m_wpMain = wp
Set m_wpSettings = wpm
m_wpMain.TriggerGetID nID
sName = "wsk_" & Format(GetTickCount) & "_" & Format(nID)
Set wsk = frm.Controls.Add("MSWinsock.Winsock.1", sName, frm)
End Sub
Private Sub wsk_Close()
m_wpMain.TriggerClosed Me
End Sub
Private Sub wsk_DataArrival(ByVal bytesTotal As Long)
Dim sData As String
wsk.GetData sData, vbString
m_sData = m_sData & Replace(sData, vbCr, "")
Do While InStr(1, m_sData, vbLf)
ParseLine Mid(m_sData, 1, InStr(1, m_sData, vbLf) - 1)
m_sData = Mid(m_sData, InStr(1, m_sData, vbLf) + 1)
Loop
End Sub
Private Sub ParseLine(sLine As String)
If Mid(sLine, 1, 4) = "GET " Then
Dim vSplit As Variant
vSplit = Split(sLine, " ")
m_sGetPath = vSplit(1)
ElseIf Mid(sLine, 1, 15) = "Authorization: " Then
m_sGetAuth = Mid(sLine, 16)
ElseIf sLine = "" Then
Dim sOut As String
Dim bShowPage As Boolean
bShowPage = False
If m_wpSettings.AuthMode Then
If m_sGetAuth = m_wpSettings.AuthString Then
bShowPage = True
Else
sOut = "HTTP/1.1 401 Authorization Required" & vbNewLine
sOut = sOut & "WWW-Authenticate: Basic realm=""" & _
m_wpSettings.AuthRealm & """" & _
vbNewLine
sOut = sOut & "Content-Type: text/html" & vbNewLine
sOut = sOut & "" & vbNewLine
sOut = sOut & _
"<html><head><title>Sorry</title></head><body>" & _
vbNewLine
sOut = sOut & "You entered the wrong " _
& "password</body></html>" & _
vbNewLine
End If
Else
bShowPage = True
End If
If bShowPage Then
Dim wsr As clsWebServerResponse
Set wsr = New clsWebServerResponse
m_wpMain.TriggerGetPage m_sGetPath, wsr
sOut = "HTTP/1.1 200 OK" & vbNewLine
sOut = sOut & "Content-type: " & wsr.ContentType & vbNewLine _
& vbNewLine
sOut = sOut & wsr.Page
End If
m_sGetPath = ""
m_sGetAuth = ""
m_sOut = sOut
SendData
End If
End Sub
Private Sub SendData()
If m_sOut = "" Then
wsk.Close
m_wpMain.TriggerClosed Me
Exit Sub
End If
If Len(m_sOut) > 4096 Then
wsk.SendData Mid(m_sOut, 1, 4096)
m_sOut = Mid(m_sOut, 4097)
Else
wsk.SendData m_sOut
m_sOut = ""
End If
End Sub
Private Sub wsk_SendComplete()
SendData
End Sub
'End of Class Module: clsWebServerClient
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'Start of Class Module: clsWebServerParent
Option Explicit
Public Event Closed(wsk As clsWebServerClient)
Public Event GetID(nID As Long)
Public Event GetPage(sPath As String, wsr As clsWebServerResponse)
Public Sub TriggerGetPage(sPath As String, wsr As clsWebServerResponse)
RaiseEvent GetPage(sPath, wsr)
End Sub
Public Sub TriggerClosed(wsk As clsWebServerClient)
RaiseEvent Closed(wsk)
End Sub
Public Sub TriggerGetID(nID As Long)
RaiseEvent GetID(nID)
End Sub
'End of Class Module: clsWebServerParent
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'Start of Class Module: clsWebServerResponse
Option Explicit
Private m_sPage As String
Private m_sContentType As String
Public Property Get Page() As String
Page = m_sPage
End Property
Public Property Let Page(sNewPage As String)
m_sPage = sNewPage
End Property
Public Property Get ContentType() As String
ContentType = m_sContentType
End Property
Public Property Let ContentType(sNewContentType As String)
m_sContentType = sNewContentType
End Property
Public Sub LoadPageFromFile(sFile As String)
Dim nFile As Long
nFile = FreeFile
Open sFile For Binary As #nFile
m_sPage = Input(LOF(nFile), #nFile)
Close #nFile
End Sub
Private Sub Class_Initialize()
m_sContentType = "text/html"
End Sub
'End of Class Module: clsWebServerResponse
'----------------------------------------------------------------------
|