host/winhost/nettest.frm

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{33155A3D-0CE0-11D1-A6B4-444553540000}#1.0#0"; "SysTray.ocx"
Begin VB.Form Form1 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "i-scream Winhost"
   ClientHeight    =   1185
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4710
   Icon            =   "nettest.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1185
   ScaleWidth      =   4710
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Visible         =   0   'False
   Begin VB.CommandButton Command1 
      Caption         =   "more"
      Height          =   255
      Left            =   3960
      TabIndex        =   8
      Top             =   840
      Width           =   615
   End
   Begin VB.TextBox Text1 
      Height          =   2055
      Left            =   120
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   7
      Top             =   1200
      Width           =   4455
   End
   Begin VB.CommandButton Hide 
      Caption         =   "hide"
      Height          =   255
      Left            =   3960
      TabIndex        =   6
      Top             =   480
      Width           =   615
   End
   Begin SysTray.SystemTray SystemTray 
      Left            =   2520
      Top             =   4200
      _ExtentX        =   847
      _ExtentY        =   847
      SysTrayText     =   "i-scream Winhost"
      IconFile        =   0
   End
   Begin VB.Timer Timer1 
      Left            =   3120
      Top             =   4200
   End
   Begin VB.CommandButton Reconfigure 
      Caption         =   "Reconfigure with FilterManager"
      Height          =   375
      Left            =   840
      TabIndex        =   0
      Top             =   3480
      Width           =   2895
   End
   Begin MSWinsockLib.Winsock TCPSock 
      Left            =   4080
      Top             =   4200
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin MSWinsockLib.Winsock UDPSock 
      Left            =   3600
      Top             =   4200
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      Protocol        =   1
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "Next heartbeat:"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   480
      Width           =   1455
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "Next UDP packet:"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   120
      Width           =   1455
   End
   Begin VB.Label Label4 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   255
      Left            =   1680
      TabIndex        =   3
      Top             =   480
      Width           =   615
   End
   Begin VB.Label Label3 
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   255
      Left            =   1680
      TabIndex        =   2
      Top             =   120
      Width           =   615
   End
   Begin VB.Label Status 
      Alignment       =   2  'Center
      Caption         =   "Status:"
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   840
      Width           =   3855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' For the system tray bits
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long

Dim filterManagerHostname As String
Dim filterManagerTCPPort As Long

Dim seqNo As Long
Dim machineName As String

Dim secondsRunning As Long

Dim filterHostname As String
Dim filterTCPPort As Integer
Dim filterUDPPort As Integer
Dim fileList As String
Dim lastModified As String

Dim fourtySevenDays As Integer

Dim UDPUpdateTime As Integer
Dim TCPUpdateTime As Integer

Dim protocolVersion As String
Dim connected As Boolean
Dim heartBeating As Boolean

Dim CUpTime As New CUpTime
Dim wksta As New CNetWksta

Dim windowBig As Boolean

Dim responseNumber As Integer

Private Sub Command1_Click()

    ' Toggle visibility of the debug output.

    If windowBig Then
        Form1.Height = 1500
        windowBig = False
    Else
        Form1.Height = 4350
        windowBig = True
    End If

End Sub

Private Sub Form_Load()
    
    If App.PrevInstance Then
        x = MsgBox("There is already an i-scream Winhost running on this machine.", 48, "i-scream host already running")
        End
    End If
    
    ' Assume the host is run within the first 47 days of the machine starting.
    fourtySevenDays = 0
    
    protocolVersion = "1.1"
    
    Status.Caption = "Loading"
    Form1.Caption = "i-scream Winhost " & protocolVersion
    
    CUpTime.Init
    
    If CUpTime.isWin9x Then
        x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server")
        End
    End If
    
    windowBig = False
    
    ''''TEMP
    'filterManagerHostname = "killigrew.ukc.ac.uk"
    'filterManagerTCPPort = 4567
    ''''' END TEMP
    
    'GoTo skip
    On Error GoTo iniError
    Dim buf As String * 256
    Dim length As Long
    length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
    filterManagerHostname = Left$(buf, length)
    length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
    filterManagerTCPPort = length
    If filterManagerHostname = "" Then
        GoTo iniError
    End If
    On Error GoTo 0
skip:

    Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
    Reconfigure_Click
    
    SystemTray.Icon = Val(Form1.Icon)
    SystemTray.Action = 0
    
    
    Exit Sub
    
