Imports System
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports System.Threading
Imports System.IO
Imports System.IO.File
Imports System.Web
Imports System.Web.HttpUtility
Imports System.Data.OleDb

Public Class Form1
    Inherits System.Windows.Forms.Form
    Private MREventAccept As New ManualResetEvent(False)
    Private AcceptThread As Thread
    Private ReceiveThread(0) As Thread
    Private ClientAccesses As ArrayList
    Private FSocketHandler As New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
    Private MREventReceiveList As ArrayList
    Private MREventReceive As New ManualResetEvent(False)
    Private MREventUser As New ManualResetEvent(False)
    Private WaitFlg As New WaitFlgObject()

    Private AcceptCount As Integer = 0
    Private ThreadNumber As Integer
    Private ThreadUserCount(0) As Integer '各スレッドのユーザー数を格納
    Private Thread_ClientAccesses(0) As Integer 'ユーザーがどのスレッドか、スレッド番号を格納する
    Private Time_ClientAccesses(0) As DateTime

    Private XMLFileName As String = "config.xml"
    Private DispDataBuf As String
    Private PortNumber As Integer
    Private ServiceDir As String
    Private CPARAM As String = vbCrLf
    Private CloseFlg As Boolean = False
    Private ConCloseFlg As Boolean = False
    Private Mut As Mutex

    'Webサーバー設定マネージャー用
    Private ListenThread As Thread
    Private TcpCli As TcpClient
    Private Tlistener As TcpListener
    Private Continue As Boolean
    Private ConPortNumber As Integer = 8777 'web_server_managerからの接続用
    Private ServerStatus As Integer '0:停止 1:開始

    Private SocketListener As Socket
    Private cntss As Integer = 0
    Private ParamTimeOut As Integer '秒以上アクセスがない場合は切断されたとみなす

    Private GCookie_Header As String
    Private GURLString As String
    Private GRecBuff As String
