io Programmo 27/IOPROG_27.ISO/SOFT/HTTPSER.ZIP/HTSTST.FOR

Visual Basic Form | 1996-11-14 | 23.0 KB | 614 lines

VERSION 4.00
Begin VB.Form frmHTTPSRTest
   Caption         =   "HTTP Server Test"
   ClientHeight    =   7695
   ClientLeft      =   1320
   ClientTop       =   1545
   ClientWidth     =   6780
   Height          =   8100
   Left            =   1260
   LinkTopic       =   "Form1"
   ScaleHeight     =   7695
   ScaleWidth      =   6780
   Top             =   1200
   Width           =   6900
   Begin VB.CommandButton btnClear
      Caption         =   "Clear Log"
      Height          =   375
      Left            =   1800
      TabIndex        =   11
      Top             =   3000
      Width           =   975
   End
   Begin VB.TextBox txtPort
      Height          =   285
      Left            =   3240
      TabIndex        =   6
      Text            =   "81"
      Top             =   1680
      Width           =   1695
   End
   Begin VB.TextBox txtMax
      Height          =   285
      Left            =   3240
      TabIndex        =   5
      Text            =   "100"
      Top             =   1320
      Width           =   1695
   End
   Begin VB.TextBox txtPortDefault
      Height          =   285
      Left            =   3240
      TabIndex        =   9
      Text            =   "82"
      Top             =   2520
      Width           =   1695
   End
   Begin VB.TextBox txtMaxDefault
      Height          =   285
      Left            =   3240
      TabIndex        =   8
      Text            =   "100"
      Top             =   2160
      Width           =   1695
   End
   Begin VB.CommandButton btnDefault
      Caption         =   "Start"
      Height          =   375
      Left            =   5160
      TabIndex        =   10
      Top             =   2280
      Width           =   975
   End
   Begin VB.CommandButton btnManual
      Caption         =   "Start"
      Height          =   375
      Left            =   5160
      TabIndex        =   7
      Top             =   1440
      Width           =   975
   End
   Begin VB.CommandButton btnProxy
      Caption         =   "Start"
      Height          =   375
      Left            =   5160
      TabIndex        =   4
      Top             =   240
      Width           =   975
   End
   Begin VB.TextBox txtPortProxy
      Height          =   285
      Left            =   3240
      TabIndex        =   2
      Text            =   "80"
      Top             =   480
      Width           =   1695
   End
   Begin VB.TextBox txtProxy
      Height          =   285
      Left            =   3240
      TabIndex        =   3
      Top             =   840
      Width           =   2775
   End
   Begin VB.TextBox txtLog
      Height          =   4095
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   12
      Top             =   3480
      Width           =   6495
   End
   Begin VB.TextBox txtMaxProxy
      Height          =   285
      Left            =   3240
      TabIndex        =   1
      Text            =   "100"
      Top             =   120
      Width           =   1695
   End
   Begin HTTPSRLib.HTTPSR HTTPSRDefault
      Left            =   240
      Top             =   2400
      _ExtentX        =   741
      _ExtentY        =   741
      Blocking        =   0   'False
      SleepTime       =   10
      ListenPort      =   0
      MaxConnections  =   100
      DefaultDocument =   "index.htm"
      RootDirectory   =   "c:\netmanag.32\webdocs"
   End
   Begin HTTPSRLib.HTTPSR HTTPSRManual
      Left            =   360
      Top             =   1680
      _ExtentX        =   741
      _ExtentY        =   741
      Blocking        =   0   'False
      SleepTime       =   10
      ListenPort      =   0
      MaxConnections  =   100
      DefaultDocument =   "index.htm"
      RootDirectory   =   "c:\netmanag.32\webdocs"
   End
   Begin HTTPSRLib.HTTPSR HTTPSRProxy
      Left            =   120
      Top             =   600
      _ExtentX        =   741
      _ExtentY        =   741
      Blocking        =   0   'False
      SleepTime       =   10
      ListenPort      =   0
      MaxConnections  =   100
      DefaultDocument =   "index.htm"
      RootDirectory   =   "c:\netmanag.32\webdocs"
   End
   Begin VB.Label Label7
      Caption         =   "Server Port:"
      Height          =   255
      Left            =   1200
      TabIndex        =   22
      Top             =   1680
      Width           =   1935
   End
   Begin VB.Label Label6
      Caption         =   "Max Connections:"
      Height          =   255
      Left            =   1200
      TabIndex        =   21
      Top             =   1320
      Width           =   1815
   End
   Begin VB.Label Label3
      Caption         =   "Server Port:"
      Height          =   255
      Left            =   1200
      TabIndex        =   20
      Top             =   2520
      Width           =   1935
   End
   Begin VB.Label Label8
      Caption         =   "Max Connections:"
      Height          =   255
      Left            =   1200
      TabIndex        =   19
      Top             =   2160
      Width           =   1815
   End
   Begin VB.Label Label11
      Caption         =   "Default"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   12
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   18
      Top             =   2160
      Width           =   975
   End
   Begin VB.Label Label10
      Caption         =   "Manual"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   12
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   17
      Top             =   1320
      Width           =   975
   End
   Begin VB.Label Label9
      Caption         =   "Proxy"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   12
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   16
      Top             =   120
      Width           =   735
   End
   Begin VB.Label Label4
      Caption         =   "Log:"
      Height          =   255
      Left            =   120
      TabIndex        =   15
      Top             =   3000
      Width           =   495
   End
   Begin VB.Line Line3
      X1              =   0
      X2              =   6600
      Y1              =   2880
      Y2              =   2880
   End
   Begin VB.Line Line2
      X1              =   0
      X2              =   6600
      Y1              =   2040
      Y2              =   2040
   End
   Begin VB.Line Line1
      X1              =   0
      X2              =   6600
      Y1              =   1200
      Y2              =   1200
   End
   Begin HTTPCTLib.HTTP HTTPCT1
      Left            =   600
      Top             =   600
      _ExtentX        =   741
      _ExtentY        =   741
      Blocking        =   0   'False
      SleepTime       =   10
      RemoteHost      =   "127.0.0.1"
      RemotePort      =   80
      ConnectTimeout  =   0
      RecvTimeout     =   0
      NotificationMode=   1
      Document        =   ""
      Method          =   1
   End
   Begin VB.Label Label5
      Caption         =   "Server Port:"
      Height          =   255
      Left            =   1200
      TabIndex        =   14
      Top             =   480
      Width           =   1935
   End
   Begin VB.Label Label2
      Caption         =   "HTTP Server:"
      Height          =   255
      Left            =   1200
      TabIndex        =   13
      Top             =   840
      Width           =   1815
   End
   Begin VB.Label Label1
      Caption         =   "Max Connections:"
      Height          =   255
      Left            =   1200
      TabIndex        =   0
      Top             =   120
      Width           =   1815
   End