iniError:
    x = MsgBox("The i-scream Winhost could not read the correct settings from the winhost.ini file.  Please correct these and try again.  " & Err.Description, 48, "Configuration not found")
    End
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    x = MsgBox("Are you sure you want to shut down the Winhost?  This will stop your computer sending information to the i-scream Central Monitoring System.", vbYesNo, "i-scream Winhost")
    If x = 7 Then
        Cancel = True
    Else
        SystemTray.Action = 2
    End If

End Sub

Private Sub Hide_Click()
    Form1.Visible = False
    SystemTray.Icon = Val(Form1.Icon)
End Sub


Private Sub Reconfigure_Click()
    ' establish a TCP connection to a filtermanager
    If Not heartBeating Then
        connected = False
        TCPSock.Close
        TCPSock.Connect filterManagerHostname, filterManagerTCPPort
    Else
        Status.Caption = "Cannot reconfigure while heartbeating"
    End If
End Sub


Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)

    Form1.Visible = True
    Form1.SetFocus

End Sub

Private Sub TCPSock_Connect()
    
    responseNumber = 0
   
    ' Send something as soon as we connect to the server.
    If connected = False Then
        ' contact the FilterManager
        TCPSock.SendData "STARTCONFIG" & vbCrLf
    Else
       ' Contact the Filter
       TCPSock.SendData "HEARTBEAT" & vbCrLf
    End If
   
End Sub

Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
    
    responseNumber = responseNumber + 1
    
    ' Get the line from the server.
    TCPSock.GetData response, vbString, bytesTotal
    
    ' Remove linefeeds and returns from the line.
    response = Replace(response, Chr(13), "")
    response = Replace(response, Chr(10), "")
    
    If connected = False Then
        ' Perform TCP configuration (1.1)
        On Error GoTo configError
        Select Case responseNumber
            Case 1:
                If Not response = "OK" Then GoTo configError
                TCPSock.SendData "LASTMODIFIED" & vbCrLf
                Text1.Text = "Requesting configuration from FilterManager:- " & vbCrLf
                Text1.Text = Text1.Text & response & vbCrLf
            Case 2:
                If response = "ERROR" Then GoTo configError
                lastModified = response
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "FILELIST" & vbCrLf
            ' New addition to the protocol.
            Case 3:
                If response = "ERROR" Then GoTo configError
                fileList = response
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "FQDN" & vbCrLf
            Case 4:
                If response = "ERROR" Then GoTo configError
                Text1.Text = Text1.Text & response & vbCrLf
                machineName = response
                TCPSock.SendData "UDPUpdateTime" & vbCrLf
            Case 5:
                If response = "ERROR" Then GoTo configError
                UDPUpdateTime = response
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "TCPUpdateTime" & vbCrLf
            Case 6:
                If response = "ERROR" Then GoTo configError
                TCPUpdateTime = response
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "ENDCONFIG" & vbCrLf
            Case 7:
                If Not response = "OK" Then GoTo configError
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "FILTER" & vbCrLf
            Case 8:
                Text1.Text = Text1.Text & response & vbCrLf
                'we got a filter list here.
                readTo = 0
                ' get hostname
                readTo = InStr(1, response, ";", vbBinaryCompare)
                filterHostname = Mid(response, 1, readTo - 1)
                response = Mid(response, readTo + 1, Len(response))
                ' get UDP Port number
                readTo = InStr(1, response, ";")
                filterUDPPort = Mid(response, 1, readTo - 1)
                response = Mid(response, readTo + 1, Len(response))
                ' get TCP Port number
                filterTCPPort = response
                TCPSock.SendData "END" & vbCrLf
            Case 9:
                If Not response = "OK" Then GoTo configError
                connected = True
                responseNumber = 0
                TCPSock.Close
                Text1.Text = Text1.Text & response & vbCrLf
                'Text4.Text = Text4.Text & vbCrLf & "  <closed>"
                Status.Caption = "Configuration successful"
                Label3.Caption = UDPUpdateTime
                Label4.Caption = TCPUpdateTime
                Timer1.Interval = 1000
        End Select
    Else
        ' Perform a heartbeat (1.1)
        heartBeating = True
        On Error GoTo heartbeatError
        Select Case responseNumber
            Case 1:
                If Not response = "OK" Then GoTo heartbeatError
                Text1.Text = "Performing heartbeat: -" & vbCrLf
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "CONFIG" & vbCrLf
            Case 2:
                If Not response = "OK" Then GoTo heartbeatError
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData fileList & vbCrLf
            Case 3:
                If Not response = "OK" Then GoTo heartbeatError
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData lastModified & vbCrLf
            Case 4:
                If Not response = "OK" Then
                    heartBeating = False
                    Reconfigure_Click
                End If
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
            Case 5:
                If Not response = "OK" Then GoTo heartbeatError
                Text1.Text = Text1.Text & response & vbCrLf
                TCPSock.Close
                Status.Caption = "Heartbeat sent successfully."
        End Select
    
    End If
    
    
    Exit Sub
    