#Region " Windows フォーム デザイナで生成されたコード "

    Public Sub New()
        MyBase.New()

        ' この呼び出しは Windows フォーム デザイナで必要です。
        InitializeComponent()

        ' InitializeComponent() 呼び出しの後に初期化を追加します。

    End Sub

    ' Form は dispose をオーバーライドしてコンポーネント一覧を消去します。
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    ' Windows フォーム デザイナで必要です。
    Private components As System.ComponentModel.IContainer

    ' メモ : 以下のプロシージャは、Windows フォーム デザイナで必要です。
    ' Windows フォーム デザイナを使って変更してください。  
    ' コード エディタは使用しないでください。
    Friend WithEvents LabelS As System.Windows.Forms.Label
    Friend WithEvents btnStart As System.Windows.Forms.Button
    Friend WithEvents btnClear As System.Windows.Forms.Button
    Friend WithEvents txtInfo As System.Windows.Forms.TextBox
    Friend WithEvents LinkLabel1 As System.Windows.Forms.LinkLabel
    Friend WithEvents LinkLabel2 As System.Windows.Forms.LinkLabel
    Friend WithEvents NotifyIcon1 As System.Windows.Forms.NotifyIcon
    Friend WithEvents MainMenu1 As System.Windows.Forms.MainMenu
    Friend WithEvents MenuItem1 As System.Windows.Forms.MenuItem
    Friend WithEvents MenuItem2 As System.Windows.Forms.MenuItem
    Friend WithEvents ContextMenu1 As System.Windows.Forms.ContextMenu
    Friend WithEvents MenuItem3 As System.Windows.Forms.MenuItem
    Friend WithEvents Timer1 As System.Windows.Forms.Timer
    Friend WithEvents txtThread As System.Windows.Forms.TextBox
    Friend WithEvents Label1 As System.Windows.Forms.Label
    Friend WithEvents txtTime As System.Windows.Forms.TextBox
    Friend WithEvents Label2 As System.Windows.Forms.Label
    Friend WithEvents txtInterval As System.Windows.Forms.TextBox
    Friend WithEvents btnStop As System.Windows.Forms.Button
    Friend WithEvents Label3 As System.Windows.Forms.Label
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
        Me.components = New System.ComponentModel.Container()
        Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(Form1))
        Me.btnStart = New System.Windows.Forms.Button()
        Me.LabelS = New System.Windows.Forms.Label()
        Me.txtThread = New System.Windows.Forms.TextBox()
        Me.txtInfo = New System.Windows.Forms.TextBox()
        Me.btnClear = New System.Windows.Forms.Button()
        Me.LinkLabel1 = New System.Windows.Forms.LinkLabel()
        Me.LinkLabel2 = New System.Windows.Forms.LinkLabel()
        Me.NotifyIcon1 = New System.Windows.Forms.NotifyIcon(Me.components)
        Me.MainMenu1 = New System.Windows.Forms.MainMenu()
        Me.MenuItem1 = New System.Windows.Forms.MenuItem()
        Me.MenuItem2 = New System.Windows.Forms.MenuItem()
        Me.MenuItem3 = New System.Windows.Forms.MenuItem()
        Me.ContextMenu1 = New System.Windows.Forms.ContextMenu()
        Me.Timer1 = New System.Windows.Forms.Timer(Me.components)
        Me.Label1 = New System.Windows.Forms.Label()
        Me.txtTime = New System.Windows.Forms.TextBox()
        Me.Label2 = New System.Windows.Forms.Label()
        Me.txtInterval = New System.Windows.Forms.TextBox()
        Me.btnStop = New System.Windows.Forms.Button()
        Me.Label3 = New System.Windows.Forms.Label()
        Me.SuspendLayout()
        '
        'btnStart
        '
        Me.btnStart.Name = "btnStart"
        Me.btnStart.Size = New System.Drawing.Size(48, 24)
        Me.btnStart.TabIndex = 0
        Me.btnStart.Text = "開始"
        '
        'LabelS
        '
        Me.LabelS.Location = New System.Drawing.Point(192, 0)
        Me.LabelS.Name = "LabelS"
        Me.LabelS.Size = New System.Drawing.Size(56, 16)
        Me.LabelS.TabIndex = 4
        Me.LabelS.Text = "スレッド数"
        '
        'txtThread
        '
        Me.txtThread.Location = New System.Drawing.Point(248, 0)
        Me.txtThread.Name = "txtThread"
        Me.txtThread.Size = New System.Drawing.Size(24, 19)
        Me.txtThread.TabIndex = 2
        Me.txtThread.Text = "3"
        Me.txtThread.TextAlign = System.Windows.Forms.HorizontalAlignment.Right
        '
        'txtInfo
        '
        Me.txtInfo.Location = New System.Drawing.Point(8, 32)
        Me.txtInfo.Multiline = True
        Me.txtInfo.Name = "txtInfo"
        Me.txtInfo.ScrollBars = System.Windows.Forms.ScrollBars.Both
        Me.txtInfo.Size = New System.Drawing.Size(264, 152)
        Me.txtInfo.TabIndex = 5
        Me.txtInfo.Text = ""
        '
        'btnClear
        '
        Me.btnClear.Location = New System.Drawing.Point(200, 192)
        Me.btnClear.Name = "btnClear"
        Me.btnClear.Size = New System.Drawing.Size(72, 24)
        Me.btnClear.TabIndex = 6
        Me.btnClear.Text = "表示のクリア"
        '
        'LinkLabel1
        '
        Me.LinkLabel1.Location = New System.Drawing.Point(32, 304)
        Me.LinkLabel1.Name = "LinkLabel1"
        Me.LinkLabel1.Size = New System.Drawing.Size(176, 16)
        Me.LinkLabel1.TabIndex = 7
        Me.LinkLabel1.TabStop = True
        Me.LinkLabel1.Text = "サンプルWebアプリケーションの実行"
        '
        'LinkLabel2
        '
        Me.LinkLabel2.Location = New System.Drawing.Point(32, 320)
        Me.LinkLabel2.Name = "LinkLabel2"
        Me.LinkLabel2.Size = New System.Drawing.Size(224, 16)
        Me.LinkLabel2.TabIndex = 8
        Me.LinkLabel2.TabStop = True
        Me.LinkLabel2.Text = "サンプル cookie Webアプリケーションの実行"
        '
        'NotifyIcon1
        '
        Me.NotifyIcon1.Icon = CType(resources.GetObject("NotifyIcon1.Icon"), System.Drawing.Icon)
        Me.NotifyIcon1.Text = "Webサーバー"
        Me.NotifyIcon1.Visible = True
        '
        'MainMenu1
        '
        Me.MainMenu1.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.MenuItem1})
        '
        'MenuItem1
        '
        Me.MenuItem1.Index = 0
        Me.MenuItem1.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.MenuItem2, Me.MenuItem3})
        Me.MenuItem1.Text = "ファイル(&F)"
        '
        'MenuItem2
        '
        Me.MenuItem2.Index = 0
        Me.MenuItem2.Text = "Webサーバーの終了(&X)"
        '
        'MenuItem3
        '
        Me.MenuItem3.Index = 1
        Me.MenuItem3.Text = "Webサーバーの終了(&X)"
        '
        'Timer1
        '
        Me.Timer1.Interval = 120000
        '
        'Label1
        '
        Me.Label1.Location = New System.Drawing.Point(56, 248)
        Me.Label1.Name = "Label1"
        Me.Label1.Size = New System.Drawing.Size(216, 24)
        Me.Label1.TabIndex = 10
        Me.Label1.Text = "秒以上アクセスがない場合は切断されたとみなす"
        '
        'txtTime
        '
        Me.txtTime.Location = New System.Drawing.Point(8, 248)
        Me.txtTime.Name = "txtTime"
        Me.txtTime.Size = New System.Drawing.Size(40, 19)
        Me.txtTime.TabIndex = 3
        Me.txtTime.Text = "60"
        Me.txtTime.TextAlign = System.Windows.Forms.HorizontalAlignment.Right
        '
        'Label2
        '
        Me.Label2.Location = New System.Drawing.Point(56, 288)
        Me.Label2.Name = "Label2"
        Me.Label2.Size = New System.Drawing.Size(120, 16)
        Me.Label2.TabIndex = 12
        Me.Label2.Text = "秒おきに切断を確認"
        '
        'txtInterval
        '
        Me.txtInterval.Location = New System.Drawing.Point(8, 280)
        Me.txtInterval.Name = "txtInterval"
        Me.txtInterval.Size = New System.Drawing.Size(40, 19)
        Me.txtInterval.TabIndex = 4
        Me.txtInterval.Text = "120"
        Me.txtInterval.TextAlign = System.Windows.Forms.HorizontalAlignment.Right
        '
        'btnStop
        '
        Me.btnStop.Enabled = False
        Me.btnStop.Location = New System.Drawing.Point(48, 0)
        Me.btnStop.Name = "btnStop"
        Me.btnStop.Size = New System.Drawing.Size(48, 24)
        Me.btnStop.TabIndex = 1
        Me.btnStop.Text = "停止"
        '
        'Label3
        '
        Me.Label3.Location = New System.Drawing.Point(8, 224)
        Me.Label3.Name = "Label3"
        Me.Label3.TabIndex = 13
        Me.Label3.Text = "Keep-Alive設定"
        '
        'Form1
        '
        Me.AutoScaleBaseSize = New System.Drawing.Size(5, 12)
        Me.ClientSize = New System.Drawing.Size(280, 337)
        Me.Controls.AddRange(New System.Windows.Forms.Control() {Me.Label3, Me.txtThread, Me.btnStop, Me.Label2, Me.txtInterval, Me.Label1, Me.txtTime, Me.LinkLabel2, Me.LinkLabel1, Me.btnClear, Me.txtInfo, Me.LabelS, Me.btnStart})
        Me.MaximizeBox = False
        Me.Menu = Me.MainMenu1
        Me.Name = "Form1"
        Me.Text = "Async WebServer"
        Me.ResumeLayout(False)

    End Sub

