Option Explicit On
Option Strict On

Imports System.Threading
Imports System.Net.Sockets
Imports System.Net
Imports System.Text
Imports System.IO
Imports System.Text.RegularExpressions

Namespace MicroHTTP

    ''' <summary>Класс содержит данные события ProcessRequest</summary>
    Public Class ProcessRequestEventArgs
        Inherits EventArgs

        Public ReadOnly Property Request As Request
        Public ReadOnly Property Response As Response

        Sub New(req As Request, res As Response)
            Me.Request = req
            Me.Response = res
        End Sub

    End Class

    ''' <summary>Класс содержит данные события ProcessError</summary>
    Public Class ProcessErrorEventArgs
        Inherits EventArgs

        Public ReadOnly Property Exception As Exception

        Sub New(ex As Exception)
            Me.Exception = ex
        End Sub
    End Class

    ''' <summary>Список кодов ответа</summary>
    Public Enum HttpCodes
        OK = 200
        MOVED_PERMANENTLY = 301
        FOUND = 302
        BAD_REQUEST = 400
        FORBIDDEN = 403
        NOT_FOUND = 404
        METHOD_NOT_ALLOWED = 405
        SERVER_ERROR = 500
        NOT_IMPELEMENTED = 501
        SERVICE_UNAVAILABLE = 503
    End Enum

    ''' <summary>Список предопределенных MIME типов</summary>
    Public Enum ContentTypes
        TEXT_HTML
        TEXT_HTML_UTF8
        TEXT_PLAIN
        TEXT_PLAIN_UTF8
        TEXT_CSS
        TEXT_JAVASCRIPT
        IMAGE_PNG
        IMAGE_JPEG
        IMAGE_GIF
        APP_OCTET_STREAM
    End Enum

    ''' <summary>Класс предоставляет объект для создания асинхронного слушателя порта</summary>
    Public Class WebServer

        Public Event ProcessRequest(ByVal sender As Object, ByVal e As ProcessRequestEventArgs)
        Public Event ProcessError(ByVal sender As Object, ByVal e As ProcessErrorEventArgs)

        Public Property ReadTimeout As Integer = 15000
        Public Property WriteTimeout As Integer = 15000

        Private reContentLength As New Regex("Content-Length:\s+(\d+)", RegexOptions.Compiled Or RegexOptions.IgnoreCase Or RegexOptions.Multiline)
        Private Const HTTP_NEW_LINE = vbCrLf & vbCrLf

        Private listener As TcpListener
        Private listenerThread As Thread

        ''' <summary>Конструктор с параметрами по-умолчанию: на всех интерфейсах и порт 80</summary>
        Public Sub New()
            Me.New(IPAddress.Any, 80)
        End Sub

        ''' <summary>Конструктор с параметрами порта</summary>
        Public Sub New(Port As Integer)
            Me.New(IPAddress.Any, Port)
        End Sub

        ''' <summary>Конструктор с параметрами локального адреса и порта</summary>
        Public Sub New(LocalAddress As IPAddress, Port As Integer)
            listener = New TcpListener(LocalAddress, Port)
            listenerThread = New Thread(New ThreadStart(AddressOf ProcessListener))
        End Sub

        ''' <summary>Запуск сервера</summary>
        Public Sub Start()
            listener.Start()
            listenerThread.Start()
        End Sub

        ''' <summary>Остановка сервера</summary>
        Public Sub Finish()
            listener.Stop()
            listenerThread.Abort()
        End Sub

        Private Sub ProcessListener()
            Dim threadCount, portsCount As Integer

            ThreadPool.GetMinThreads(threadCount, portsCount)
            ThreadPool.SetMaxThreads(threadCount, portsCount)

            Do While True
                ThreadPool.QueueUserWorkItem(New WaitCallback(AddressOf ProcessWorkItem), listener.AcceptTcpClient())
            Loop
        End Sub

        Private Sub ProcessWorkItem(State As Object)
            Dim remoteTcpClient As TcpClient = Nothing, remoteStream As NetworkStream = Nothing

            Try
                'Подключаемся
                remoteTcpClient = DirectCast(State, TcpClient)
                remoteTcpClient.ReceiveTimeout = Me.ReadTimeout
                remoteTcpClient.SendTimeout = Me.WriteTimeout

                'Читаем запрос от клиента
                remoteStream = remoteTcpClient.GetStream()
                Dim dataRead(8192) As Byte, bytesRead As Integer
                Dim builder As New StringBuilder()

                Do
                    bytesRead = remoteStream.Read(dataRead, 0, dataRead.Length)
                    builder.Append(Encoding.UTF8.GetString(dataRead, 0, bytesRead))
                Loop While Not IsValidHttpPacketLength(builder)

                'Препроцессинг
                Dim reqClass As New Request(builder.ToString(), remoteTcpClient)
                Dim resClass As New Response()

                'Обрабатываем в приложении
                RaiseEvent ProcessRequest(remoteTcpClient, New ProcessRequestEventArgs(reqClass, resClass))

                'Отвечаем на запрос
                Dim dataWrite = resClass.Encoding.GetBytes(resClass.Content)
                remoteStream.Write(dataWrite, 0, dataWrite.Length)

            Catch ex As Exception
                RaiseEvent ProcessError(remoteTcpClient, New ProcessErrorEventArgs(ex))

            Finally 'Закрываемся
                If remoteStream IsNot Nothing Then remoteStream.Close()
                If remoteTcpClient IsNot Nothing Then remoteTcpClient.Close()

            End Try
        End Sub

        ''' <summary>
        ''' Определяет получили ли мы полностью HTTP пакет или ещё нет
        ''' </summary>
        ''' <param name="BufferBuilder">Накопительный пакет с StringBuilder</param>
        Private Function IsValidHttpPacketLength(BufferBuilder As StringBuilder) As Boolean
            Dim strBuffer = BufferBuilder.ToString()
            Dim posCrLf = strBuffer.IndexOf(HTTP_NEW_LINE)

            If strBuffer(0) = "G"c Then
                Return posCrLf > -1

            ElseIf strBuffer(0) = "P"c Then
                If posCrLf > -1 Then
                    Dim posContentLength = strBuffer.IndexOf("Content-Length", 0, posCrLf)

                    If posContentLength > -1 Then
                        Dim realPacketLength = CInt(strBuffer.Length - (posCrLf + 2))
                        Dim headerPacketLength = CInt(reContentLength.Match(strBuffer).Groups(1).Value)

                        If realPacketLength < headerPacketLength Then
                            Return False
                        Else
                            Return True
                        End If
                    End If

                    Return True
                Else
                    Return False
                End If
            Else
                Return True
            End If
        End Function

    End Class

    ''' <summary>Класс предоставляет интерфейс для входящих запросов от клиентов</summary>
    Public Class Request

        Public ReadOnly Property RequestRaw As String
        Public ReadOnly Property RemoteIP As String

        Public ReadOnly Property Method As String
        Public ReadOnly Property Host As String
        Public ReadOnly Property Headers As Dictionary(Of String, String)
        Public ReadOnly Property UserAgent As String
        Public ReadOnly Property Cookie As String

        Public ReadOnly Property OriginalUrl As String
        Public ReadOnly Property Url As String
        Public ReadOnly Property UrlParameters As Dictionary(Of String, String)
        Public ReadOnly Property PostData As String

        Private Const HTTP_NEW_LINE = vbCrLf & vbCrLf

        'Парсим пакет
        Public Sub New(ByVal HttpPacket As String, HttpTcpClient As TcpClient)
            Dim idxHeadersEnd = HttpPacket.IndexOf(HTTP_NEW_LINE)
            If idxHeadersEnd = -1 Then Throw New Exception("MicroHTTP.ParseHeaderLine() :: Не найден правильный HTTP заголовок:" & vbCrLf & HttpPacket)

            Dim headerNumber = 0
            Dim strHeaders = HttpPacket.Substring(0, idxHeadersEnd)
            Me.PostData = HttpPacket.Substring(idxHeadersEnd + 4)

            Me.RemoteIP = DirectCast(HttpTcpClient.Client.RemoteEndPoint, IPEndPoint).Address.ToString()
            Me.RequestRaw = strHeaders
            Me.Headers = New Dictionary(Of String, String)
            Me.UrlParameters = New Dictionary(Of String, String)

            For Each xLine In strHeaders.Split(New String() {vbCrLf}, StringSplitOptions.None)
                If headerNumber = 0 Then 'Для первого заголовка с GET/POST

                    'Метод HTTP
                    Dim strFirstHeader() = Split(xLine, " "c)
                    Dim strQuery As String = String.Empty

                    Me.Method = strFirstHeader(0)
                    Me.OriginalUrl = strFirstHeader(1)

                    'Отделяем URL и GET параметры
                    Dim idxQueryStart = Me.OriginalUrl.IndexOf("?"c)

                    If idxQueryStart >= 0 Then
                        Me.Url = Me.OriginalUrl.Substring(0, idxQueryStart)
                        strQuery = Me.OriginalUrl.Substring(idxQueryStart + 1)
                    Else
                        Me.Url = Me.OriginalUrl
                    End If

                    'Добавляем параметры в коллекцию
                    Select Case Me.Method
                        Case "GET", "HEAD", "DELETE", "PUT"
                            If Not String.IsNullOrEmpty(strQuery) Then Me.UrlParameters = New UrlParameters(strQuery, True)

                        Case "POST"
                            ' Не готово [application/x-www-form-urlencoded + multipart/form + RAW]

                    End Select

                Else

                    'Для специальных заголовков
                    Dim kvp = ParseHeaderLine(xLine)

                    Select Case kvp.Key.ToLowerInvariant()
                        Case "host"
                            Me.Host = kvp.Value

                        Case "user-agent"
                            Me.UserAgent = kvp.Value

                        Case "cookie"
                            Me.Cookie = kvp.Value

                    End Select

                    'Для всех заголовков
                    Me.Headers.Add(kvp.Key, kvp.Value)
                End If

                headerNumber = +1
            Next
        End Sub

        ''' <summary>Внутренний метод для разделения строки на ключ и значение</summary>
        Private Shared Function ParseHeaderLine(TextLine As String) As KeyValuePair(Of String, String)
            TextLine = TextLine.TrimStart()

            Dim idxEqual = TextLine.IndexOf(":"c)
            If idxEqual = -1 Then Throw New Exception("MicroHTTP.ParseHeaderLine() > Получен неверный заголовок:" & vbCrLf & TextLine)

            Dim strKey = TextLine.Substring(0, idxEqual).TrimEnd()
            Dim strValue = TextLine.Substring(idxEqual + 1).TrimStart()

            Return New KeyValuePair(Of String, String)(strKey, strValue)
        End Function

    End Class

    ''' <summary>Класс предоставляет интерфейс для взаимодействия с клиентом и отправки ответов</summary>
    Public Class Response

        Private Shared ContentTypesList As New Dictionary(Of ContentTypes, String) From {
        {ContentTypes.TEXT_HTML, "text/html"},
        {ContentTypes.TEXT_HTML_UTF8, "text/html; charset=utf-8"},
        {ContentTypes.TEXT_PLAIN, "text/plain"},
        {ContentTypes.TEXT_PLAIN_UTF8, "text/plain; charset=utf-8"},
        {ContentTypes.TEXT_CSS, "text/css"},
        {ContentTypes.TEXT_JAVASCRIPT, "application/x-javascript"},
        {ContentTypes.IMAGE_PNG, "image/png"},
        {ContentTypes.IMAGE_JPEG, "image/jpeg"},
        {ContentTypes.IMAGE_GIF, "image/gif"},
        {ContentTypes.APP_OCTET_STREAM, "application/octet-stream"}
        }

        Private Shared HttpCodesList As New Dictionary(Of HttpCodes, String) From {
        {HttpCodes.OK, "OK"},
        {HttpCodes.MOVED_PERMANENTLY, "Moved Permanently"},
        {HttpCodes.FOUND, "Found"},
        {HttpCodes.BAD_REQUEST, "Bad Request"},
        {HttpCodes.FORBIDDEN, "Forbidden"},
        {HttpCodes.NOT_FOUND, "Not Found"},
        {HttpCodes.METHOD_NOT_ALLOWED, "Method Not Allowed"},
        {HttpCodes.SERVER_ERROR, "Server Error"},
        {HttpCodes.NOT_IMPELEMENTED, "Not Impelemented"},
        {HttpCodes.SERVICE_UNAVAILABLE, "Service Unavailable"}
        }

        Private sb As New StringBuilder

        ''' <summary>Свойство предоставляет доступ к ответу для клиента</summary>
        Public ReadOnly Property Content As String
            Get
                Return sb.ToString()
            End Get
        End Property

        ''' <summary>Свойство предоставляет возможность предопределить кодировку ответа.
        ''' Бинарные данные должны пересылаться в однобайтовой кодировке ASCII, а некоторые текстовые данные могут быть в UTF-8 или Unicode или ANSI
        ''' </summary>
        Public Property Encoding As Encoding = Encoding.UTF8

        ''' <summary>Очищает буфер ответа</summary>
        Public Function Clear() As Response
            sb.Clear()
            Return Me
        End Function

        ''' <summary>Добавляет значение в буфер ответа</summary>
        Public Function Write(ByVal Value As String) As Response
            sb.Append(Value)
            Return Me
        End Function

        Public Function Write(ByVal Value() As Byte) As Response
            sb.Append(Encoding.GetString(Value))
            Return Me
        End Function

        Public Function WriteFormat(ByVal FormatString As String, ParamArray Values() As Object) As Response
            sb.AppendFormat(FormatString, Values)
            Return Me
        End Function

        Public Function WriteLine(ByVal Value As String) As Response
            sb.AppendLine(Value)
            Return Me
        End Function

        Public Function WriteLine() As Response
            sb.AppendLine()
            Return Me
        End Function

        ''' <summary>Добавляет основные заголовки без заключительного переноса строки</summary>
        Public Function WriteHead(Code As HttpCodes, ContentType As ContentTypes) As Response
            sb.AppendFormat("HTTP/1.0 {0} {1}", CInt(Code), HttpCodesList(Code)).AppendLine()
            sb.AppendFormat("X-Powered-By: MicroHTTP").AppendLine()
            sb.AppendFormat("Content-Type: {0}", ContentTypesList(ContentType)).AppendLine()
            Return Me
        End Function

        ''' <summary>Добавляет основные заголовки без заключительного переноса строки</summary>
        Public Function WriteHead(Code As HttpCodes, ContentType As String) As Response
            sb.AppendFormat("HTTP/1.0 {0} {1}", CInt(Code), HttpCodesList(Code)).AppendLine()
            sb.AppendFormat("X-Powered-By: MicroHTTP").AppendLine()
            sb.AppendFormat("Content-Type: {0}", ContentType).AppendLine()
            Return Me
        End Function

        ''' <summary>Добавляет основные заголовки без заключительного переноса строки</summary>
        Public Function WriteHead(Code As Short, Description As String, ContentType As String) As Response
            sb.AppendFormat("HTTP/1.0 {0} {1}", CInt(Code), Description).AppendLine()
            sb.AppendFormat("X-Powered-By: MicroHTTP").AppendLine()
            sb.AppendFormat("Content-Type: {0}", ContentType).AppendLine()
            Return Me
        End Function

        ''' <summary>Метод возвращает контент тип на основе расширения файла</summary>
        Public Function ByFileExtension(ByVal strFileExtension As String) As ContentTypes
            Select Case strFileExtension.Replace(".", "").ToLowerInvariant()
                Case "jpg", "jpeg", "jpe"
                    Return ContentTypes.IMAGE_JPEG
                Case "gif"
                    Return ContentTypes.IMAGE_GIF
                Case "png"
                    Return ContentTypes.IMAGE_PNG
                Case "htm", "html"
                    Return ContentTypes.TEXT_HTML
                Case "txt", "csv"
                    Return ContentTypes.TEXT_PLAIN
                Case "js"
                    Return ContentTypes.TEXT_JAVASCRIPT
                Case "css"
                    Return ContentTypes.TEXT_CSS
                Case Else
                    Return ContentTypes.APP_OCTET_STREAM
            End Select
        End Function

        ''' <summary>Предопределенный метод для обработки запросов к статичным файлам</summary>
        Public Sub ProcessAsStaticFile(RootWebPath As String, RequestUrl As String)
            If Directory.Exists(RootWebPath) Then
                Dim filePath As String = Path.Combine(RootWebPath, RequestUrl.Replace("/", "\").Substring(1))

                If File.Exists(filePath) Then
                    Dim fi As FileInfo = New FileInfo(filePath)

                    Select Case Me.ByFileExtension(fi.Extension)
                        Case ContentTypes.TEXT_CSS, ContentTypes.TEXT_JAVASCRIPT, ContentTypes.TEXT_HTML, ContentTypes.TEXT_PLAIN
                            Me.Encoding = Text.Encoding.UTF8
                            Me.WriteHead(HttpCodes.OK, Me.ByFileExtension(fi.Extension)).WriteLine().
                            Write(File.ReadAllText(filePath, Text.Encoding.UTF8))

                        Case Else
                            Me.Encoding = Text.Encoding.GetEncoding(1251)
                            Me.WriteHead(HttpCodes.OK, Me.ByFileExtension(fi.Extension)).WriteLine().
                            Write(File.ReadAllText(filePath, Text.Encoding.GetEncoding(1251)))

                    End Select

                Else
                    Me.Encoding = Text.Encoding.UTF8
                    Me.WriteHead(HttpCodes.NOT_FOUND, "Content-type: text/html; charset=utf-8").WriteLine().
                    Write("<h1>Страница не найдена!</h1>")

                End If
            End If
        End Sub

        ''' <summary>Предопределенный метод для переадресации на другой Url</summary>
        Public Sub ProcessAsRedirect(UrlDestination As String)
            Me.WriteHead(HttpCodes.MOVED_PERMANENTLY, ContentTypes.TEXT_HTML).
            WriteFormat("Location: {0}", UrlDestination).WriteLine()
        End Sub

    End Class

    ''' <summary>Provides somewhat lenient URL encoding suited for Unicode Uris.</summary>
    Public Class UrlEncoding

        Shared ReadOnly urlEncStrings() As String = InitUrlStrings()

        Private Sub New()
        End Sub

        Private Shared Function InitUrlStrings() As String()
            Dim urlEncStrings As String() = New String(255) {}
            For i As Integer = 0 To 254
                urlEncStrings(i) = "%" & i.ToString("X2")
            Next
            Return urlEncStrings
        End Function

        ''' <summary>
        ''' Url encodes a string, but allow unicode characters to pass unencoded.
        ''' </summary>
        ''' <param name="value">The string to encode.</param>
        ''' <returns>The Url encoded string.</returns>
        Public Shared Function Encode(value As String) As String
            If value Is Nothing Then
                Return Nothing
            End If

            Dim ret As New StringBuilder(value.Length)

            For i As Integer = 0 To value.Length - 1
                Dim ch As Char = value(i)
                If ch = " "c Then
                    ret.Append("+"c)
                ElseIf Not IsSafe(ch) Then
                    ret.Append(urlEncStrings(AscW(ch)))
                Else
                    ret.Append(ch)
                End If
            Next

            Return ret.ToString()
        End Function

        ''' <summary>
        ''' Decodes a Url using System.Uri's Unescape method.
        ''' </summary>
        ''' <param name="value">The string to decode.</param>
        ''' <returns>The Url decoded string.</returns>
        Public Shared Function Decode(value As String) As String
            If value Is Nothing Then
                Return Nothing
            End If

            Return Uri.UnescapeDataString(value.Replace("+", "%20"))
        End Function

        Private Shared Function IsSafe(ch As Char) As Boolean
            If Char.IsLetterOrDigit(ch) Then
                Return True
            End If

            Select Case ch
                Case "'"c, "("c, ")"c, "["c, "]"c, "*"c, "-"c, "."c, "!"c, "_"c
                    Return True
            End Select

            If AscW(ch) > 255 Then Return True
            Return False
        End Function

    End Class

    ''' <summary>
    ''' Represents a URI query parsed in name/value pairs.
    ''' </summary>
    Public Class UrlParameters
        Inherits Dictionary(Of String, String)

        ''' <summary>
        ''' Parse a query from a given Uri.
        ''' </summary>
        ''' <param name="uri">The URI to parse from</param>
        Public Sub New(uri As Uri)
            Me.New(uri.Query.TrimStart("?"c), True)
        End Sub

        ''' <summary>
        ''' Parse a query from a URL encoded query string.
        ''' </summary>
        ''' <param name="query">The query string to parse from.</param>
        Public Sub New(query As String)
            Me.New(query, True)
        End Sub

        ''' <summary>
        ''' Parse a query from a given string.
        ''' </summary>
        ''' <param name="Query">The query string to parse from.</param>
        ''' <param name="UrlEncoded">A value indicating whether the string is URL encoded or not.</param>
        Public Sub New(Query As String, UrlEncoded As Boolean)
            For i As Integer = 0 To Query.Length - 1
                Dim start As Integer = i
                Dim equalIndex As Integer = -1
                While i < Query.Length
                    If Query(i) = "="c Then
                        If equalIndex < 0 Then
                            equalIndex = i
                        End If
                    ElseIf Query(i) = "&"c Then
                        Exit While
                    End If
                    i += 1
                End While

                Dim name As String
                Dim value As String

                If equalIndex < 0 Then
                    name = Query.Substring(start, i - start)
                    value = String.Empty
                Else
                    name = Query.Substring(start, equalIndex - start)
                    value = Query.Substring(equalIndex + 1, (i - equalIndex) - 1)
                End If

                If UrlEncoded Then
                    Me.Add(UrlEncoding.Decode(name), UrlEncoding.Decode(value))
                Else
                    Me.Add(name, value)
                End If

                If i = Query.Length - 1 AndAlso Query(i) = "&"c Then
                    Me.Add(Nothing, String.Empty)
                End If
            Next
        End Sub

    End Class

End Namespace