Attribute VB_Name = "frmHTTPSRTest"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim strPostData As String
Sub EnumSessions(ByVal httpsr1 As HTTPSR)
    Dim session1 As HTTPSRSession
    Log "---Enumeration of Sessions, Count is: " & httpsr1.Sessions.Count
    For Each session1 In httpsr1.Sessions
        Log vbTab & session1.RemoteHostIP & "  " & session1.RemotePort & "  " & session1.StateString
    Next
End Sub
Sub Log(ByVal str As String)
    txtLog.SelText = vbCrLf & str
    txtLog.SelStart = Len(txtLog)
End Sub
Sub StartServer(btn As CommandButton, max As Integer, port As Integer, httpsr1 As HTTPSR)
    On Error Resume Next
    If btn.Caption = "Start" Then
        httpsr1.MaxConnections = max
        httpsr1.ListenPort = port
        httpsr1.Start
        If (Err.Number > 0) Then
            Log "Failed to start server on port : " & port & vbCrLf & vbTab & Err.Description
        Else
            Log "Started HTTP server at port : " & port
            btn.Caption = "Stop"
        End If
    Else
        httpsr1.Stop False
        Log "Stopped HTTP server at port : " & port
        btn.Caption = "Start"
    End If
End Sub
Private Sub LogError(ByVal httpsr1 As HTTPSR, Number As Integer, Description As String)
    Log "Server port: " & httpsr1.ListenPort & " Error event: " & Number & " " & Description
    Dim error As icError
    Dim errors As icErrors
    Set errors = httpsr1.errors
    If Not (errors Is Nothing) Then
        If IsEmpty(errors.Source) Then
            Log vbTab & "Errors.Source is empty"
        Else
            Log vbTab & "Errors Source: " & "Thread: " & errors.Source.ThreadID & _
                " Remote host: " & errors.Source.RemoteHostIP & " " & errors.Source.RemoteHostName
        End If
        For Each error In errors
            Log vbTab & "Error type: " & error.Type & " " & error.Code & " " & _
                    error.Description
        Next
    Else
        Log vbTab & "Errors property is nothing!"
    End If