#End Region
    Private Delegate Sub AsyncServerDelegate() '*** Form1のテキストボックスに表示するため

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Mut = New Mutex(False, "web_server")
        If Mut.WaitOne(0, False) = False Then
            MessageBox.Show("Webサーバーはすでに起動しています", "Webサーバー", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
            Application.Exit()
        Else
            OnManagerStart()
        End If
        ContextMenu1.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {MenuItem3})
        NotifyIcon1.ContextMenu = ContextMenu1
    End Sub
    Private Sub Form1_Closing(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing
        If Not CloseFlg Then
            MessageBox.Show("タスクトレイに格納されます。" & vbCrLf & "Webサーバーを終了するには「ファイル」メニューの「Webサーバーの終了」を選択してください。", "Webサーバー", MessageBoxButtons.OK, MessageBoxIcon.Information)
            e.Cancel = True
            Me.Hide()
        Else
            If ServerStatus = 1 Then
                OnSStop()
            End If
            OnManagerStop()
            Mut.Close()
        End If
    End Sub
    Private Sub btnStart_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStart.Click
        OnSStart()
        btnStart.Enabled = False
    End Sub
    Private Sub btnStop_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnStop.Click
        OnSStop()
        btnStop.Enabled = False
    End Sub

    '---------------------------------------
    ' Webサーバー開始処理
    '---------------------------------------
    Private Sub OnSStart()
        ThreadNumber = Val(txtThread.Text)
        ParamTimeOut = Val(txtTime.Text)
        Timer1.Interval = Val(txtInterval.Text) * 1000

        MREventReceiveList = New ArrayList()
        Dim i As Integer
        '指定された数だけスレッドを起動
        For i = 0 To ThreadNumber - 1
            MREventReceiveList.Add(MREventReceive)
            ReDim Preserve ReceiveThread(i + 1)
            ReDim Preserve ThreadUserCount(i + 1)
            ThreadUserCount(i) = 0
            ReceiveThread(i) = New Thread(AddressOf Receive)
            ReceiveThread(i).Start()
        Next

        PortNumber = CInt(GetXmlValue("portnumber"))
        ServiceDir = GetXmlValue("dir")

        txtThread.Enabled = False
        txtTime.Enabled = False
        txtInterval.Enabled = False
        btnStart.Enabled = False
        Timer1.Enabled = True
        btnStop.Enabled = True

        AcceptThread = New Thread(AddressOf Accept)
        AcceptThread.Start()
    End Sub
    '---------------------------------------
    ' Webサーバー終了処理
    '---------------------------------------
    Private Sub OnSStop()

        AcceptThread.Abort()
        Dim i As Integer
        For i = 0 To ThreadNumber - 1
            ReceiveThread(i).Abort()
        Next
        LinkLabel1.Links.Clear()
        LinkLabel2.Links.Clear()
        ServerStatus = 0

        txtThread.Enabled = True
        txtTime.Enabled = True
        txtInterval.Enabled = True
        btnStart.Enabled = True
        Timer1.Enabled = False
    End Sub

    '---------------------------------------
    ' Accept
    '---------------------------------------
    Private Sub Accept()
        Dim strHostName As String = Dns.GetHostName()
        Dim ipHostInfo As IPHostEntry = Dns.Resolve(strHostName)
        Dim ipAddress As IPAddress = ipHostInfo.AddressList(0)
        Dim localEndPoint As New IPEndPoint(ipAddress, PortNumber)

        ClientAccesses = New ArrayList()

        cntss = cntss + 1
        If cntss = 1 Then
            SocketListener = New Socket(AddressFamily.InterNetwork, SocketType.Stream, ProtocolType.Tcp)
            Try
                SocketListener.Bind(localEndPoint)
                SocketListener.Listen(100)
            Catch ex As Exception
                DispDataBuf = ex.ToString & CPARAM
                Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
                ServerStatus = 1
                LinkLabel1.Links.Clear()
                LinkLabel2.Links.Clear()
                MessageBox.Show("指定されたポート[ " & CStr(PortNumber) & " ]を使用できませんでした。" & vbCrLf & "「ファイル」メニューの「Webサーバーの終了」を選択してWebサーバーをシャットダウンし、再起動してください。", "Webサーバー", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
                Exit Sub
            End Try
        End If

        DispDataBuf = "ポート番号:" & CStr(PortNumber) & CPARAM & "Webフォルダ:" & ServiceDir & CPARAM & "で起動しました。" & CPARAM
        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
        LinkLabel1.Links.Add(0, 18, "http://" & strHostName & ":" & CStr(PortNumber) & "/webapp.shtml")
        LinkLabel2.Links.Add(0, 26, "http://" & strHostName & ":" & CStr(PortNumber) & "/webapp3.shtml")
        ServerStatus = 1
        While True
            MREventAccept.Reset()
            SocketListener.BeginAccept(New AsyncCallback(AddressOf CallbackAccept), SocketListener)
            MREventAccept.WaitOne()
        End While

    End Sub
    Private Sub CallbackAccept(ByVal ar As IAsyncResult)
        Dim intMREvent As Integer
        AcceptCount = AcceptCount + 1
        intMREvent = AcceptCount Mod ThreadNumber

        MREventUser.Reset()
        SyncLock WaitFlg
            If WaitFlg.Flg = 1 Then
                MREventUser.WaitOne()
            End If
            WaitFlg.Flg = 1
        End SyncLock

        Dim SocketHandler As Socket = ar.AsyncState.EndAccept(ar)
        MREventAccept.Set()
        ClientAccesses.Add(SocketHandler)

        FSocketHandler = SocketHandler

        'ユーザー数の少ないスレッドを探す
        Dim i As Integer
        Dim num As Integer
        Dim MinThreadNo As Integer
        num = ThreadUserCount(0)
        MinThreadNo = 0
        For i = 1 To ThreadNumber - 1
            If num > ThreadUserCount(i) Then
                num = ThreadUserCount(i)
                MinThreadNo = i
            End If
        Next
        intMREvent = MinThreadNo
        ReDim Preserve Thread_ClientAccesses(ClientAccesses.Count)
        Thread_ClientAccesses(ClientAccesses.Count) = intMREvent
        ThreadUserCount(intMREvent) = ThreadUserCount(intMREvent) + 1
        ReDim Preserve Time_ClientAccesses(ClientAccesses.Count)
        Time_ClientAccesses(ClientAccesses.Count) = DateTime.Now

        MREventReceive = MREventReceiveList(intMREvent)
        MREventReceive.Set()

    End Sub

    '---------------------------------------
    ' Receive
    '---------------------------------------
    Private Sub Receive()
        MREventReceive = MREventReceiveList(MREventReceiveList.Count - 1)
        While True
            MREventReceive.WaitOne()
            Dim state As New StateObject()
            state.workSocket = FSocketHandler
            FSocketHandler.BeginReceive(state.buffer, 0, 1024, 0, New AsyncCallback(AddressOf CallbackReceive), state)
            MREventReceive.Reset()

            WaitFlg.Flg = 0
            MREventUser.Set()
        End While

    End Sub
    Private Sub CallbackReceive(ByVal ar As IAsyncResult)
        Dim state As StateObject = CType(ar.AsyncState, StateObject)
        Dim SocketHandler As Socket = state.workSocket
        Dim bytesRead As Integer
        Try
            bytesRead = SocketHandler.EndReceive(ar)
        Catch
        End Try

        Dim strindex As String
        If bytesRead > 0 Then
            state.sb.Append(Encoding.Default.GetString(state.buffer, 0, bytesRead))
            strindex = InStr(state.sb.ToString, vbCrLf & vbCrLf)
            If strindex > 0 Then
                Send(SocketHandler, state.sb.ToString(), ClientAccesses)
                state.sb.Remove(0, state.sb.Length)
            Else
                SocketHandler.BeginReceive(state.buffer, 0, 1024, 0, New AsyncCallback(AddressOf CallbackReceive), state)
            End If
        End If
    End Sub

    '---------------------------------------
    ' Send
    '---------------------------------------
    Private Sub Send(ByVal SocketHandler As Socket, ByVal data As String, ByVal ClientAcc As ArrayList)
        Dim byteData As Byte() = GetSendData(data)
        SocketHandler.BeginSend(byteData, 0, byteData.Length, 0, New AsyncCallback(AddressOf CallbackSend), SocketHandler)

    End Sub
    Private Sub CallbackSend(ByVal ar As IAsyncResult)
        Dim SocClient As Socket = CType(ar.AsyncState, Socket)
        Dim bytesSent As Integer = SocClient.EndSend(ar)
        Dim i, j As Integer
        Dim SocIndex As Integer = -1
        For i = 0 To ClientAccesses.Count - 1
            If ClientAccesses(i) Is SocClient Then
                SocIndex = i
                Exit For
            End If
        Next
        'HTTPヘッダーのconnectionがclose の場合
        If ConCloseFlg Then
            ThreadUserCount(Thread_ClientAccesses(SocIndex + 1)) = ThreadUserCount(Thread_ClientAccesses(SocIndex + 1)) - 1
            For j = SocIndex + 1 To ClientAccesses.Count - 1
                Thread_ClientAccesses(j) = Thread_ClientAccesses(j + 1)
                Time_ClientAccesses(j) = Time_ClientAccesses(j + 1)
            Next
            ClientAccesses.RemoveAt(SocIndex)

            '切断
            SocClient.Shutdown(SocketShutdown.Both)
            SocClient.Close()
        Else
            Time_ClientAccesses(SocIndex + 1) = Now
        End If
    End Sub

    '---------------------------------------
    ' クライアントへ送信するデータを作成する
    '---------------------------------------
    Private Function GetSendData(ByVal strBuf As String) As Byte()
        Dim strSendData As String
        Dim sParam As String
        Dim nPos As Integer
        Dim nPosQ As Integer
        Dim sFile As String
        Dim sType As String
        Dim streaderFile As StreamReader
        Dim binReaderFile As BinaryReader
        ConCloseFlg = False
        GRecBuff = strBuf & CPARAM
        GCookie_Header = ""

        DispDataBuf = "---Webブラウザから受信した要求---" & CPARAM & strBuf
        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

        sParam = UCase(Mid(strBuf, 1, InStr(strBuf, " ") - 1))
        If sParam = "GET" Or sParam = "POST" Then

            If InStr(LCase(strBuf), "connection: close") > 0 Then
                ConCloseFlg = True
            End If

            nPos = InStr(strBuf, "/")
            sFile = Mid(strBuf, nPos + 1, InStr(nPos, strBuf, " ") - nPos - 1)

            '*** URLStringの場合ファイル名を取り出す
            nPosQ = InStr(sFile, "?")
            GURLString = ""
            If nPosQ > 0 Then
                GURLString = Mid(sFile, nPosQ + 1)
                sFile = Mid(sFile, 1, nPosQ - 1)
            End If
            '***

            sType = LCase(Mid(sFile, InStr(1, sFile, ".") + 1))

            If Mid(Trim(ServiceDir), ServiceDir.Length - 1, 1) <> "\" Then
                ServiceDir = Trim(ServiceDir) & "\"
            End If
            If sType = "htm" Or sType = "html" Or sType = "shtml" Or sType = "asp" Or sType = "aspx" Or sType = "txt" Or sType = "ini" Then
                Try
                    streaderFile = New StreamReader(Trim(ServiceDir) & sFile, Encoding.Default)
                    strSendData = streaderFile.ReadToEnd
                    streaderFile.Close()
                Catch ex As Exception
                    DispDataBuf = ex.ToString & CPARAM
                    Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
                    strSendData = "HTTP/1.1 200 OK" & CPARAM & CPARAM & ex.ToString
                    GetSendData = Encoding.Default.GetBytes(strSendData)
                    Exit Function
                End Try

                If sType = "shtml" Or sType = "asp" Or sType = "aspx" Then
                    strSendData = WebAppExec(strSendData)
                End If

                strSendData = Add_Header(strSendData, Trim(ServiceDir) & sFile)

                GetSendData = Encoding.Default.GetBytes(strSendData)
                DispDataBuf = "---Webブラウザへの応答---" & CPARAM & strSendData
                Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

            Else '    "gif", "jpg", "jpeg"
                Try
                    binReaderFile = New BinaryReader(File.Open(Trim(ServiceDir) & sFile, FileMode.Open))
                    GetSendData = binReaderFile.ReadBytes(FileLen(Trim(ServiceDir) & sFile))
                    binReaderFile.Close()
                Catch ex As Exception
                    DispDataBuf = ex.ToString & CPARAM
                    Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
                    strSendData = "HTTP/1.1 200 OK" & CPARAM & "Connection: close" & CPARAM & CPARAM & ex.ToString
                    GetSendData = Encoding.Default.GetBytes(strSendData)
                    Exit Function
                End Try
            End If
        End If
        GRecBuff = ""
    End Function
    Private Function Add_Header(ByVal strData As String, ByVal strFilePath As String) As String
        Dim strHeader As String
        '*** ファイルの内容の前にヘッダー情報を付加 ***
        strHeader = "HTTP/1.1 200 OK" & CPARAM & "Server: .NET Web Server" & CPARAM
        strHeader = strHeader & "Date: " & Format(Now, "R") & CPARAM
        strHeader = strHeader & "Last-Modified: " & Format(GetLastWriteTime(strFilePath), "R") & CPARAM
        strHeader = strHeader & "Content-Length: " & FileLen(strFilePath) & CPARAM
        If ConCloseFlg Then
            strHeader = strHeader & "Connection: close " & CPARAM
        End If
        strHeader = strHeader & "Content-Type: text/html; charset=shift_jis" & CPARAM
        If GCookie_Header <> "" Then
            strHeader = strHeader & "Set-Cookie: " & GCookie_Header & CPARAM
        End If
        strHeader = strHeader & CPARAM
        Add_Header = strHeader & strData
    End Function

    Private Sub DispReceiveData()
        '*** Form1のテキストボックスに表示する ***
        Me.txtInfo.Text = CPARAM & DispDataBuf & CPARAM & Me.txtInfo.Text
    End Sub

    Public Function GetPathName() As String
        Dim fPathName As String
        Dim LenPath As Integer
        fPathName = System.Reflection.Assembly.GetExecutingAssembly.Location()
        LenPath = Len(fPathName) - 15 '15:AsyncServer.exeの文字数
        fPathName = Microsoft.VisualBasic.Left(fPathName, LenPath)
        GetPathName = fPathName
    End Function
    Public Function GetConnStr() As String
        '*** Connection.ConnectionString ***
        GetConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetPathName() & "Northwind.mdb"
    End Function

    '---------------------------------------
    ' XMLファイル操作
    '---------------------------------------
    Private Function GetXmlValue(ByVal sTagName As String) As String
        Dim xmlDoc As New Xml.XmlDocument()
        xmlDoc.Load(XMLFileName)
        Dim xmlNList As Xml.XmlNodeList = xmlDoc.GetElementsByTagName(sTagName)
        GetXmlValue = ""
        If xmlNList.Count > 0 Then
            If Not (xmlNList(0).FirstChild Is Nothing) Then
                GetXmlValue = xmlNList(0).FirstChild.Value
            End If
        End If
        If GetXmlValue = "" Then
            Select Case sTagName
                Case "portnumber"
                    GetXmlValue = "11000"
                Case "dir"
                    GetXmlValue = GetPathName()
            End Select
        End If
    End Function
    Private Function GetXml(ByVal sXMLString As String, ByVal sTagName As String) As String
        Dim xmlDoc As New Xml.XmlDocument()
        xmlDoc.LoadXml(sXMLString)
        Dim xmlNList As Xml.XmlNodeList = xmlDoc.GetElementsByTagName(sTagName)
        GetXml = ""
        If xmlNList.Count > 0 Then
            If Not (xmlNList(0).FirstChild Is Nothing) Then
                GetXml = xmlNList(0).FirstChild.Value
            End If
        End If
    End Function
    Private Sub WriteXML(ByVal sTagName As String, ByVal sTagValue As String)
        Dim xmlDoc As Xml.XmlDocument
        Dim xmlChd As Xml.XmlElement
        Dim xmlTxt As Xml.XmlText
        If sTagName = "" Or sTagValue = "" Then Exit Sub

        '*** xmlファイルに書き込み
        xmlDoc = New Xml.XmlDocument()
        xmlDoc.Load(XMLFileName)
        Dim xmlNList As Xml.XmlNodeList = xmlDoc.GetElementsByTagName(sTagName)
        If xmlNList.Count > 0 Then
            xmlChd = xmlNList(0)
            xmlTxt = xmlDoc.CreateTextNode(sTagValue)
            xmlChd.RemoveAll()
            xmlChd.AppendChild(xmlTxt)
        Else
            xmlChd = xmlDoc.CreateElement(sTagName)
            xmlTxt = xmlDoc.CreateTextNode(sTagValue)
            xmlChd.AppendChild(xmlTxt)
            Dim xmlDocEle As Xml.XmlElement = xmlDoc.DocumentElement
            xmlDocEle.AppendChild(xmlChd)
        End If
        xmlDoc.Save(XMLFileName)
    End Sub

    '---------------------------------------
    ' Webサーバー設定マネージャーとの送受信用
    '---------------------------------------
    Private Sub OnManagerStart()
        Continue = True

        Tlistener = New TcpListener(ConPortNumber)
        ListenThread = New Thread(AddressOf ListenerStart)
        ListenThread.Start()

    End Sub
    Private Sub OnManagerStop()
        Dim tcpc As New TcpClient()
        Continue = False
        tcpc.Connect("localhost", ConPortNumber)
        tcpc.Close()
        Tlistener.Stop()
        If IsReference(TcpCli) Then
            Try
                TcpCli.Close()
            Catch
            End Try
        End If
        ListenThread.Abort()
    End Sub
    Private Sub ListenerStart()
        Dim ClientThread As Thread
        Dim i As Integer
        Tlistener.Start()
        Do While True
            TcpCli = Tlistener.AcceptTcpClient()
            If Continue = False Then Exit Do
            DataReadWrite(TcpCli)
        Loop
    End Sub
    Private Sub DataReadWrite(ByVal CliSock As TcpClient)
        Dim nStream As NetworkStream
        Dim sendBytes As [Byte]()
        Dim sType As String
        Dim sMethod As String
        Dim sFile As String
        Dim nPos As Integer
        Dim nPos2 As Integer
        Dim xmlDoc As Xml.XmlDocument
        Dim xmlChd As Xml.XmlElement
        Dim xmlTxt As Xml.XmlText
        Dim strBuf As String

        nStream = CliSock.GetStream()

        Try
            Dim ByteData(CliSock.ReceiveBufferSize) As Byte
            nStream.Read(ByteData, 0, CInt(CliSock.ReceiveBufferSize))
            strBuf = Encoding.Default.GetString(ByteData)

            sMethod = UCase(Mid(strBuf, 1, InStr(strBuf, " ") - 1))
            If sMethod = "SYSTEM_MESSAGE" Then
                DispDataBuf = CPARAM & "---受信した要求---" & CPARAM & strBuf
                Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

                nPos = InStr(strBuf, "/")
                sFile = Mid(strBuf, nPos + 1, InStr(nPos + 1, strBuf, "/") - nPos - 1)
                Select Case LCase(sFile)
                    Case "send"
                        nPos2 = InStr(nPos + 1, strBuf, "/")
                        sFile = Mid(strBuf, nPos2 + 1)

                        '*** xmlファイルに書き込み ***
                        WriteXML("portnumber", CInt(GetXml(sFile, "portnumber")))
                        WriteXML("dir", GetXml(sFile, "dir"))

                        sendBytes = Encoding.Default.GetBytes("XMLファイルを更新しました。")
                        nStream.Write(sendBytes, 0, sendBytes.Length)
                        DispDataBuf = CPARAM & "---応答---" & CPARAM & "XMLファイルを更新しました。"
                        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

                    Case "getinfo"
                        sFile = "<?xml version=""1.0""?>" & "<webserver>"
                        sFile = sFile & "<portnumber>" & CStr(PortNumber) & "</portnumber>"
                        sFile = sFile & "<dir>" & ServiceDir & "</dir>"
                        sFile = sFile & "<status>" & CStr(ServerStatus) & "</status>"
                        sFile = sFile & "</webserver>"

                        sendBytes = Encoding.Default.GetBytes(sFile)
                        nStream.Write(sendBytes, 0, sendBytes.Length)
                        DispDataBuf = CPARAM & "---応答---" & CPARAM & sFile
                        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

                    Case "start"
                        If ServerStatus = 0 Then
                            OnSStart()
                            sFile = "開始しました"
                        Else
                            sFile = "開始しています"
                        End If
                        sendBytes = Encoding.Default.GetBytes(sFile)
                        nStream.Write(sendBytes, 0, sendBytes.Length)
                        DispDataBuf = CPARAM & "---応答---" & CPARAM & sFile
                        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため

                    Case "stop"
                        If ServerStatus = 1 Then
                            OnSStop()
                            sFile = "停止しました"
                        Else
                            sFile = "停止しています"
                        End If
                        sendBytes = Encoding.Default.GetBytes(sFile)
                        nStream.Write(sendBytes, 0, sendBytes.Length)
                        DispDataBuf = CPARAM & "---応答---" & CPARAM & sFile
                        Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
                End Select
            End If
        Catch ex As Exception
            DispDataBuf = CPARAM & ex.ToString()
            Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData)) '*** Form1のテキストボックスに表示するため
        End Try
        nStream.Close()
        CliSock.Close()
    End Sub

    '---------------------------------------
    ' Form1のコントロールのイベント
    '---------------------------------------
    Private Sub btnClear_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnClear.Click
        txtInfo.Text = ""
    End Sub
    Private Sub LinkLabel1_LinkClicked(ByVal sender As System.Object, ByVal e As System.Windows.Forms.LinkLabelLinkClickedEventArgs) Handles LinkLabel1.LinkClicked
        LinkLabel1.Links(LinkLabel1.Links.IndexOf(e.Link)).Visited = True
        Dim target As String = CType(e.Link.LinkData, String)
        If Nothing <> target Then
            System.Diagnostics.Process.Start(target)
        Else
            MsgBox("Web Serverの開始ボタンをクリックしてください。")
        End If
    End Sub
    Private Sub LinkLabel2_LinkClicked(ByVal sender As System.Object, ByVal e As System.Windows.Forms.LinkLabelLinkClickedEventArgs) Handles LinkLabel2.LinkClicked
        LinkLabel2.Links(LinkLabel2.Links.IndexOf(e.Link)).Visited = True
        Dim target As String = CType(e.Link.LinkData, String)
        If Nothing <> target Then
            System.Diagnostics.Process.Start(target)
        Else
            MsgBox("Web Serverの開始ボタンをクリックしてください。")
        End If
    End Sub
    Private Sub NotifyIcon1_DoubleClick(ByVal sender As Object, ByVal e As System.EventArgs) Handles NotifyIcon1.DoubleClick
        If (Me.WindowState = FormWindowState.Minimized) Then _
            Me.WindowState = FormWindowState.Normal
        Me.Show()
        Me.Activate()
    End Sub
    Private Sub MenuItem2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MenuItem2.Click
        CloseFlg = True
        Me.Close()
    End Sub
    Private Sub MenuItem3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MenuItem3.Click
        CloseFlg = True
        Me.Close()
    End Sub
    Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        Dim i, j, k As Integer

        For i = ClientAccesses.Count - 1 To 0 Step -1
            '現在と比べて指定時間以上経過していたら
            If DateTime.Compare(DateTime.Now, Time_ClientAccesses(i).AddSeconds(ParamTimeOut)) > 0 Then
                Try
                    Dim SocClient As Socket = CType(ClientAccesses(i), Socket)
                    ClientAccesses.RemoveAt(i)
                    ThreadUserCount(Thread_ClientAccesses(i + 1)) = ThreadUserCount(Thread_ClientAccesses(i + 1)) - 1
                    '削除する代わりに配列の内容を前に詰める
                    For j = i + 1 To ClientAccesses.Count - 1
                        Thread_ClientAccesses(j) = Thread_ClientAccesses(j + 1)
                        Time_ClientAccesses(j) = Time_ClientAccesses(j + 1)
                    Next
                    '切断処理
                    SocClient.Shutdown(SocketShutdown.Both)
                    SocClient.Close()
                Catch ex As Exception
                    DispDataBuf = CPARAM & ex.ToString()
                    'Form1のテキストボックスに表示
                    Me.Invoke(New AsyncServerDelegate(AddressOf DispReceiveData))
                End Try
            End If

        Next

    End Sub

    '--------------------------------------------------------
    ' 受信したデータの処理："shtml" "asp" "aspx"　の場合
    '--------------------------------------------------------
    Private Function WebAppExec(ByVal strSendBuf As String) As String
        Dim strParamName As String = ""
        Dim strWebAppName As String = ""
        Dim sBuf As String = ""
        Dim nPos As Integer
        Dim nPos1 As Integer
        Dim nStart As Integer
        nPos = InStr(strSendBuf, "<%")
        If nPos > 0 Then
            ConCloseFlg = True
        End If
        nStart = 1
        Do While nPos > 0
            sBuf = sBuf & Mid(strSendBuf, nStart, nPos - nStart)
            nPos1 = InStr(nPos, strSendBuf, "%>")
            strWebAppName = Trim(Mid(strSendBuf, nPos + 2, nPos1 - nPos - 2))
            strParamName = SelectWebApp(strWebAppName)
            sBuf = sBuf & strParamName
            nStart = nPos1 + 2
            nPos = InStr(nStart, strSendBuf, "<%")
        Loop
        sBuf = sBuf & Mid(strSendBuf, nStart)
        WebAppExec = sBuf
    End Function

    Private Function UrlRequest(ByVal strSParam As String) As String
        Dim nPos As Integer
        Dim nPos1 As Integer
        Dim sBuf As String
        nPos = InStr(GURLString, strSParam & "=")
        UrlRequest = ""
        If nPos > 0 Then
            nPos1 = InStr(nPos + strSParam.Length + 1, GURLString, "&")
            If nPos1 > 0 Then
                sBuf = Mid(GURLString, nPos + strSParam.Length + 1, nPos1 - (nPos + strSParam.Length + 1))
            Else
                sBuf = Mid(GURLString, nPos + strSParam.Length + 1)
            End If
            UrlRequest = UrlDecode(sBuf, System.Text.Encoding.GetEncoding("SHIFT_JIS"))
        End If
    End Function

    Private Function FormRequest(ByVal strSParam As String) As String
        Dim nPos As Integer
        Dim nPos1 As Integer
        Dim sBuf As String
        nPos = InStr(GRecBuff, strSParam & "=")
        FormRequest = ""
        If nPos > 0 Then
            nPos1 = InStr(nPos + strSParam.Length + 1, GRecBuff, "&")
            If nPos1 <= 0 Then
                nPos1 = InStr(nPos + strSParam.Length + 1, GRecBuff, CPARAM)
            End If
            sBuf = Mid(GRecBuff, nPos + strSParam.Length + 1, nPos1 - (nPos + strSParam.Length + 1))
            FormRequest = UrlDecode(sBuf, System.Text.Encoding.GetEncoding("SHIFT_JIS"))
        End If
    End Function

    Private Sub CookieResponse(ByVal cname As String, ByVal param As String)
        Dim sBuf As String
        sBuf = cname & "=" & param
        If GCookie_Header <> "" Then
            GCookie_Header = GCookie_Header & "&"
        End If
        GCookie_Header = GCookie_Header & sBuf
    End Sub
    Private Function CookieRequest(ByVal cname As String) As String
        CookieRequest = FormRequest(cname)
    End Function

    '--------------------------------------------------------
    ' SelectWebApp
    '--------------------------------------------------------
    Private Function SelectWebApp(ByVal sWebAppName As String) As String
        Select Case LCase(sWebAppName)
            Case "webapp1"
                SelectWebApp = WebApp1()
            Case "webapp2"
                SelectWebApp = WebApp2()
            Case "webapp3"
                SelectWebApp = WebApp3()
            Case "webapp4"
                SelectWebApp = WebApp4()
            Case Else
                SelectWebApp = ""
        End Select
    End Function

    Private Function WebApp1() As String
        WebApp1 = "<b>" & FormRequest("param1") & "<br>" & FormRequest("param2") & "</b>"
    End Function
    Private Function WebApp2() As String
        Dim strDataList As String = ""
        Dim sqlSelect As String = ""
        Dim Connection As New OleDbConnection()
        WebApp2 = ""
        If UrlRequest("table_name") = "" Then Exit Function
        Connection.ConnectionString = GetConnStr()
        Connection.Open()
        sqlSelect = "SELECT * FROM " & UrlRequest("table_name")
        Dim CMD As OleDbCommand = New OleDbCommand(sqlSelect, Connection)
        Dim DA As OleDbDataAdapter = New OleDbDataAdapter()
        DA.SelectCommand = CMD
        Dim WebAppDataSet As New DataSet()
        Dim WebAppDataTable As DataTable
        DA.Fill(WebAppDataSet, "WebAppDataTable")
        WebAppDataTable = WebAppDataSet.Tables("WebAppDataTable")
        Dim i As Integer
        Dim j As Integer
        For i = 0 To WebAppDataTable.Rows.Count - 1
            For j = 0 To WebAppDataTable.Columns.Count - 1
                strDataList = strDataList & CStr("" & WebAppDataTable.Rows(i).Item(j)) & ","
            Next
            strDataList = strDataList & "<br>"
        Next
        WebApp2 = strDataList
    End Function
    Private Function WebApp3() As String
        WebApp3 = ""
        CookieResponse("ck_name1", "こんにちは")
        CookieResponse("ck_name2", "世界のみなさん")
    End Function
    Private Function WebApp4() As String
        WebApp4 = CookieRequest("ck_name1") & "<br>" & CookieRequest("ck_name2")
    End Function

End Class
Public Class StateObject
    Public workSocket As Socket = Nothing
    Public buffer(1024) As Byte
    Public sb As New StringBuilder()
End Class
Public Class WaitFlgObject
    Public Flg As Integer = 0
End Class
