' --------------------
' The bulk of the iServer class code is based on the C# code written
' by Imtiaz Alman (http://www.codeproject.com/KB/IP/mywebserver.aspx).
' iServer is just a VB.NET port of his basic, web sering subroutines,
' repackaged here to act as a simple XML-RPC server.
' --------------------
Imports System
Imports System.IO
Imports System.IO.Stream
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Text.StringBuilder
Imports System.Text.UTF8Encoding
Imports System.Threading
Imports System.Xml
Public Class iServer
' "Global variables" within the class
Private iListener As TcpListener
Private iPort As Integer = 10240
Private goon As Boolean = True
Private dirloc As String
' Events
Public Event SrvError(ByVal msg As String, ByVal stack As String)
Public Event SrvLog(ByVal msg As String)
' Constructor
Public Sub New()
Me.iPort = 80
Me.dirloc = Environment.CurrentDirectory
End Sub
Public Sub New(ByVal PortNum As Integer)
' Sets the port number the server listens on
Me.iPort = PortNum
Me.dirloc = Environment.CurrentDirectory
End Sub
Public Sub New(ByVal PortNum As Integer, ByVal Location As String)
Me.iPort = PortNum
Me.dirloc = Location
End Sub
' Properties
Public WriteOnly Property SetPort() As Integer
Set(ByVal Value As Integer)
Me.iPort = Value
End Set
End Property
Public ReadOnly Property GetPort() As Integer
Get
Return Me.iPort
End Get
End Property
Public WriteOnly Property SetLocation() As String
Set(ByVal Value As String)
Me.dirloc = Value
End Set
End Property
Public ReadOnly Property GetLocation() As String
Get
Return Me.dirloc
End Get
End Property
' Functions and subroutines
Public Sub SendHeader(ByVal len As Integer, ByRef iSocket As Socket, ByVal contentType As String)
Dim strHeader As New StringBuilder
Dim dateNow As DateTime = DateTime.Now()
strHeader.Append("HTTP/1.0 200 OK").Append(vbCrLf)
strHeader.Append("Server: iServer for iTunes").Append(vbCrLf)
strHeader.Append("Date: ").Append(dateNow.DayOfWeek).Append(" ").Append(dateNow.ToLocalTime).Append(vbCrLf)
strHeader.Append("Content-Length: ").Append(len.ToString()).Append(vbCrLf)
strHeader.Append("Content-Type: ").Append(contentType).Append(vbCrLf).Append(vbCrLf)
SendToBrowser(strHeader.ToString(), iSocket)
End Sub
Public Sub SendToBrowser(ByVal sData As String, ByRef iSocket As Socket)
Me.SendToBrowser(Encoding.UTF8.GetBytes(sData), iSocket)
End Sub
Public Sub SendToBrowser(ByVal bSendData() As Byte, ByRef iSocket As Socket)
Dim numBytes As Integer = 0
Try
If iSocket.Connected = True Then
If (numBytes = iSocket.Send(bSendData, bSendData.Length, 0)) = -1 Then
RaiseEvent SrvError("No bytes to send.", "")
Exit Sub
End If
End If
Catch ex As Exception
RaiseEvent SrvError(ex.Message, ex.StackTrace)
End Try
End Sub
' The main listener
Private Sub StartListen()
Do While goon = True
Dim iSocket As Socket = iListener.AcceptSocket()
If iSocket.Connected = True Then
Dim reqReceive() As Byte = New Byte(1024) {}
Dim reqLen As Integer = iSocket.Receive(reqReceive, reqReceive.Length, 0)
Dim reqBuffer As String = Encoding.UTF8.GetString(reqReceive)
Dim headers As Hashtable = ParseHeader(reqBuffer)
Dim contentType As String = "text/html; charset=UTF-8"
Dim dataString As String = ""
If reqBuffer.Substring(0, 3) = "GET" Then
Dim methodLen As Integer = "GET ".Length
Dim endPos As Integer = reqBuffer.IndexOf(" HTTP") - methodLen
Dim path As String = reqBuffer.Substring(methodLen, endPos)
Dim pathTemp As String = System.Web.HttpUtility.UrlDecode(path)
pathTemp = pathTemp.Replace("/", "\\")
RaiseEvent SrvLog(path)
If File.Exists(Me.dirloc + pathTemp) Then
Dim fs As New FileStream(Me.dirloc + pathTemp, FileMode.Open, FileAccess.Read)
Dim br As New BinaryReader(fs)
Dim bytes(fs.Length) As Byte
Dim read As Integer
contentType = selectMimeType(path)
read = br.Read(bytes, 0, bytes.Length)
br.Close()
fs.Close()
SendHeader(bytes.Length, iSocket, contentType)
SendToBrowser(bytes, iSocket)
Else
If path.IndexOf("?") > -1 Then
Dim pathAndArgs() As String = path.Split({"?"c}, 2)
Command(pathAndArgs(0), pathAndArgs(1), headers, "GET", iSocket, contentType)
Else
Command(path, "", headers, "GET", iSocket, contentType)
End If
End If
ElseIf reqBuffer.Substring(0, 4) = "POST" Then
Dim methodLen As Integer = "POST ".Length
Dim endPos As Integer = reqBuffer.IndexOf(" HTTP") - methodLen
If reqBuffer.IndexOf("?") > -1 Then
endPos = reqBuffer.IndexOf("?") - methodLen
End If
Dim path As String = reqBuffer.Substring(methodLen, endPos)
Dim contentLen As Integer = Integer.Parse(headers.Item("Content-Length"))
RaiseEvent SrvLog(path)
Command(path, ParseRequest(reqBuffer, contentLen), headers, "POST", iSocket, contentType)
Else
iSocket.Close()
Return
End If
iSocket.Close()
End If
Loop
End Sub
' Command Sub
Public Overridable Sub Command(ByVal path As String, ByVal args As String, _
ByVal headers As Hashtable, ByVal method As String, _
ByRef iSocket As Socket, ByVal contentType As String)
Dim x As String = "<p>" + path + "</p><p>" + args + "</p>"
SendHeader(x.Length, iSocket, contentType)
SendToBrowser(Encoding.UTF8.GetBytes(x), iSocket)
End Sub
' Gets the MIME type based on file extension
Private Function selectMimeType(ByVal file As String) As String
Dim retval As String = "text/plain"
Dim parts() As String = file.Split(".")
Dim ext As String = parts(parts.Length - 1).ToLower
Select Case ext
Case "jpg"
retval = "image/jpeg"
Case "gif"
retval = "image/gif"
Case "png"
retval = "image/png"
Case "swf"
retval = "application/x-shockwave-flash"
Case "js"
retval = "application/x-javascript"
Case "xml"
retval = "application/xml"
Case "rss"
retval = "application/xml"
Case "opml"
retval = "application/xml"
Case "pdf"
retval = "application/pdf"
Case "htm"
retval = "text/html"
Case "html"
retval = "text/html"
Case "txt"
retval = "text/plain"
End Select
Return retval
End Function
' Parses the request header
Private Function ParseHeader(ByVal header As String) As Hashtable
header = header.Replace(vbLf, "")
Dim vals As New Hashtable
Dim headers() As String = header.Split(vbCr)
Dim cnt As Integer = 0
For Each line As String In headers
If cnt > 0 Then
If line.Length > 0 Then
Dim parts() As String = line.Split({": "}, 2, StringSplitOptions.None)
vals.Add(parts(0), parts(1))
Else
Exit For
End If
End If
cnt = cnt + 1
Next
Return vals
End Function
' Parses the header and pulls out the data
Private Function ParseRequest(ByVal header As String, ByVal length As Integer) As String
header = header.Replace(vbLf, "")
Dim data As String = ""
Dim headers() As String = header.Split(vbCr)
Dim keeploop As Integer = 0
For Each line As String In headers
If keeploop = 0 Then
If line.Length = 0 Then
keeploop = 1
End If
ElseIf keeploop = 1 Then
data = line.Substring(0, length)
keeploop = -1
ElseIf keeploop = -1 Then
Exit For
End If
Next
Return data
End Function
' Starts the server running
Public Sub StartServer()
Try
iListener = New TcpListener(IPAddress.Any, iPort)
iListener.Start()
' Allows for the creation of multiple threads
Dim th As New Thread(AddressOf StartListen)
th.Start()
Catch ex As Exception
RaiseEvent SrvError(ex.Message, ex.StackTrace)
End Try
End Sub
' Stops the server thread
Public Sub StopServer()
Me.goon = False
End Sub
End Class
Comments