End Sub
Private Sub btnClear_Click()
    txtLog = ""
End Sub
Private Sub btnDefault_Click()
    StartServer btnDefault, txtMaxDefault, txtPortDefault, HTTPSRDefault
End Sub
Private Sub btnManual_Click()
    StartServer btnManual, txtMax, txtPort, HTTPSRManual
End Sub
Private Sub btnProxy_Click()
    StartServer btnProxy, txtMaxProxy, txtPortProxy, HTTPSRProxy
End Sub
Private Sub Form_Load()
' start all servers
    btnProxy_Click
    btnManual_Click
    btnDefault_Click
End Sub
Private Sub HTTPSRDefault_Accept(ByVal Session As Object, AcceptConnection As Boolean)
    Log "Default server --- accept connection from " & Session.RemoteHostIP & " Port: " & Session.RemotePort
End Sub
Private Sub HTTPSRDefault_CloseAll()
    Log "Default server --- all sessions are closed"
End Sub
Private Sub HTTPSRDefault_DocInput(ByVal Session As Object, ByVal DocInput As DocInput)
    Log "Default server -- DocInput event: state = " & DocInput.State
End Sub
Private Sub HTTPSRDefault_DocOutput(ByVal Session As Object, ByVal DocOutput As DocOutput)
    Log "Default server --- DocOutput event - state: " & DocOutput.State
Dim data As Variant
    If DocOutput.State = icDocBegin Then
        strPostData = ""
    ElseIf DocOutput.State = icDocHeaders Then
        Dim hdr As DocHeader
        For Each hdr In DocOutput.Headers
            Log vbTab & hdr.Name & " : " & hdr.Value
        Next
    ElseIf DocOutput.State = icDocData Then
        DocOutput.GetData data
        strPostData = strPostData & data
    ElseIf DocOutput.State = icDocEnd Then
        Log vbTab & "Output data in file: " & DocOutput.filename
        Log strPostData
    End If
End Sub
Private Sub HTTPSRDefault_Error(Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean)
    LogError HTTPSRDefault, Number, Description
End Sub
Private Sub HTTPSRDefault_RemoteHostName(ByVal Session As Object, ByVal Success As Boolean)
    Log "Default server --- RemoteHostName event " & str(Success)
    Log vbTab & "Session thread ID: " & Session.ThreadID & _
        " RemoteHost: " & Session.RemoteHostIP & " " & Session.RemoteHostName
End Sub
Private Sub HTTPSRDefault_Request(ByVal Session As Object, EnableDefault As Boolean)
        EnableDefault = True
        Log "Default server -- Got request from :" & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort
        Log vbTab & "Document: " & Session.Document
        Log Session.RequestString
        If Session.Method = prsPut Or Session.Method = prsPost Then ' POST and PUT
            Session.DocOutput.filename = "c:\default.txt"
        End If
End Sub
Private Sub HTTPSRDefault_StateChanged(ByVal Session As Object, ByVal State As Integer)
    If State = prcConnected Then
        Session.Timeout = 1 ' in seconds
        Log "Default server --- new session from : " & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort & " Timeout(seconds): " & Session.Timeout
    End If
    Log "Default server --- session State changed to : " & Session.StateString
    EnumSessions HTTPSRDefault
End Sub
Private Sub HTTPSRDefault_Timeout(ByVal Session As Object)
    Log "Default server --- timeout"
    Session.Close
End Sub
Private Sub HTTPSRProxy_Accept(ByVal Session As Object, AcceptConnection As Boolean)
    Log "Proxy server --- accept connection from " & Session.RemoteHostIP & " Port: " & Session.RemotePort
End Sub
Private Sub HTTPSRProxy_CloseAll()
    Log "Proxy server --- all sessions are closed"
