VERSION 5.00
Begin VB.UserControl Gossamer
BorderStyle = 1 'Fixed Single
CanGetFocus = 0 'False
ClientHeight = 450
ClientLeft = 0
ClientTop = 0
ClientWidth = 450
ClipControls = 0 'False
FillStyle = 0 'Solid
HasDC = 0 'False
InvisibleAtRuntime= -1 'True
PaletteMode = 4 'None
ScaleHeight = 450
ScaleWidth = 450
ToolboxBitmap = "Gossamer.ctx":0000
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "G"
BeginProperty Font
Name = "Times New Roman"
Size = 15.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00FF0000&
Height = 400
Left = 30
TabIndex = 0
Top = 0
Width = 370
End
Begin VB.Shape Shape1
BackColor = &H00FFFF80&
BackStyle = 1 'Opaque
BorderStyle = 0 'Transparent
FillStyle = 7 'Diagonal Cross
Height = 400
Left = 0
Top = 0
Width = 400
End
End
Attribute VB_Name = "Gossamer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
'Gossamer
'========
'
'A tiny HTTP server control.
'
'This control uses SimplServer as a listener on Index = 0 for incoming HTTP
'client connections which are handed off to higher index values.
'
'Changes
'-------
'
'Version: 1.1
'
' o Added Port property.
' o Changed StartListening so Port parameter is optional, using
' current value of the Port property setting if not supplied.
' o Added procedure attributes, set LogEvent as default event.
' o Marked several Public members "hidden" since they're only meant
' for use by GossClients.
' o Methods: LogEvent is now RaiseLogEvent, DynamicRequest is now
' RaiseDynamicRequest.
' o New handling of VDir, property can now only be set while not
' listening.
'
'Version: 1.2
'
' o Split out function UTCDateTime from UTCString.
' o Added function UTCParseString to convert HTTP timestamps to
' Date values.
' o VDirPath R/O property is no longer hidden, since it can be useful
' in handling dynamic requests.
'
'Version: 1.3
'
' no change
'
'Version: 1.4
'
' o Added new (hidden) property ServerHeader for use by GossClient.
' o Added EntityEncode method.
'
'Version: 1.5
'
' o Corrected ResolvePath() so it no longer allocates a buffer 1 char too
' long nor needs to then truncate prior to return.
'
'Version 1.6
'
' o Treat sckWouldBlock as a getWSSoftError: log it as such and then
' ignore it.
' o Stop setting .Timestamp since it gets set when GE instances are
' created.
'
'Version: 1.7
'
' o Added GOSS_VERSION_MAJOR and GOSS_VERSION_MINOR Consts for use in the
' default ServerHeader value.
' o Removed sending an extraneous space after header ":" separators. Not
' important, and quite commonly done but a silly waste of bandwidth.
'
Implements SimpleServer
Private mServer() As New SimpleServer
Private IPVersion As String
Private RemotePort As Long
Private RemoteHostIP As String
Private lIndex As Long
Private LastConnect As String
Private mBlnConnClose As Boolean 'Received a "Connection: close" header.
Private mBlnInUse As Boolean 'In-use status of this GossClient.
Private mBytBuffer() As Byte 'Buffer for reading static resource requested.
Private mBytResponse() As Byte 'Response data from dynamic request.
Private mLngResponseLen As Long 'Valid bytes in mBytResponse.
Private mReqState As RequestStates 'Where we are receiving a request.
Private mStrBuffer As String 'Buffered incoming request text.
Private mStrContent As String 'Request Content body.
Private mStrHTTPVersion As String 'Version of request.
Private mStrReqLine As String 'HTTP request line.
Private mColReqHeaders As Collection 'Request headers Collection.
Private mLngContentLen 'Request content length from header.
Private mIntFile As Integer 'Native I/O file number of static resource requested.
'If non-0 a file is open.
Private mIntFullBlocks As Integer 'Remaining count of full blocks to send in static resource.
Private mIntIndex As Integer 'Index in control array of this Client.
Private mLngLastBlockSize As Long 'Size in bytes of final block in static resource.
Private mStrRespBuffer As String 'We want to buffer responses so we can handle
' ReqCloseConn = True properly.
Private mLngRespUsed As Long
Private Const GOSS_VERSION_MAJOR As String = "1"
Private Const GOSS_VERSION_MINOR As String = "7"
Private Const DOUBLE_CRLF As String = vbCrLf & vbCrLf
'Private Const STATIC_BUFFER_SZ As Long = 8192
Private mBufferSize As Long
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Private Declare Function GetFullPathName Lib "kernel32" _
Alias "GetFullPathNameW" ( _
ByVal lpFileName As Long, _
ByVal nBufferLength As Long, _
ByVal lpBuffer As Long, _
ByVal lpFilePart As Long) As Long
Private Declare Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Const TIME_ZONE_ID_DAYLIGHT As Long = 2
Private mMaxConnections As Integer
Private mVDir As String
Private mVDirPath As String
Private mServerHeader As String
Public DefaultPage As String 'Default page for directory requests.
Attribute DefaultPage.VB_VarDescription = "Simple file name of Gossamer's default page to return on directory requests"
Public Port As Long 'Server listen port.
Attribute Port.VB_VarDescription = "HTTP port to listen on"
Public Event DynamicRequest(ByVal Method As String, _
ByVal URI As String, _
ByVal Params As String, _
ByVal ReqHeaders As Collection, _
ByRef RespStatus As Single, _
ByRef RespStatusText As String, _
ByRef RespMIME As String, _
ByRef RespExtraHeaders As String, _
ByRef RespBody() As Byte, _
ByVal ClientIndex As Integer)
Public Event LogEvent(ByVal GossEvent As GossEvent, _
ByVal ClientIndex As Integer) '-1 for Gossamer events.
Attribute LogEvent.VB_Description = "Raised when a loggable event has occurred"
Attribute LogEvent.VB_MemberFlags = "200"
Private Enum RequestStates
rqsIdle = 0
rqsHeadersComplete
rqsReqLineComplete
rqsRequestComplete
End Enum
Private Sub AppendResp(ByVal Text As String)
Dim Length As Long
Length = Len(Text)
If mLngRespUsed + Length > Len(mStrRespBuffer) Then
If Len(mStrRespBuffer) < 1 Then
mStrRespBuffer = Space$(Length + 200)
Else
mStrRespBuffer = mStrRespBuffer & Space$(Length + 100)
End If
End If
Mid$(mStrRespBuffer, mLngRespUsed + 1, Length) = Text
mLngRespUsed = mLngRespUsed + Length
End Sub
Public Property Let BufferSize(ByVal NewValue As Long)
mBufferSize = NewValue
End Property
Public Property Get MaxConnections() As Long
Attribute MaxConnections.VB_Description = "Maximum number of active client connections to accept"
MaxConnections = mMaxConnections
End Property
Public Property Let MaxConnections(ByVal Max As Long)
If 0 < Max Or Max <= 1000 Then
mMaxConnections = Max
Else
Err.Raise &H8004A702, "Gossamer", "MaxConnections must be 1 to 1000"
End If
End Property
Private Sub ProcessRequest()
Dim blnReturnFile As Boolean
Dim dtSince As Date
Dim GE As GossEvent
Dim lngFileBytes As Long
Dim lngInStr As Long
Dim sngStatus As Single
Dim strFile As String
Dim strKeepAlive As String
Dim strMIME As String
Dim strParts() As String
Dim strRespExtraHeaders As String
Dim strStatusText As String
strParts = Split(mStrReqLine, " ", 3)
strParts(0) = UCase$(strParts(0))
Set GE = New GossEvent
With GE
.EventType = getHTTP
.IP = RemoteHostIP
.Port = RemotePort
End With
If UBound(strParts) <> 2 Then
With GE
.EventSubtype = gesHTTPError
.Method = "ERROR"
.Text = "Bad Request Line: " & mStrReqLine
End With
RaiseLogEvent GE, mIntIndex
mReqState = rqsIdle
SimpleServer_CloseSck (mIntIndex)
mStrBuffer = ""
mBlnInUse = False
Else
'Process "Connection: close" headers.
On Error Resume Next
strKeepAlive = mColReqHeaders("CONNECTION")(1)
If Err.Number = 0 Then
On Error GoTo 0
If UCase$(strKeepAlive) = "CLOSE" Then mBlnConnClose = True
End If
strParts(2) = UCase$(strParts(2))
mStrHTTPVersion = strParts(2)
With GE
.Method = strParts(0)
.Text = strParts(1)
.HTTPVersion = strParts(2)
End With
strParts(1) = Replace$(strParts(1), "/", "\")
Select Case strParts(0)
Case "GET", "HEAD"
lngInStr = InStr(strParts(1), "?")
If lngInStr > 0 Then
'Request parameters present, assume dynamic content request.
If strParts(0) = "HEAD" Then
SendCanned 501
Else
'GET dynamic content.
GE.EventSubtype = gesGETDynamic
RaiseDynamicRequest strParts(0), _
Left$(strParts(1), lngInStr - 1), _
Mid$(strParts(1), lngInStr + 1), _
mColReqHeaders, _
sngStatus, _
strStatusText, _
strMIME, _
strRespExtraHeaders, _
mBytResponse, _
mIntIndex
If sngStatus = 0 Then
SendCanned 501
Else
SendResponse sngStatus, _
strStatusText, _
strMIME, _
strRespExtraHeaders
End If
End If
Else
'Request for static resource.
GE.EventSubtype = gesGETStatic
strFile = strParts(1)
If Right$(strFile, 1) = "\" Then strFile = strFile & DefaultPage
strFile = ResolvePath(VDirPath & strFile)
If Left$(strFile, Len(VDirPath)) <> VDirPath Then
'Bad request, trying to snoop outside VDir?
SendCanned 403
Else
'Locate file.
On Error Resume Next
GetAttr strFile
If Err.Number Then
'No such file.
On Error GoTo 0
SendCanned 404
Else
'Found file.
On Error GoTo 0
If strParts(0) = "HEAD" Then
'Return only HEADers.
SendStaticHeader FileLen(strFile), strFile
Else
'GET of static content.
On Error Resume Next
dtSince = _
UTCParseString(mColReqHeaders("IF-MODIFIED-SINCE")(1))
If Err.Number Then
On Error GoTo 0
blnReturnFile = True
Else
On Error GoTo 0
blnReturnFile = _
dtSince < UTCDateTime(FileDateTime(strFile))
End If
If blnReturnFile Then
On Error Resume Next
mIntFile = GetFreeFile()
If Err.Number Then
On Error GoTo 0
RaiseLogEvent GE, mIntIndex
GE.EventSubtype = gesServerError
GE.Text = "Ran out of file numbers"
SendCanned 500.13
Else
'Open file, format and send headers and prime for
'transmission of content.
On Error GoTo 0
Open strFile For Binary Access Read As #mIntFile
' ReDim mBytBuffer(STATIC_BUFFER_SZ - 1)
ReDim mBytBuffer(mBufferSize - 1)
lngFileBytes = LOF(mIntFile)
' mIntFullBlocks = lngFileBytes \ STATIC_BUFFER_SZ
mIntFullBlocks = lngFileBytes \ mBufferSize
' mIntLastBlockSize = lngFileBytes Mod STATIC_BUFFER_SZ
mLngLastBlockSize = lngFileBytes Mod mBufferSize
SendStaticHeader lngFileBytes, strFile
'File content will be sent via SendComplete handler.
End If
Else
SendCanned 304
End If
End If
End If
End If
End If
Case "POST"
GE.EventSubtype = gesPOST
RaiseDynamicRequest strParts(0), _
strParts(1), _
mStrContent, _
mColReqHeaders, _
sngStatus, _
strStatusText, _
strMIME, _
strRespExtraHeaders, _
mBytResponse, _
mIntIndex
If sngStatus = 0 Then
SendCanned 501
Else
SendResponse sngStatus, _
strStatusText, _
strMIME, _
strRespExtraHeaders
End If
Case Else
GE.EventSubtype = gesUnknown
SimpleServer_CloseSck (mIntIndex)
End Select
mStrContent = ""
RaiseLogEvent GE, mIntIndex
mReqState = rqsIdle
Set mColReqHeaders = Nothing
End If
End Sub
Public Property Get ServerHeader() As String
Attribute ServerHeader.VB_Description = "Returns versioned server header string for responses"
Attribute ServerHeader.VB_MemberFlags = "40"
ServerHeader = mServerHeader
End Property
Public Property Get State() As Integer
Attribute State.VB_Description = "Returns State of the listener Winsock control"
State = State
End Property
Public Property Get VDir() As String
Attribute VDir.VB_Description = "Directory containing static resources of Gossamer site"
VDir = mVDir
End Property
Public Property Let VDir(ByVal Directory As String)
' If wskRequest.State <> sckListening Then
mVDir = Directory
If Len(mVDir) = 0 Then
mVDirPath = CurDir$()
Else
mVDirPath = ResolvePath(mVDir)
End If
' Else
' Err.Raise &H8004A704, "Gossamer", "Can't change VDir while listening"
' End If
End Property
Public Property Get VDirPath() As String
Attribute VDirPath.VB_Description = "Returns fully qualified path for current VDir setting"
VDirPath = mVDirPath
End Property
Public Function EntityEncode(ByVal Text As String) As String
Attribute EntityEncode.VB_Description = "Encode a text string to be inserted into HTML as text with HTML entity encoding"
EntityEncode = Join$(Split(Text, "&"), "&")
EntityEncode = Join$(Split(EntityEncode, """"), """)
EntityEncode = Join$(Split(EntityEncode, "<"), "<")
EntityEncode = Join$(Split(EntityEncode, ">"), ">")
End Function
Public Function ExtensionToMIME(ByVal Extension As String) As String
Attribute ExtensionToMIME.VB_Description = "Return MIME type corresponding to the supplied file extension value (without .)"
Extension = UCase$(Extension)
Select Case Extension
Case "CSS"
ExtensionToMIME = "text/css"
Case "GIF"
ExtensionToMIME = "image/gif"
Case "HTM", "HTML"
ExtensionToMIME = "text/html"
Case "ICO"
ExtensionToMIME = "image/vnd.microsoft.icon"
Case "JPG", "JPEG"
ExtensionToMIME = "image/jpeg"
Case "JS", "JSE"
ExtensionToMIME = "application/javascript"
Case "PNG"
ExtensionToMIME = "image/png"
Case "RTF"
ExtensionToMIME = "application/rtf"
Case "TIF", "TIFF"
ExtensionToMIME = "image/tiff"
Case "TXT"
ExtensionToMIME = "text/plain"
Case "VBS", "VBE"
ExtensionToMIME = "application/vbscript"
Case "XML", "XSD"
ExtensionToMIME = "text/xml"
Case "ZIP"
ExtensionToMIME = "application/zip"
Case Else
ExtensionToMIME = "application/octet-stream"
End Select
End Function
Private Function ExtractResp() As String
ExtractResp = Left$(mStrRespBuffer, mLngRespUsed)
mLngRespUsed = 0
End Function
Public Function GetFreeFile() As Integer
Attribute GetFreeFile.VB_Description = "Calls FreeFile(0) to get file number, if exhausted tries FreeFile(1)"
On Error Resume Next
GetFreeFile = FreeFile(0)
If Err.Number Then
On Error GoTo 0
GetFreeFile = FreeFile(1)
End If
End Function
Private Function GetNextSocket() As Long
Dim lNum As Long
For lNum = 0 To MaxConnections
If mServer(lNum).State = 0 Then Exit For 'Closed socket found
Next lNum
GetNextSocket = lNum
End Function
Public Sub RaiseDynamicRequest(ByVal Method As String, _
ByVal URI As String, _
ByVal Params As String, _
ByVal ReqHeaders As Collection, _
ByRef RespStatus As Single, _
ByRef RespStatusText As String, _
ByRef RespMIME As String, _
ByRef RespExtraHeaders As String, _
ByRef RespBody() As Byte, _
ByVal Index As Integer)
RaiseEvent DynamicRequest(Method, _
URI, _
Params, _
ReqHeaders, _
RespStatus, _
RespStatusText, _
RespMIME, _
RespExtraHeaders, _
RespBody, _
Index)
End Sub
Public Sub RaiseLogEvent(ByVal GossEvent As GossEvent, ByVal Index As Integer)
Attribute RaiseLogEvent.VB_Description = "Only for use by GossClient"
Attribute RaiseLogEvent.VB_MemberFlags = "40"
RaiseEvent LogEvent(GossEvent, Index)
End Sub
Public Function ResolvePath(ByVal RelativePath As String) As String
Attribute ResolvePath.VB_Description = "Only for use by GossClient"
Attribute ResolvePath.VB_MemberFlags = "40"
'Returns full path to RelativePath, "" if any error.
Dim strFullPath As String
Dim lngLen As Long
Dim lngFilePart As Long
lngLen = GetFullPathName(StrPtr(RelativePath), 0, StrPtr(strFullPath), lngFilePart)
If lngLen Then
'If the lpBuffer buffer is too small to contain the path, the return value
'is the size, in TCHARs, of the buffer that is required to hold the path
'and the terminating null character.
strFullPath = String$(lngLen - 1, 0)
lngLen = GetFullPathName(StrPtr(RelativePath), lngLen, StrPtr(strFullPath), lngFilePart)
If lngLen Then
'If the function succeeds, the return value is the length, in TCHARs,
'of the string copied to lpBuffer, not including the terminating null
'character.
ResolvePath = strFullPath
End If
End If
End Function
Private Sub SendCanned(ByVal Status As Single)
Const MSG304 As String = "304 Not Modified"
Const MSG403 As String = "403 Forbidden"
Const MSG404 As String = "404 Not Found"
Const MSG500 As String = "500 Internal Server Error"
Const MSG500_13 As String = "500.13 Server busy"
Const MSG501 As String = "501 Not Implemented"
Select Case Status
Case 304
SendCannedFormatted MSG304
Case 403
SendCannedFormatted MSG403
Case 404
SendCannedFormatted MSG404
Case 500.13
SendCannedFormatted MSG500_13
Case 501
SendCannedFormatted MSG501
Case Else
SendCannedFormatted MSG500
End Select
End Sub
Private Sub SendCannedFormatted(ByVal StatusText As String)
AppendResp mStrHTTPVersion & " " & StatusText & vbCrLf
AppendResp "Date:" & UTCString(Now()) & vbCrLf
AppendResp "Content-Type:text/html" & vbCrLf
AppendResp "Content-Length:" & CStr(Len(StatusText) + 35) & vbCrLf
AppendResp "Accept-Ranges:none" & vbCrLf
AppendResp ServerHeader & DOUBLE_CRLF
AppendResp "<html><body><h1>" & StatusText & "</h1></body></html>"
' wskClient.SendData ExtractResp()
mServer(mIntIndex).sOutBuffer = ExtractResp
mServer(mIntIndex).TCPSend
End Sub
Private Sub SendResponse(ByVal Status As Single, ByVal StatusText As String, ByVal MIME As String, ByVal ExtraHeaders As String)
AppendResp mStrHTTPVersion & " " & CStr(Status) & " " & StatusText & vbCrLf
AppendResp "Date:" & UTCString(Now()) & vbCrLf
If InStr(1, ExtraHeaders, "Last-Modified:", vbTextCompare) = 0 Then
AppendResp "Last-Modified:" & UTCString(Now()) & vbCrLf
End If
If Len(MIME) > 0 Then AppendResp "Content-Type:" & MIME & vbCrLf
mLngResponseLen = 0
On Error Resume Next
mLngResponseLen = UBound(mBytResponse) + 1
On Error GoTo 0
AppendResp "Content-Length:" & CStr(mLngResponseLen) & vbCrLf
AppendResp "Accept-Ranges:none" & vbCrLf
AppendResp ServerHeader & vbCrLf
If Len(ExtraHeaders) > 0 Then
AppendResp ExtraHeaders
If Right$(ExtraHeaders, 2) <> vbCrLf Then AppendResp vbCrLf
End If
AppendResp vbCrLf 'Second CRLF, terminating headers.
mServer(mIntIndex).sOutBuffer = ExtractResp
mServer(mIntIndex).TCPSend
End Sub
Private Sub SendStaticHeader(ByVal Length As Long, ByVal Resource As String)
Dim strMIME As String
strMIME = ExtensionToMIME(Mid$(Resource, InStrRev(Resource, ".") + 1))
AppendResp mStrHTTPVersion & " 200 Ok" & vbCrLf
AppendResp "Date:" & UTCString(Now()) & vbCrLf
AppendResp "Last-Modified:" & UTCString(FileDateTime(Resource)) & vbCrLf
AppendResp "Content-Type:" & strMIME & vbCrLf
AppendResp "Content-Length:" & CStr(Length) & vbCrLf
AppendResp "Accept-Ranges:none" & vbCrLf
AppendResp ServerHeader & DOUBLE_CRLF
mServer(mIntIndex).sOutBuffer = ExtractResp
mServer(mIntIndex).TCPSend
End Sub
Public Sub StartListening(Optional ByVal Port As Long = -1, Optional ByVal AdapterIP As String = "")
Attribute StartListening.VB_Description = "Begin accepting HTTP connections, may specify listen port and adapter IP to bind to"
Dim GE As GossEvent
Dim lNum As Long
If Port > -1 Then Me.Port = Port
IPVersion = "4"
ReDim mServer(MaxConnections)
For lNum = 0 To MaxConnections
Set mServer(lNum).Callback(lNum) = Me
mServer(lNum).EncrFlg = False
mServer(lNum).IPvFlg = CLng(IPVersion)
Next
ReDim RecLen(MaxConnections)
ReDim RecType(MaxConnections)
mServer(0).Listen (Port)
mBufferSize = mServer(0).BufferSize
Set GE = New GossEvent
With GE
.EventType = getServer
.EventSubtype = gesStarted
.IP = AdapterIP
.Port = Me.Port
.Text = "Service started."
End With
RaiseEvent LogEvent(GE, -1)
End Sub
Public Sub StopListening()
Attribute StopListening.VB_Description = "Shuts down any active GossClients and stops listening for client connection requests"
Dim GE As GossEvent
Dim Index As Integer
SimpleServer_CloseSck (0) 'Close listening socket
Set GE = New GossEvent
With GE
.EventType = getServer
.EventSubtype = gesStopped
.Text = "Service stopped."
End With
RaiseEvent LogEvent(GE, -1)
End Sub
Public Function URLDecode(ByVal URLEncoded As String) As String
Attribute URLDecode.VB_Description = "Converts URLEncoded string to plaintext string"
Dim intPart As Integer
Dim strParts() As String
URLDecode = Replace$(URLEncoded, "+", " ")
strParts = Split(URLDecode, "%")
For intPart = 1 To UBound(strParts)
strParts(intPart) = _
Chr$(CLng("&H" & Left$(strParts(intPart), 2))) _
& Mid$(strParts(intPart), 3)
Next
URLDecode = Join$(strParts, "")
End Function
Public Function UTCDateTime(ByVal DateTime As Date) As Date
Attribute UTCDateTime.VB_Description = "Convert Date value from local time to UTC equivalent"
Dim tzi As TIME_ZONE_INFORMATION
Dim lngRet As Long
Dim lngOffsetMinutes As Long
'Return the time difference between local & GMT time in minutes.
lngRet = GetTimeZoneInformation(tzi)
lngOffsetMinutes = -tzi.Bias
'If we are in daylight saving time, apply the bias if applicable.
If lngRet = TIME_ZONE_ID_DAYLIGHT Then
If tzi.DaylightDate.wMonth Then
lngOffsetMinutes = lngOffsetMinutes - tzi.DaylightBias
End If
End If
UTCDateTime = DateAdd("n", lngOffsetMinutes, DateTime)
End Function
Public Function UTCParseString(ByVal UTCString As String) As Date
Attribute UTCParseString.VB_Description = "Convert HTTP UTC timestamp string to Date value, if badly formatted return Now() value"
On Error Resume Next
UTCParseString = CDate(Mid$(UTCString, 6, 20))
If Err.Number Then UTCParseString = UTCDateTime(Now())
End Function
Public Function UTCString(ByVal DateTime As Date) As String
Attribute UTCString.VB_Description = "Converts Date value in local time zone to HTTP timestamp in GMT form"
UTCString = Format$(UTCDateTime(DateTime), _
"Ddd, dd Mmm YYYY HH:NN:SS \G\M\T")
End Function
Private Sub SimpleServer_CloseSck(ByVal Index As Long)
On Error Resume Next
Call mServer(Index).CloseSocket
End Sub
Private Sub SimpleServer_Connect(ByVal Index As Long)
End Sub
Private Sub SimpleServer_ConnectionRequest(ByVal Index As Long, ByVal requestID As Long, ByVal lRemotePort As Long, ByVal sRemoteHostIP As String)
Dim lTmp As Long
lTmp = GetNextSocket
If lTmp > MaxConnections Then 'Request will exceed maximum, close the socket
Call mServer(lIndex).Accept(requestID, 0, "")
Exit Sub
Else 'Accept the connection request
lIndex = lTmp
RemoteHostIP = sRemoteHostIP
RemotePort = lRemotePort
Call mServer(lIndex).Accept(requestID, RemotePort, RemoteHostIP)
LastConnect = mServer(lIndex).RemoteHostIP
End If
End Sub
Private Sub SimpleServer_DataArrival(ByVal Index As Long, ByVal bytesTotal As Long)
Dim GE As GossEvent
Dim strFragment As String
Dim strHeadBlock As String
Static strBuffer As String 'the buffer of the loading message
Dim strChar As String
Dim strContentLen As String
Dim lInStr As Long
Dim lHeader As Long
Dim strHeaders() As String
Dim strParts() As String
mServer(Index).RecoverData 'Get inbound byte data
strFragment = mServer(Index).sInBuffer 'Recover as string data
mStrBuffer = mStrBuffer & strFragment
Debug.Print strFragment
If mReqState = rqsIdle Then
'Erratic POST cleanup:
'There is not supposed to be anything after the POST content but many
'clients submit an extra CRLF. Delete them if found here, which will
'be a leftover from a previous request on a persistent connection.
Do
lInStr = InStr(mStrBuffer, vbCrLf)
If lInStr > 0 Then
If lInStr > 1 Then
'We found a complete Request Line.
mStrReqLine = Left$(mStrBuffer, lInStr - 1)
mReqState = rqsReqLineComplete
End If
mStrBuffer = Mid$(mStrBuffer, lInStr + 2)
End If
Loop Until lInStr = 0 Or lInStr > 1
End If
'Look for the Headers block if we have the Request Line.
If mReqState = rqsReqLineComplete Then
lInStr = InStr(mStrBuffer, DOUBLE_CRLF)
If lInStr > 0 Then
'We have the Headers.
strHeadBlock = Left$(mStrBuffer, lInStr - 1)
mStrBuffer = Mid$(mStrBuffer, lInStr + 4)
'Parse Headers into Collection. Keys are stored UPPERCASED.
Set mColReqHeaders = New Collection
strHeaders = Split(strHeadBlock, vbCrLf)
For lHeader = 0 To UBound(strHeaders)
strParts = Split(strHeaders(lHeader), ":", 2)
'Strip whitespace from Attribute.
strChar = Right$(strParts(0), 1)
Do While strChar = vbTab Or strChar = " "
strParts(1) = Left$(strParts(0), Len(strParts(0)) - 1)
strChar = Right$(strParts(0), 1)
Loop
If UBound(strParts) > 0 Then
'Strip whitespace from Value.
strChar = Left$(strParts(1), 1)
Do While strChar = vbTab Or strChar = " "
strParts(1) = Mid$(strParts(1), 2)
strChar = Left$(strParts(1), 1)
Loop
End If
'Watch for and remove duplicate headers (keep last one).
On Error Resume Next
mColReqHeaders.Add strParts, UCase$(strParts(0))
If Err.Number Then
mColReqHeaders.Remove strParts(0)
mColReqHeaders.Add strParts, UCase$(strParts(0))
End If
On Error GoTo 0
Next
'Look for Content-Length.
On Error Resume Next
strContentLen = mColReqHeaders("CONTENT-LENGTH")(1)
If Err.Number Then
'No Content-Length header. Bypass checking for it.
On Error GoTo 0
mReqState = rqsRequestComplete
Else
'Process Content-Length.
On Error GoTo 0
If IsNumeric(strContentLen) Then
mLngContentLen = CLng(strContentLen)
mReqState = rqsHeadersComplete
Else
'Bad Content-Length error.
Set GE = New GossEvent
With GE
.EventType = getHTTP
.EventSubtype = gesHTTPError
.IP = RemoteHostIP
.Port = RemotePort
.Method = "ERROR"
.Text = "Bad Content-Length header value: " & strContentLen
End With
RaiseLogEvent GE, mIntIndex
'wskClient_Close
SimpleServer_CloseSck (Index)
Exit Sub
End If
End If
End If
End If
'Look for the end of the Request if we have processed the Headers.
If mReqState = rqsHeadersComplete Then
If Len(mStrBuffer) >= mLngContentLen Then
mStrContent = Left$(mStrBuffer, mLngContentLen)
mStrBuffer = Mid$(mStrBuffer, mLngContentLen + 1)
mReqState = rqsRequestComplete
End If
End If
'Process completed Request (all of Content-Length rcvd or no Content-Length header).
mIntIndex = Index
If mReqState = rqsRequestComplete Then ProcessRequest
End Sub
Private Sub SimpleServer_EncrDataArrival(ByVal Index As Long, ByVal bytesTotal As Long)
End Sub
Private Sub SimpleServer_Error(ByVal Index As Long, ByVal Number As Long, Description As String, ByVal Source As String)
End Sub
Private Sub SimpleServer_SendComplete(ByVal Index As Long)
Debug.Print "SendComplete"
If mLngResponseLen > 0 Then
mLngResponseLen = 0
mServer(Index).bOutBuffer = mBytResponse
mServer(Index).TCPSend
Erase mBytResponse
Exit Sub 'Bypass CheckClose until next SendComplete.
End If
If mIntFile Then
'We're sending a static (file) resource. Continue.
If mIntFullBlocks > 0 Then
Get #mIntFile, , mBytBuffer
mIntFullBlocks = mIntFullBlocks - 1
Else
If mLngLastBlockSize > 0 Then
ReDim mBytBuffer(mLngLastBlockSize - 1)
Get #mIntFile, , mBytBuffer
End If
Close #mIntFile
mIntFile = 0
If mLngLastBlockSize <= 0 Then GoTo CheckClose
End If
'wskClient.SendData mBytBuffer
mServer(Index).bOutBuffer = mBytBuffer
mServer(Index).TCPSend
Exit Sub 'Bypass CheckClose until next SendComplete.
End If
CheckClose:
If mBlnConnClose Then
'Request had a "Connection: close" header.
'wskClient_Close
SimpleServer_CloseSck (Index)
End If
End Sub
Private Sub SimpleServer_SendProgress(ByVal Index As Long, ByVal bytesSent As Long, ByVal bytesRemaining As Long)
End Sub
Private Sub SimpleServer_WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
End Sub
Private Sub UserControl_Initialize()
ChDir App.Path
mServerHeader = "Server:TS.Gossamer/" & GOSS_VERSION_MAJOR & "." & GOSS_VERSION_MINOR _
& vbCrLf _
& "X-Powered-By:Microsoft.Visual.Basic.6.0"
End Sub
Private Sub UserControl_InitProperties()
DefaultPage = "index.html"
MaxConnections = 320
Port = 8080
VDir = ""
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
DefaultPage = PropBag.ReadProperty("DefaultPage", "index.html")
MaxConnections = PropBag.ReadProperty("MaxConnections", 320)
Port = PropBag.ReadProperty("Port", 8080)
VDir = PropBag.ReadProperty("VDir", "")
End Sub
Private Sub UserControl_Resize()
Const DIMENSIONS As Single = 420
With UserControl
.Height = DIMENSIONS
.Width = DIMENSIONS
End With
With Shape1
.Height = DIMENSIONS
.Width = DIMENSIONS
End With
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "DefaultPage", DefaultPage, "index.htm"
PropBag.WriteProperty "MaxConnections", MaxConnections, 32
PropBag.WriteProperty "Port", Port, 8080
PropBag.WriteProperty "VDir", VDir, ""
End Sub