configError:
    heartBeating = False
    Status.Caption = "FAILED to get configuration from the server"
    Exit Sub
heartbeatError:
    heartBeating = False
    Status.Caption = "Heatbeat FAILED"
    Exit Sub
End Sub

Private Sub Timer1_Timer()

    Label3.Caption = Label3.Caption - 1
    Label4.Caption = Label4.Caption - 1
    
    Status.Caption = ""
    
    If Label3.Caption < 1 Then
        
        ' prepare the contents of the XML packet.
        seqNo = seqNo + 1
        
        netbiosName = TCPSock.LocalHostName
        
        LocalIP = TCPSock.LocalIP
        packetDate = Date2Num()
        
        
        Dim verinfo As OSVERSIONINFO
        verinfo.dwOSVersionInfoSize = Len(verinfo)
        ret% = GetVersionEx(verinfo)
        If ret% = 0 Then
            MsgBox "Error getting Windows version Information"
            End
        End If
          
        osName = GetVersion()
        osVersionMajor = verinfo.dwMajorVersion
        osVersionMinor = verinfo.dwMinorVersion
        osBuild = verinfo.dwBuildNumber
        
        Dim sysinfo As SYSTEM_INFO
        GetSystemInfo sysinfo
        Select Case sysinfo.dwProcessorType
            Case PROCESSOR_INTEL_386
                processorType = "Intel 386"
            Case PROCESSOR_INTEL_486
                processorType = "Intel 486"
            Case PROCESSOR_INTEL_PENTIUM
                processorType = "Intel Pentium variant"
            Case PROCESSOR_MIPS_R4000
                processorType = "MIPS R4000"
            Case PROCESSOR_ALPHA_21064
                processorType = "DEC Alpha 21064"
            Case Else
                processorType = "(unknown)"
        End Select
        
        Dim memsts As MEMORYSTATUS
        Dim memory&
        GlobalMemoryStatus memsts
        memory& = memsts.dwTotalPhys
        memTotal = memory& \ 1048576
        memory& = memsts.dwAvailPhys
        memFree = memory& \ 1048576
        memory& = memsts.dwTotalVirtual
        swapTotal = memory& \ 1048576
        memory& = memsts.dwAvailVirtual
        swapFree = memory& \ 1048576
        
        CUpTime.Capture
        cpu_time = CUpTime.CPUTime
        percent_idle = CUpTime.PercentIdle
        
        '' Doesn't work after 47 days :-/
        'uptime = GetTickCount \ 1000
        
        'secondsRunning = secondsRunning + UDPUpdateTime
        'uptime = secondsRunning
        
        uptime = CUpTime.MilliSecs / 1000#
        
        userCount = wksta.LoggedOnUsers
        
        ' build the contents of the XML packet
        xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
              "<os>" & _
                "<netbios_name>" & netbiosName & "</netbios_name>" & _
                "<name>" & osName & "</name>" & _
                "<version>" & osVersionMajor & "." & osVersionMinor & "</version>" & _
                "<release>" & osBuild & "</release>" & _
                "<platform>" & processorType & "</platform>" & _
                "<uptime>" & uptime & "</uptime>" & _
              "</os>" & _
              "<users><count>" & userCount & "</count></users>" & _
              "<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
              "<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
              "<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
              "</packet>"
        Text1.Text = "Last packet contained: -" & vbCrLf & xml

        ' Use the first winsock control to send a UDP packet.
        UDPSock.RemoteHost = filterHostname
        UDPSock.RemotePort = filterUDPPort
        UDPSock.SendData xml
        Status.Caption = "UDP packet sent"
        Label3.Caption = UDPUpdateTime
    End If
    
    If Label4.Caption < 1 Then
        ' establish a TCP connection to a filter
        TCPSock.Close
        TCPSock.Connect filterHostname, filterTCPPort
        Label4.Caption = TCPUpdateTime
    End If

End Sub

Function Date2Num() As Long
    Dim x As Long
    x = DateDiff("s", "1-1-1970", Now)
    Date2Num = x
