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