End Sub
Private Sub HTTPSRProxy_DocInput(ByVal Session As Object, ByVal DocInput As DocInput)
    Log "Proxy server -- DocInput event: state = " & DocInput.State
    If DocInput.State = icDocHeaders Then
        If Len(Session.ReplyString) = 0 Then  ' replystring hasn't been set
            Session.ReplyString = httpct1.ReplyString
        End If
        Log vbTab & "Reply string: " & Session.ReplyString
    ElseIf DocInput.State = icDocData Then
        If Session.Method = prsHead Then  ' for HEAD
            ' Chameleon HTTP server sends data even for HEAD request
'            DocInput.SetData "" ' do not send data for HEAD request
        End If
    ElseIf DocInput.State = icDocEnd Then
        Log vbTab & "BytesTransferred: " & DocInput.BytesTransferred
        Session.DocInput.DocLink = Nothing  ' for doclink, must be here
        httpct1.DocInput.DocLink = Nothing
        If Len(Session.ReplyString) = 0 Then  ' didn't get headers notification
            Session.ReplyString = "HTTP/1.0 404 Error in processing"
            Session.ReplyDoc , "<BODY> Error in processing request, please return to home page</BODY>"
        Else
            Session.Close
        End If
        ' could result in partial data if default docstream implementation is used.
        ' httpsr override ondata to fix docstream problem.
    End If
End Sub
Private Sub HTTPSRProxy_DocOutput(ByVal Session As Object, ByVal DocOutput As DocOutput)
    Log "Proxy server --- DocOutput event - state: " & DocOutput.State
Dim data As Variant
    If DocOutput.State = icDocBegin Then
        strPostData = ""
    ElseIf DocOutput.State = icDocHeaders Then
        Dim hdr As DocHeader
        For Each hdr In DocOutput.Headers
            Log vbTab & hdr.Name & " : " & hdr.Value
        Next
    ElseIf DocOutput.State = icDocData Then
        DocOutput.GetData data
        strPostData = strPostData & data
    ElseIf DocOutput.State = icDocEnd Then
        Log vbTab & "Output data in file: " & DocOutput.filename
        Log strPostData
    End If
End Sub
Private Sub HTTPSRProxy_Error(Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean)
    LogError HTTPSRProxy, Number, Description
End Sub
Private Sub HTTPSRProxy_RemoteHostName(ByVal Session As Object, ByVal Success As Boolean)
    Log "Proxy server --- RemoteHostName event " & str(Success)
    Log vbTab & "Session thread ID: " & Session.ThreadID & _
        " RemoteHost: " & Session.RemoteHostIP & " " & Session.RemoteHostName
End Sub
Private Sub HTTPSRProxy_Request(ByVal Session As Object, EnableDefault As Boolean)
        If (txtProxy.Text = "") Then
            Log "ERROR: Please enter a HTTP Server"
            'MsgBox "Please enter a HTTP Server"
           Exit Sub
        End If
        EnableDefault = False
        Log "Proxy server -- Got request from :" & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort
        Log vbTab & "Document: " & Session.Document
        Log Session.RequestString

        ' reset replystring

        Session.ReplyString = ""
        If Session.Method = prsPut Or Session.Method = prsPost Then ' POST and PUT
            Session.DocOutput.filename = "c:\proxy.txt"
            httpct1.Method = Session.Method
            Session.DocInput.DocLink = httpct1.DocOutput.DocLink
            httpct1.DocInput.DocLink = Session.DocOutput.DocLink
            Session.ReplyDoc
            httpct1.SendDoc txtProxy.Text & Session.Document
        Else  ' GET and HEAD
            httpct1.Method = Session.Method
            Session.DocInput.DocLink = httpct1.DocOutput.DocLink
            Session.ReplyDoc
            httpct1.GetDoc txtProxy.Text & Session.Document
        End If
End Sub
Private Sub HTTPSRProxy_StateChanged(ByVal Session As Object, ByVal State As Integer)
    If State = prcConnected Then
        Session.Timeout = 1 ' in seconds
        Log "Proxy server --- new session from : " & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort & " Timeout(seconds): " & Session.Timeout
    End If
    Log "Proxy server --- session State changed to : " & Session.StateString
    EnumSessions HTTPSRProxy
End Sub
Private Sub HTTPSRProxy_Timeout(ByVal Session As Object)
    Log "Proxy server --- timeout"
'    Session.Close
End Sub
Private Sub HTTPSRManual_Accept(ByVal Session As Object, AcceptConnection As Boolean)
    Log "Manual server --- accept connection from " & Session.RemoteHostIP & " Port: " & Session.RemotePort