End Function
Revision:	1.36
Committed:	Mon Mar 19 10:11:15 2001 UTC (23 years, 6 months ago) by pjm2
Branch:	MAIN
Changes since 1.35:	+1 -2 lines
Log Message:	more xml contents tweaking. check the visual diff
#	User	Rev	Content
1	pjm2	1.1	VERSION 5.00
2			Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
3	pjm2	1.11	Object = "{33155A3D-0CE0-11D1-A6B4-444553540000}#1.0#0"; "SysTray.ocx"
4	pjm2	1.1	Begin VB.Form Form1
5	pjm2	1.17	BorderStyle = 3 'Fixed Dialog
6	pjm2	1.10	Caption = "i-scream Winhost"
7	pjm2	1.27	ClientHeight = 1185
8	pjm2	1.1	ClientLeft = 45
9	pjm2	1.17	ClientTop = 330
10	pjm2	1.12	ClientWidth = 4710
11	pjm2	1.20	Icon = "nettest.frx":0000
12	pjm2	1.1	LinkTopic = "Form1"
13			MaxButton = 0 'False
14	pjm2	1.17	MinButton = 0 'False
15	pjm2	1.27	ScaleHeight = 1185
16	pjm2	1.12	ScaleWidth = 4710
17	pjm2	1.1	ShowInTaskbar = 0 'False
18	pjm2	1.24	StartUpPosition = 2 'CenterScreen
19			Visible = 0 'False
20	pjm2	1.26	Begin VB.CommandButton Command1
21			Caption = "more"
22			Height = 255
23			Left = 3960
24			TabIndex = 8
25			Top = 840
26			Width = 615
27			End
28			Begin VB.TextBox Text1
29			Height = 2055
30			Left = 120
31			Locked = -1 'True
32			MultiLine = -1 'True
33			ScrollBars = 2 'Vertical
34			TabIndex = 7
35			Top = 1200
36			Width = 4455
37			End
38	pjm2	1.11	Begin VB.CommandButton Hide
39	pjm2	1.27	Caption = "hide"
40			Height = 255
41			Left = 3960
42	pjm2	1.24	TabIndex = 6
43	pjm2	1.27	Top = 480
44			Width = 615
45	pjm2	1.11	End
46			Begin SysTray.SystemTray SystemTray
47	pjm2	1.26	Left = 2520
48			Top = 4200
49	pjm2	1.11	_ExtentX = 847
50			_ExtentY = 847
51			SysTrayText = "i-scream Winhost"
52			IconFile = 0
53			End
54	pjm2	1.8	Begin VB.Timer Timer1
55	pjm2	1.26	Left = 3120
56			Top = 4200
57	pjm2	1.1	End
58	pjm2	1.10	Begin VB.CommandButton Reconfigure
59			Caption = "Reconfigure with FilterManager"
60	pjm2	1.12	Height = 375
61	pjm2	1.26	Left = 840
62	pjm2	1.10	TabIndex = 0
63	pjm2	1.26	Top = 3480
64	pjm2	1.10	Width = 2895
65	pjm2	1.1	End
66	pjm2	1.5	Begin MSWinsockLib.Winsock TCPSock
67	pjm2	1.26	Left = 4080
68			Top = 4200
69	pjm2	1.1	_ExtentX = 741
70			_ExtentY = 741
71			_Version = 393216
72			End
73	pjm2	1.5	Begin MSWinsockLib.Winsock UDPSock
74	pjm2	1.26	Left = 3600
75			Top = 4200
76	pjm2	1.1	_ExtentX = 741
77			_ExtentY = 741
78			_Version = 393216
79			Protocol = 1
80			End
81	pjm2	1.9	Begin VB.Label Label2
82			Alignment = 1 'Right Justify
83			Caption = "Next heartbeat:"
84	pjm2	1.8	Height = 255
85	pjm2	1.26	Left = 120
86	pjm2	1.24	TabIndex = 5
87	pjm2	1.26	Top = 480
88	pjm2	1.9	Width = 1455
89	pjm2	1.8	End
90	pjm2	1.9	Begin VB.Label Label1
91			Alignment = 1 'Right Justify
92			Caption = "Next UDP packet:"
93	pjm2	1.8	Height = 255
94	pjm2	1.24	Left = 120
95			TabIndex = 4
96	pjm2	1.9	Top = 120
97			Width = 1455
98	pjm2	1.8	End
99	pjm2	1.9	Begin VB.Label Label4
100	pjm2	1.10	BorderStyle = 1 'Fixed Single
101	pjm2	1.9	Caption = "0"
102	pjm2	1.7	Height = 255
103	pjm2	1.26	Left = 1680
104	pjm2	1.24	TabIndex = 3
105	pjm2	1.26	Top = 480
106	pjm2	1.9	Width = 615
107	pjm2	1.7	End
108	pjm2	1.9	Begin VB.Label Label3
109	pjm2	1.10	BorderStyle = 1 'Fixed Single
110	pjm2	1.9	Caption = "0"
111	pjm2	1.7	Height = 255
112	pjm2	1.24	Left = 1680
113			TabIndex = 2
114	pjm2	1.9	Top = 120
115			Width = 615
116	pjm2	1.7	End
117	pjm2	1.6	Begin VB.Label Status
118	pjm2	1.12	Alignment = 2 'Center
119	pjm2	1.6	Caption = "Status:"
120	pjm2	1.1	Height = 255
121	pjm2	1.18	Left = 0
122	pjm2	1.24	TabIndex = 1
123	pjm2	1.26	Top = 840
124			Width = 3855
125	pjm2	1.1	End
126			End
127			Attribute VB_Name = "Form1"
128			Attribute VB_GlobalNameSpace = False
129			Attribute VB_Creatable = False
130			Attribute VB_PredeclaredId = True
131			Attribute VB_Exposed = False
132	pjm2	1.15	' For the system tray bits
133	pjm2	1.4	Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
134			Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
135
136			Dim filterManagerHostname As String
137	pjm2	1.18	Dim filterManagerTCPPort As Long
138	pjm2	1.4
139	pjm2	1.13	Dim seqNo As Long
140			Dim machineName As String
141
142	pjm2	1.32	Dim secondsRunning As Long
143
144	pjm2	1.2	Dim filterHostname As String
145	pjm2	1.3	Dim filterTCPPort As Integer
146			Dim filterUDPPort As Integer
147			Dim fileList As String
148			Dim lastModified As String
149	pjm2	1.2
150	pjm2	1.32	Dim fourtySevenDays As Integer
151
152	pjm2	1.7	Dim UDPUpdateTime As Integer
153			Dim TCPUpdateTime As Integer
154
155	pjm2	1.2	Dim protocolVersion As String
156			Dim connected As Boolean
157	pjm2	1.34	Dim heartBeating As Boolean
158	pjm2	1.16
159	pjm2	1.21	Dim CUpTime As New CUpTime
160	pjm2	1.25	Dim wksta As New CNetWksta
161	pjm2	1.16
162	pjm2	1.26	Dim windowBig As Boolean
163
164	pjm2	1.1	Dim responseNumber As Integer
165
166	pjm2	1.26	Private Sub Command1_Click()
167
168			' Toggle visibility of the debug output.
169
170			If windowBig Then
171			Form1.Height = 1500
172			windowBig = False
173			Else
174			Form1.Height = 4350
175			windowBig = True
176			End If
177
178			End Sub
179
180	pjm2	1.2	Private Sub Form_Load()
181	pjm2	1.13
182	pjm2	1.22	If App.PrevInstance Then
183			x = MsgBox("There is already an i-scream Winhost running on this machine.", 48, "i-scream host already running")
184	pjm2	1.25	End
185	pjm2	1.22	End If
186
187	pjm2	1.32	' Assume the host is run within the first 47 days of the machine starting.
188			fourtySevenDays = 0
189
190	pjm2	1.2	protocolVersion = "1.1"
191	pjm2	1.13
192	pjm2	1.10	Status.Caption = "Loading"
193	pjm2	1.21	Form1.Caption = "i-scream Winhost " & protocolVersion
194
195			CUpTime.Init
196
197			If CUpTime.isWin9x Then
198	pjm2	1.25	x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server")
199	pjm2	1.21	End
200			End If
201	pjm2	1.6
202	pjm2	1.26	windowBig = False
203
204	pjm2	1.4	''''TEMP
205	pjm2	1.18	'filterManagerHostname = "killigrew.ukc.ac.uk"
206			'filterManagerTCPPort = 4567
207	pjm2	1.13	''''' END TEMP
208	pjm2	1.4
209	pjm2	1.18	'GoTo skip
210	pjm2	1.4	On Error GoTo iniError
211			Dim buf As String * 256
212			Dim length As Long
213	pjm2	1.18	length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
214	pjm2	1.4	filterManagerHostname = Left$(buf, length)
215	pjm2	1.18	length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
216			filterManagerTCPPort = length
217	pjm2	1.25	If filterManagerHostname = "" Then
218			GoTo iniError
219			End If
220	pjm2	1.20	On Error GoTo 0
221	pjm2	1.13	skip:
222
223	pjm2	1.18	Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
224	pjm2	1.13	Reconfigure_Click
225	pjm2	1.6
226	pjm2	1.20	SystemTray.Icon = Val(Form1.Icon)
227	pjm2	1.15	SystemTray.Action = 0
228
229
230	pjm2	1.4	Exit Sub
231
232			iniError:
233	pjm2	1.18	x = MsgBox("The i-scream Winhost could not read the correct settings from the winhost.ini file. Please correct these and try again. " & Err.Description, 48, "Configuration not found")
234	pjm2	1.4	End
235
236			End Sub
237
238	pjm2	1.10	Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
239	pjm2	1.11	x = MsgBox("Are you sure you want to shut down the Winhost? This will stop your computer sending information to the i-scream Central Monitoring System.", vbYesNo, "i-scream Winhost")
240	pjm2	1.10	If x = 7 Then
241			Cancel = True
242	pjm2	1.15	Else
243			SystemTray.Action = 2
244	pjm2	1.10	End If
245
246			End Sub
247
248	pjm2	1.11	Private Sub Hide_Click()
249			Form1.Visible = False
250			SystemTray.Icon = Val(Form1.Icon)
251			End Sub
252
253	pjm2	1.30
254	pjm2	1.10	Private Sub Reconfigure_Click()
255			' establish a TCP connection to a filtermanager
256	pjm2	1.34	If Not heartBeating Then
257			connected = False
258			TCPSock.Close
259			TCPSock.Connect filterManagerHostname, filterManagerTCPPort
260			Else
261			Status.Caption = "Cannot reconfigure while heartbeating"
262			End If
263	pjm2	1.11	End Sub
264
265
266
267			Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)
268
269			Form1.Visible = True
270			Form1.SetFocus
271
272	pjm2	1.10	End Sub
273
274	pjm2	1.5	Private Sub TCPSock_Connect()
275	pjm2	1.6
276			responseNumber = 0
277	pjm2	1.1
278	pjm2	1.3	' Send something as soon as we connect to the server.
279			If connected = False Then
280			' contact the FilterManager
281	pjm2	1.5	TCPSock.SendData "STARTCONFIG" & vbCrLf
282	pjm2	1.3	Else
283			' Contact the Filter
284	pjm2	1.5	TCPSock.SendData "HEARTBEAT" & vbCrLf
285	pjm2	1.3	End If
286	pjm2	1.1
287			End Sub
288
289	pjm2	1.5	Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
290	pjm2	1.1
291			responseNumber = responseNumber + 1
292
293			' Get the line from the server.
294	pjm2	1.5	TCPSock.GetData response, vbString, bytesTotal
295	pjm2	1.1
296			' Remove linefeeds and returns from the line.
297			response = Replace(response, Chr(13), "")
298			response = Replace(response, Chr(10), "")
299
300	pjm2	1.2	If connected = False Then
301			' Perform TCP configuration (1.1)
302			On Error GoTo configError
303			Select Case responseNumber
304			Case 1:
305			If Not response = "OK" Then GoTo configError
306	pjm2	1.5	TCPSock.SendData "LASTMODIFIED" & vbCrLf
307	pjm2	1.26	Text1.Text = "Requesting configuration from FilterManager:- " & vbCrLf
308			Text1.Text = Text1.Text & response & vbCrLf
309	pjm2	1.2	Case 2:
310			If response = "ERROR" Then GoTo configError
311	pjm2	1.3	lastModified = response
312	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
313	pjm2	1.5	TCPSock.SendData "FILELIST" & vbCrLf
314	pjm2	1.29	' New addition to the protocol.
315	pjm2	1.2	Case 3:
316			If response = "ERROR" Then GoTo configError
317	pjm2	1.3	fileList = response
318	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
319	pjm2	1.29	TCPSock.SendData "FQDN" & vbCrLf
320			Case 4:
321			If response = "ERROR" Then GoTo configError
322			Text1.Text = Text1.Text & response & vbCrLf
323			machineName = response
324	pjm2	1.5	TCPSock.SendData "UDPUpdateTime" & vbCrLf
325	pjm2	1.29	Case 5:
326	pjm2	1.2	If response = "ERROR" Then GoTo configError
327	pjm2	1.7	UDPUpdateTime = response
328	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
329	pjm2	1.5	TCPSock.SendData "TCPUpdateTime" & vbCrLf
330	pjm2	1.29	Case 6:
331	pjm2	1.2	If response = "ERROR" Then GoTo configError
332	pjm2	1.7	TCPUpdateTime = response
333	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
334	pjm2	1.5	TCPSock.SendData "ENDCONFIG" & vbCrLf
335	pjm2	1.29	Case 7:
336	pjm2	1.2	If Not response = "OK" Then GoTo configError
337	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
338	pjm2	1.5	TCPSock.SendData "FILTER" & vbCrLf
339	pjm2	1.29	Case 8:
340	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
341	pjm2	1.2	'we got a filter list here.
342			readTo = 0
343			' get hostname
344			readTo = InStr(1, response, ";", vbBinaryCompare)
345			filterHostname = Mid(response, 1, readTo - 1)
346			response = Mid(response, readTo + 1, Len(response))
347			' get UDP Port number
348			readTo = InStr(1, response, ";")
349			filterUDPPort = Mid(response, 1, readTo - 1)
350			response = Mid(response, readTo + 1, Len(response))
351			' get TCP Port number
352			filterTCPPort = response
353	pjm2	1.5	TCPSock.SendData "END" & vbCrLf
354	pjm2	1.29	Case 9:
355	pjm2	1.2	If Not response = "OK" Then GoTo configError
356			connected = True
357			responseNumber = 0
358	pjm2	1.5	TCPSock.Close
359	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
360	pjm2	1.24	'Text4.Text = Text4.Text & vbCrLf & " <closed>"
361	pjm2	1.10	Status.Caption = "Configuration successful"
362	pjm2	1.8	Label3.Caption = UDPUpdateTime
363			Label4.Caption = TCPUpdateTime
364			Timer1.Interval = 1000
365	pjm2	1.2	End Select
366			Else
367			' Perform a heartbeat (1.1)
368	pjm2	1.34	heartBeating = True
369	pjm2	1.2	On Error GoTo heartbeatError
370			Select Case responseNumber
371			Case 1:
372	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
373	pjm2	1.26	Text1.Text = "Performing heartbeat: -" & vbCrLf
374			Text1.Text = Text1.Text & response & vbCrLf
375	pjm2	1.5	TCPSock.SendData "CONFIG" & vbCrLf
376	pjm2	1.2	Case 2:
377	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
378	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
379	pjm2	1.5	TCPSock.SendData fileList & vbCrLf
380	pjm2	1.2	Case 3:
381	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
382	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
383	pjm2	1.5	TCPSock.SendData lastModified & vbCrLf
384	pjm2	1.2	Case 4:
385	pjm2	1.34	If Not response = "OK" Then
386			heartBeating = False
387			Reconfigure_Click
388			End If
389	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
390	pjm2	1.5	TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
391	pjm2	1.2	Case 5:
392	pjm2	1.3	If Not response = "OK" Then GoTo heartbeatError
393	pjm2	1.26	Text1.Text = Text1.Text & response & vbCrLf
394	pjm2	1.5	TCPSock.Close
395	pjm2	1.10	Status.Caption = "Heartbeat sent successfully."
396	pjm2	1.2	End Select
397
398			End If
399
400
401			Exit Sub
402
403			configError:
404	pjm2	1.34	heartBeating = False
405	pjm2	1.33	Status.Caption = "FAILED to get configuration from the server"
406	pjm2	1.8	Exit Sub
407	pjm2	1.2	heartbeatError:
408	pjm2	1.34	heartBeating = False
409	pjm2	1.10	Status.Caption = "Heatbeat FAILED"
410	pjm2	1.8	Exit Sub
411	pjm2	1.1	End Sub
412	pjm2	1.5
413	pjm2	1.8	Private Sub Timer1_Timer()
414
415			Label3.Caption = Label3.Caption - 1
416			Label4.Caption = Label4.Caption - 1
417
418	pjm2	1.10	Status.Caption = ""
419	pjm2	1.8
420			If Label3.Caption < 1 Then
421	pjm2	1.15
422			' prepare the contents of the XML packet.
423			seqNo = seqNo + 1
424	pjm2	1.26
425	pjm2	1.31	netbiosName = TCPSock.LocalHostName
426	pjm2	1.26
427	pjm2	1.16	LocalIP = TCPSock.LocalIP
428	pjm2	1.14	packetDate = Date2Num()
429	pjm2	1.15
430
431			Dim verinfo As OSVERSIONINFO
432			verinfo.dwOSVersionInfoSize = Len(verinfo)
433			ret% = GetVersionEx(verinfo)
434			If ret% = 0 Then
435			MsgBox "Error getting Windows version Information"
436			End
437			End If
438
439	pjm2	1.21	osName = GetVersion()
440	pjm2	1.15	osVersionMajor = verinfo.dwMajorVersion
441			osVersionMinor = verinfo.dwMinorVersion
442			osBuild = verinfo.dwBuildNumber
443
444			Dim sysinfo As SYSTEM_INFO
445			GetSystemInfo sysinfo
446			Select Case sysinfo.dwProcessorType
447			Case PROCESSOR_INTEL_386
448			processorType = "Intel 386"
449			Case PROCESSOR_INTEL_486
450			processorType = "Intel 486"
451			Case PROCESSOR_INTEL_PENTIUM
452			processorType = "Intel Pentium variant"
453			Case PROCESSOR_MIPS_R4000
454			processorType = "MIPS R4000"
455			Case PROCESSOR_ALPHA_21064
456			processorType = "DEC Alpha 21064"
457			Case Else
458			processorType = "(unknown)"
459			End Select
460
461			Dim memsts As MEMORYSTATUS
462			Dim memory&
463			GlobalMemoryStatus memsts
464			memory& = memsts.dwTotalPhys
465	pjm2	1.29	memTotal = memory& \ 1048576
466	pjm2	1.15	memory& = memsts.dwAvailPhys
467	pjm2	1.29	memFree = memory& \ 1048576
468	pjm2	1.15	memory& = memsts.dwTotalVirtual
469	pjm2	1.29	swapTotal = memory& \ 1048576
470	pjm2	1.15	memory& = memsts.dwAvailVirtual
471	pjm2	1.29	swapFree = memory& \ 1048576
472	pjm2	1.15
473	pjm2	1.23	CUpTime.Capture
474			cpu_time = CUpTime.CPUTime
475			percent_idle = CUpTime.PercentIdle
476	pjm2	1.32
477			'' Doesn't work after 47 days :-/
478			'uptime = GetTickCount \ 1000
479
480	pjm2	1.33	'secondsRunning = secondsRunning + UDPUpdateTime
481			'uptime = secondsRunning
482
483			uptime = CUpTime.MilliSecs / 1000#
484	pjm2	1.23
485	pjm2	1.28	userCount = wksta.LoggedOnUsers
486
487	pjm2	1.15	' build the contents of the XML packet
488	pjm2	1.16	xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
489	pjm2	1.15	"<os>" & _
490	pjm2	1.31	"<netbios_name>" & netbiosName & "</netbios_name>" & _
491	pjm2	1.15	"<name>" & osName & "</name>" & _
492	pjm2	1.35	"<version>" & osVersionMajor & "." & osVersionMinor & "</version>" & _
493	pjm2	1.15	"<release>" & osBuild & "</release>" & _
494	pjm2	1.36	"<platform>" & processorType & "</platform>" & _
495	pjm2	1.19	"<uptime>" & uptime & "</uptime>" & _
496	pjm2	1.15	"</os>" & _
497	pjm2	1.28	"<users><count>" & userCount & "</count></users>" & _
498	pjm2	1.23	"<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
499	pjm2	1.15	"<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
500			"<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
501	pjm2	1.17	"</packet>"
502	pjm2	1.26	Text1.Text = "Last packet contained: -" & vbCrLf & xml
503	pjm2	1.8
504			' Use the first winsock control to send a UDP packet.
505			UDPSock.RemoteHost = filterHostname
506			UDPSock.RemotePort = filterUDPPort
507			UDPSock.SendData xml
508	pjm2	1.10	Status.Caption = "UDP packet sent"
509	pjm2	1.8	Label3.Caption = UDPUpdateTime
510			End If
511
512			If Label4.Caption < 1 Then
513			' establish a TCP connection to a filter
514			TCPSock.Close
515			TCPSock.Connect filterHostname, filterTCPPort
516			Label4.Caption = TCPUpdateTime
517			End If
518
519			End Sub
520	pjm2	1.13
521			Function Date2Num() As Long
522	pjm2	1.14	Dim x As Long
523			x = DateDiff("s", "1-1-1970", Now)
524			Date2Num = x
525	pjm2	1.13	End Function