ViewVC Help
View File | Revision Log | Show Annotations | Revision Graph | Root Listing
root/i-scream/projects/cms/source/host/winhost/nettest.frm
Revision: 1.37
Committed: Mon Mar 19 10:32:43 2001 UTC (23 years, 8 months ago) by pjm2
Branch: MAIN
Changes since 1.36: +26 -19 lines
Log Message:
Added the long-awaited logo to the host.  Tidied up the layout of the form
a little bit.

File Contents

# Content
1 VERSION 5.00
2 Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
3 Object = "{33155A3D-0CE0-11D1-A6B4-444553540000}#1.0#0"; "SysTray.ocx"
4 Begin VB.Form Form1
5 BorderStyle = 3 'Fixed Dialog
6 Caption = "i-scream Winhost"
7 ClientHeight = 1380
8 ClientLeft = 45
9 ClientTop = 330
10 ClientWidth = 4635
11 Icon = "nettest.frx":0000
12 LinkTopic = "Form1"
13 MaxButton = 0 'False
14 MinButton = 0 'False
15 ScaleHeight = 1380
16 ScaleWidth = 4635
17 ShowInTaskbar = 0 'False
18 StartUpPosition = 2 'CenterScreen
19 Visible = 0 'False
20 Begin VB.CommandButton Command1
21 Caption = "more"
22 Height = 255
23 Left = 3885
24 TabIndex = 8
25 Top = 1035
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 = 1440
36 Width = 4395
37 End
38 Begin VB.CommandButton Hide
39 Caption = "hide"
40 Height = 255
41 Left = 3225
42 TabIndex = 6
43 Top = 1035
44 Width = 615
45 End
46 Begin SysTray.SystemTray SystemTray
47 Left = 2520
48 Top = 4200
49 _ExtentX = 847
50 _ExtentY = 847
51 SysTrayText = "i-scream Winhost"
52 IconFile = 0
53 End
54 Begin VB.Timer Timer1
55 Left = 3120
56 Top = 4200
57 End
58 Begin VB.CommandButton Reconfigure
59 Caption = "Reconfigure with FilterManager"
60 Height = 375
61 Left = 840
62 TabIndex = 0
63 Top = 3555
64 Width = 2895
65 End
66 Begin MSWinsockLib.Winsock TCPSock
67 Left = 4080
68 Top = 4200
69 _ExtentX = 741
70 _ExtentY = 741
71 _Version = 393216
72 End
73 Begin MSWinsockLib.Winsock UDPSock
74 Left = 3600
75 Top = 4200
76 _ExtentX = 741
77 _ExtentY = 741
78 _Version = 393216
79 Protocol = 1
80 End
81 Begin VB.Image Image1
82 Height = 900
83 Left = 2400
84 Picture = "nettest.frx":0742
85 Top = 90
86 Width = 2100
87 End
88 Begin VB.Label Label2
89 Alignment = 1 'Right Justify
90 Caption = "Next heartbeat:"
91 Height = 255
92 Left = 120
93 TabIndex = 5
94 Top = 645
95 Width = 1455
96 End
97 Begin VB.Label Label1
98 Alignment = 1 'Right Justify
99 Caption = "Next UDP packet:"
100 Height = 255
101 Left = 120
102 TabIndex = 4
103 Top = 165
104 Width = 1455
105 End
106 Begin VB.Label Label4
107 BorderStyle = 1 'Fixed Single
108 Caption = "0"
109 Height = 255
110 Left = 1680
111 TabIndex = 3
112 Top = 645
113 Width = 615
114 End
115 Begin VB.Label Label3
116 BorderStyle = 1 'Fixed Single
117 Caption = "0"
118 Height = 255
119 Left = 1680
120 TabIndex = 2
121 Top = 165
122 Width = 615
123 End
124 Begin VB.Label Status
125 Alignment = 2 'Center
126 Caption = "Status:"
127 Height = 255
128 Left = 0
129 TabIndex = 1
130 Top = 1035
131 Width = 3180
132 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 ' For the system tray bits
140 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 Dim filterManagerTCPPort As Long
145
146 Dim seqNo As Long
147 Dim machineName As String
148
149 Dim secondsRunning As Long
150
151 Dim filterHostname As String
152 Dim filterTCPPort As Integer
153 Dim filterUDPPort As Integer
154 Dim fileList As String
155 Dim lastModified As String
156
157 Dim fourtySevenDays As Integer
158
159 Dim UDPUpdateTime As Integer
160 Dim TCPUpdateTime As Integer
161
162 Dim protocolVersion As String
163 Dim connected As Boolean
164 Dim heartBeating As Boolean
165
166 Dim CUpTime As New CUpTime
167 Dim wksta As New CNetWksta
168
169 Dim windowBig As Boolean
170
171 Dim responseNumber As Integer
172
173 Private Sub Command1_Click()
174
175 ' Toggle visibility of the debug output.
176
177 If windowBig Then
178 Form1.Height = 1755
179 windowBig = False
180 Else
181 Form1.Height = 4380
182 windowBig = True
183 End If
184
185 End Sub
186
187 Private Sub Form_Load()
188
189 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 End
192 End If
193
194 ' Assume the host is run within the first 47 days of the machine starting.
195 fourtySevenDays = 0
196
197 protocolVersion = "1.1"
198
199 Status.Caption = "Loading"
200 Form1.Caption = "i-scream Winhost " & protocolVersion
201
202 CUpTime.Init
203
204 If CUpTime.isWin9x Then
205 x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server")
206 End
207 End If
208
209 windowBig = False
210
211 ''''TEMP
212 'filterManagerHostname = "killigrew.ukc.ac.uk"
213 'filterManagerTCPPort = 4567
214 ''''' END TEMP
215
216 'GoTo skip
217 On Error GoTo iniError
218 Dim buf As String * 256
219 Dim length As Long
220 length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
221 filterManagerHostname = Left$(buf, length)
222 length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
223 filterManagerTCPPort = length
224 If filterManagerHostname = "" Then
225 GoTo iniError
226 End If
227 On Error GoTo 0
228 skip:
229
230 Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
231 Reconfigure_Click
232
233 SystemTray.Icon = Val(Form1.Icon)
234 SystemTray.Action = 0
235
236
237 Exit Sub
238
239 iniError:
240 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 End
242
243 End Sub
244
245 Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
246 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 If x = 7 Then
248 Cancel = True
249 Else
250 SystemTray.Action = 2
251 End If
252
253 End Sub
254
255 Private Sub Hide_Click()
256 Form1.Visible = False
257 SystemTray.Icon = Val(Form1.Icon)
258 End Sub
259
260
261 Private Sub Reconfigure_Click()
262 ' establish a TCP connection to a filtermanager
263 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 End Sub
271
272
273
274 Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)
275
276 Form1.Visible = True
277 Form1.SetFocus
278
279 End Sub
280
281 Private Sub TCPSock_Connect()
282
283 responseNumber = 0
284
285 ' Send something as soon as we connect to the server.
286 If connected = False Then
287 ' contact the FilterManager
288 TCPSock.SendData "STARTCONFIG" & vbCrLf
289 Else
290 ' Contact the Filter
291 TCPSock.SendData "HEARTBEAT" & vbCrLf
292 End If
293
294 End Sub
295
296 Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
297
298 responseNumber = responseNumber + 1
299
300 ' Get the line from the server.
301 TCPSock.GetData response, vbString, bytesTotal
302
303 ' Remove linefeeds and returns from the line.
304 response = Replace(response, Chr(13), "")
305 response = Replace(response, Chr(10), "")
306
307 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 TCPSock.SendData "LASTMODIFIED" & vbCrLf
314 Text1.Text = "Requesting configuration from FilterManager:- " & vbCrLf
315 Text1.Text = Text1.Text & response & vbCrLf
316 Case 2:
317 If response = "ERROR" Then GoTo configError
318 lastModified = response
319 Text1.Text = Text1.Text & response & vbCrLf
320 TCPSock.SendData "FILELIST" & vbCrLf
321 ' New addition to the protocol.
322 Case 3:
323 If response = "ERROR" Then GoTo configError
324 fileList = response
325 Text1.Text = Text1.Text & response & vbCrLf
326 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 TCPSock.SendData "UDPUpdateTime" & vbCrLf
332 Case 5:
333 If response = "ERROR" Then GoTo configError
334 UDPUpdateTime = response
335 Text1.Text = Text1.Text & response & vbCrLf
336 TCPSock.SendData "TCPUpdateTime" & vbCrLf
337 Case 6:
338 If response = "ERROR" Then GoTo configError
339 TCPUpdateTime = response
340 Text1.Text = Text1.Text & response & vbCrLf
341 TCPSock.SendData "ENDCONFIG" & vbCrLf
342 Case 7:
343 If Not response = "OK" Then GoTo configError
344 Text1.Text = Text1.Text & response & vbCrLf
345 TCPSock.SendData "FILTER" & vbCrLf
346 Case 8:
347 Text1.Text = Text1.Text & response & vbCrLf
348 '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 TCPSock.SendData "END" & vbCrLf
361 Case 9:
362 If Not response = "OK" Then GoTo configError
363 connected = True
364 responseNumber = 0
365 TCPSock.Close
366 Text1.Text = Text1.Text & response & vbCrLf
367 'Text4.Text = Text4.Text & vbCrLf & " <closed>"
368 Status.Caption = "Configuration successful"
369 Label3.Caption = UDPUpdateTime
370 Label4.Caption = TCPUpdateTime
371 Timer1.Interval = 1000
372 End Select
373 Else
374 ' Perform a heartbeat (1.1)
375 heartBeating = True
376 On Error GoTo heartbeatError
377 Select Case responseNumber
378 Case 1:
379 If Not response = "OK" Then GoTo heartbeatError
380 Text1.Text = "Performing heartbeat: -" & vbCrLf
381 Text1.Text = Text1.Text & response & vbCrLf
382 TCPSock.SendData "CONFIG" & vbCrLf
383 Case 2:
384 If Not response = "OK" Then GoTo heartbeatError
385 Text1.Text = Text1.Text & response & vbCrLf
386 TCPSock.SendData fileList & vbCrLf
387 Case 3:
388 If Not response = "OK" Then GoTo heartbeatError
389 Text1.Text = Text1.Text & response & vbCrLf
390 TCPSock.SendData lastModified & vbCrLf
391 Case 4:
392 If Not response = "OK" Then
393 heartBeating = False
394 Reconfigure_Click
395 End If
396 Text1.Text = Text1.Text & response & vbCrLf
397 TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
398 Case 5:
399 If Not response = "OK" Then GoTo heartbeatError
400 Text1.Text = Text1.Text & response & vbCrLf
401 TCPSock.Close
402 Status.Caption = "Heartbeat sent successfully."
403 End Select
404
405 End If
406
407
408 Exit Sub
409
410 configError:
411 heartBeating = False
412 Status.Caption = "FAILED to get configuration from the server"
413 Exit Sub
414 heartbeatError:
415 heartBeating = False
416 Status.Caption = "Heatbeat FAILED"
417 Exit Sub
418 End Sub
419
420 Private Sub Timer1_Timer()
421
422 Label3.Caption = Label3.Caption - 1
423 Label4.Caption = Label4.Caption - 1
424
425 Status.Caption = ""
426
427 If Label3.Caption < 1 Then
428
429 ' prepare the contents of the XML packet.
430 seqNo = seqNo + 1
431
432 netbiosName = TCPSock.LocalHostName
433
434 LocalIP = TCPSock.LocalIP
435 packetDate = Date2Num()
436
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 osName = GetVersion()
447 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 memTotal = memory& \ 1048576
473 memory& = memsts.dwAvailPhys
474 memFree = memory& \ 1048576
475 memory& = memsts.dwTotalVirtual
476 swapTotal = memory& \ 1048576
477 memory& = memsts.dwAvailVirtual
478 swapFree = memory& \ 1048576
479
480 CUpTime.Capture
481 cpu_time = CUpTime.CPUTime
482 percent_idle = CUpTime.PercentIdle
483
484 '' Doesn't work after 47 days :-/
485 'uptime = GetTickCount \ 1000
486
487 'secondsRunning = secondsRunning + UDPUpdateTime
488 'uptime = secondsRunning
489
490 uptime = CUpTime.MilliSecs / 1000#
491
492 userCount = wksta.LoggedOnUsers
493
494 ' build the contents of the XML packet
495 xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
496 "<os>" & _
497 "<netbios_name>" & netbiosName & "</netbios_name>" & _
498 "<name>" & osName & "</name>" & _
499 "<version>" & osVersionMajor & "." & osVersionMinor & "</version>" & _
500 "<release>" & osBuild & "</release>" & _
501 "<platform>" & processorType & "</platform>" & _
502 "<uptime>" & uptime & "</uptime>" & _
503 "</os>" & _
504 "<users><count>" & userCount & "</count></users>" & _
505 "<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
506 "<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
507 "<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
508 "</packet>"
509 Text1.Text = "Last packet contained: -" & vbCrLf & xml
510
511 ' Use the first winsock control to send a UDP packet.
512 UDPSock.RemoteHost = filterHostname
513 UDPSock.RemotePort = filterUDPPort
514 UDPSock.SendData xml
515 Status.Caption = "UDP packet sent"
516 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
528 Function Date2Num() As Long
529 Dim x As Long
530 x = DateDiff("s", "1-1-1970", Now)
531 Date2Num = x
532 End Function