End Sub
Private Sub HTTPSRManual_CloseAll()
    Log "Manual server --- all sessions are closed"
End Sub
Private Sub HTTPSRManual_DocInput(ByVal Session As Object, ByVal DocInput As DocInput)
    Log "Manual server -- DocInput event: state = " & DocInput.State
    If DocInput.State = icDocData Then
        If Session.Method = prsHead Then  ' for HEAD
            DocInput.SetData "" ' do not send data for HEAD request
        End If
    ElseIf DocInput.State = icDocHeaders Then
        If Len(Session.ReplyString) = 0 Then
            Session.ReplyString = "HTTP/1.0 200 Document follows"
        End If
        Log vbTab & Session.ReplyString
    ElseIf DocInput.State = icDocEnd Then
        Log vbTab & "BytesTransferred: " & DocInput.BytesTransferred
        If Len(Session.ReplyString) = 0 Then  ' no headers have been sent yet. something is wrong
            Session.ReplyString = "HTTP/1.0 404 File not found"
            Session.ReplyDoc , "<BODY> document is not found, return to home page</BODY>"
        Else
            Session.Close
        End If
        ' could result in partial data if default docstream implementation is used.
        ' httpsr override ondata to fix docstream problem.
    End If
End Sub
Private Sub HTTPSRManual_DocOutput(ByVal Session As Object, ByVal DocOutput As DocOutput)
    Log "Manual server --- DocOutput event - state: " & DocOutput.State
Dim data As Variant
    If DocOutput.State = icDocBegin Then
        strPostData = ""
    ElseIf DocOutput.State = icDocHeaders Then
        Dim hdr As DocHeader
        For Each hdr In DocOutput.Headers
            Log vbTab & hdr.Name & " : " & hdr.Value
        Next
    ElseIf DocOutput.State = icDocData Then
        DocOutput.GetData data
        strPostData = strPostData & data
    ElseIf DocOutput.State = icDocEnd Then
        Log vbTab & "Output data in file: " & DocOutput.filename
        If Session.Method = prsPost Or Session.Method = prsPut Then
            ' should integrate with CGI
            Log strPostData
            Session.ReplyDoc , "<BODY> Got post/put request, data is " & strPostData & "</BODY>"
            Debug.Print Environ("REQUEST_METHOD")
        Else ' GET, HEAD
            If Session.Document = "/" Then
                Session.ReplyDoc , , HTTPSRManual.RootDirectory & "\" & HTTPSRManual.DefaultDocument  ' default HTML file
            Else
                ' TODO: deal with subdirectory
                Session.ReplyDoc , , HTTPSRManual.RootDirectory & "\" & Right(Session.Document, Len(Session.Document) - 1)
            End If
        End If
    End If
End Sub
Private Sub HTTPSRManual_Error(Number As Integer, Description As String, Scode As Long, Source As String, HelpFile As String, HelpContext As Long, CancelDisplay As Boolean)
    LogError HTTPSRManual, Number, Description
End Sub
Private Sub HTTPSRManual_RemoteHostName(ByVal Session As Object, ByVal Success As Boolean)
    Log "Manual server --- RemoteHostName event " & str(Success)
    Log vbTab & "Session thread ID: " & Session.ThreadID & _
        " RemoteHost: " & Session.RemoteHostIP & " " & Session.RemoteHostName
End Sub
Private Sub HTTPSRManual_Request(ByVal Session As Object, EnableDefault As Boolean)
        EnableDefault = False
        Log "Manual server -- Got request from :" & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort
        Log vbTab & "Document: " & Session.Document
        Log Session.RequestString

        Session.DocOutput.filename = "c:\manual.txt"
End Sub
Private Sub HTTPSRManual_StateChanged(ByVal Session As Object, ByVal State As Integer)
    If State = prcConnected Then
        Session.Timeout = 1 ' in seconds
        Log "Manual server --- new session from : " & Session.RemoteHostIP & _
            " Port: " & Session.RemotePort & " Timeout(seconds): " & Session.Timeout
    End If
    Log "Manual server --- session State changed to : " & Session.StateString
    EnumSessions HTTPSRManual
End Sub
Private Sub HTTPSRManual_Timeout(ByVal Session As Object)
    Log "Manual server --- timeout"
    'Debug.Print "Manual server --- timeout"
'    Session.Close
End Sub