www.pudn.com > tinyserver.zip > frmServer.frm
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Server
BorderStyle = 1 'Fixed Single
Caption = "Tiny Server"
ClientHeight = 4110
ClientLeft = 45
ClientTop = 330
ClientWidth = 7455
Icon = "frmServer.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 4110
ScaleWidth = 7455
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Configure
Caption = "Configure Server"
Height = 375
Left = 5520
TabIndex = 3
Top = 240
Width = 1335
End
Begin VB.CommandButton StopButton
Caption = "Stop Server"
Height = 375
Left = 3060
TabIndex = 2
Top = 240
Width = 1335
End
Begin VB.CommandButton StartButton
Caption = "Start Server"
Height = 375
Left = 600
TabIndex = 1
Top = 240
Width = 1335
End
Begin VB.TextBox TextBox
Height = 2895
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 1080
Width = 7215
End
Begin MSWinsockLib.Winsock tcpServer
Index = 0
Left = 6960
Top = 240
_ExtentX = 741
_ExtentY = 741
_Version = 393216
LocalPort = 80
End
Begin VB.Label Label1
Caption = "Message Window"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = -1 'True
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 3060
TabIndex = 4
Top = 840
Width = 1335
End
End
Attribute VB_Name = "Server"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim cnt As Integer
Private Sub Configure_Click()
Dim fOptions As New frmOptions
fOptions.Show vbModal
End Sub
Private Sub Form_Load()
Dim i As Long
Dim sFile As String
Dim fileNum As Integer
Dim rFile As Variant
cnt = 0
fileNum = FreeFile
Open "server.ini" For Input As #fileNum
Line Input #fileNum, sFile
rFile = Split(sFile, "=")
If StrComp(rFile(0), "wwwroot", vbTextCompare) = 0 Then
wwwRoot = rFile(1)
End If
Line Input #fileNum, sFile
rFile = Split(sFile, "=")
If StrComp(rFile(0), "defaultpage", vbTextCompare) = 0 Then
DefaultPage = rFile(1)
End If
Close #fileNum
For i = 1 To 100
Load tcpServer(i)
Next
PortNum = 80
Exit Sub
ErrHandler:
Unload Me
End Sub
Private Sub StartButton_Click()
' Set the LocalPort property to an integer.
' Then invoke the Listen method.
tcpServer(0).LocalPort = PortNum
tcpServer(0).Listen
TextBox.Text = "TinyServer started . . ." + vbCrLf + "Listening on port : " + Str(PortNum) + vbCrLf
End Sub
Private Sub StopButton_Click()
Dim i As Integer
For i = 1 To cnt
Unload tcpServer(i)
Next
cnt = 0
tcpServer(0).Close
If tcpServer(0).State <> sckListening Then
TextBox.Text = TextBox.Text + vbCrLf + "TinyServer stopped..."
End If
End Sub
Private Sub tcpServer_ConnectionRequest _
(Index As Integer, ByVal requestID As Long)
Dim i As Integer
' Accept the request with the requestID
' parameter.
If Index = 0 Then
For i = 1 To 100
If tcpServer(i).State = sckClosed Then
tcpServer(i).LocalPort = 0
tcpServer(i).Accept requestID
TextBox.Text = TextBox.Text + vbCrLf + "Connection from : " + tcpServer(cnt).RemoteHostIP
Exit For
End If
Next i
End If
End Sub
Private Sub tcpServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim a As Integer
Dim inData As String
tcpServer(Index).GetData inData
Call serveRequest(Index, inData)
'tcpServer(Index).Close
End Sub
Private Sub serveRequest(ind As Integer, inData As String)
Dim rServer As Winsock
Dim i As Integer
Dim fileNum As Integer
Dim Method As String
Dim Request As String
Dim lRequest As String
Dim httpVersion As String
Dim Accept() As String
Dim AcceptLanguage As String
Dim UserAgent As String
Dim Connection As String
Dim Referer As String
Dim Host As String
Dim AcceptEncoding As String
Dim Cookie As String
Dim SplitHeader() As String
Dim SplitTemp() As String
Dim sFile As String
Dim outData As String
Dim fileDate As Date
i = 1
Set rServer = tcpServer(ind)
SplitHeader = Split(inData, vbCrLf)
SplitTemp = Split(SplitHeader(0))
Method = SplitTemp(0)
Request = SplitTemp(1)
httpVersion = SplitTemp(2)
While StrComp(SplitHeader(i), "") <> 0
SplitTemp = Split(SplitHeader(i), ": ")
Select Case SplitTemp(0)
Case "Accept"
Accept = Split(SplitTemp(1), ", ")
Case "Accept-Language"
AcceptLanguage = SplitTemp(1)
Case "Accept-Encoding"
AcceptEncoding = SplitTemp(1)
Case "User-Agent"
UserAgent = SplitTemp(1)
Case "Host"
Host = SplitTemp(1)
Case "Connection"
Connection = SplitTemp(1)
Case "Cookie"
Cookie = SplitTemp(1)
End Select
i = i + 1
Wend
If StrComp(Method, "GET") <> 0 Then
rServer.SendData errorPage(405, "Method not allowed : " + Method + "")
Exit Sub
End If
SplitTemp = Split(Request, "/")
lRequest = Join(SplitTemp, "\")
If StrComp(Right(lRequest, 1), "\", vbTextCompare) = 0 Then
sFile = wwwRoot + lRequest + DefaultPage
If StrComp(Dir$(sFile), "", vbTextCompare) = 0 Then
rServer.SendData errorPage(403, "You do not have the permission to access " + Request + " on this server")
Exit Sub
End If
Else
sFile = wwwRoot + lRequest
If StrComp(Dir$(sFile), "") = 0 Then
sFile = wwwRoot + lRequest + "\" + DefaultPage
End If
End If
If StrComp(Dir$(sFile), "", vbTextCompare) = 0 Then
rServer.SendData errorPage(404, "The following page was not found on this server : " + Request + "")
Exit Sub
End If
fileNum = FreeFile
Open sFile For Binary As #fileNum
outData = Input(LOF(fileNum), #fileNum)
Close #fileNum
fileDate = FileDateTime(sFile)
SplitTemp = Split(sFile, ".")
rServer.SendData makemimeHeader(200, FileLen(sFile), SplitTemp(1), Format(fileDate, "ddd, d mmm yyyy hh:mm:ss ") + "GMT", Connection)
rServer.SendData outData
End Sub
Function errorPage(errNum As Integer, errMessage As String) As String
Dim responseHeader As String
Dim responseData As String
Dim sDate As Date
Dim sTime As Date
sDate = Date
sTime = Time
responseData = "" + vbCrLf _
+ "" + vbCrLf _
+ "Error : " + Str(errNum) + " Error : " + Str(errNum) + " " + getReason(errNum) + " |
| " + errMessage + " |
Copyright © Saurabh 2001-2002 |