iServer.vb

' --------------------
' 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