ViewVC Help
View File | Revision Log | Show Annotations | Revision Graph | Root Listing
root/i-scream/projects/cms/source/host/winhost/nettest.frm
Revision: 1.36
Committed: Mon Mar 19 10:11:15 2001 UTC (23 years, 8 months ago) by pjm2
Branch: MAIN
Changes since 1.35: +1 -2 lines
Log Message:
more xml contents tweaking.  check the visual diff

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 = 1185
8 ClientLeft = 45
9 ClientTop = 330
10 ClientWidth = 4710
11 Icon = "nettest.frx":0000
12 LinkTopic = "Form1"
13 MaxButton = 0 'False
14 MinButton = 0 'False
15 ScaleHeight = 1185
16 ScaleWidth = 4710
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 = 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 Begin VB.CommandButton Hide
39 Caption = "hide"
40 Height = 255
41 Left = 3960
42 TabIndex = 6
43 Top = 480
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 = 3480
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.Label Label2
82 Alignment = 1 'Right Justify
83 Caption = "Next heartbeat:"
84 Height = 255
85 Left = 120
86 TabIndex = 5
87 Top = 480
88 Width = 1455
89 End
90 Begin VB.Label Label1
91 Alignment = 1 'Right Justify
92 Caption = "Next UDP packet:"
93 Height = 255
94 Left = 120
95 TabIndex = 4
96 Top = 120
97 Width = 1455
98 End
99 Begin VB.Label Label4
100 BorderStyle = 1 'Fixed Single
101 Caption = "0"
102 Height = 255
103 Left = 1680
104 TabIndex = 3
105 Top = 480
106 Width = 615
107 End
108 Begin VB.Label Label3
109 BorderStyle = 1 'Fixed Single
110 Caption = "0"
111 Height = 255
112 Left = 1680
113 TabIndex = 2
114 Top = 120
115 Width = 615
116 End
117 Begin VB.Label Status
118 Alignment = 2 'Center
119 Caption = "Status:"
120 Height = 255
121 Left = 0
122 TabIndex = 1
123 Top = 840
124 Width = 3855
125 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 ' For the system tray bits
133 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 Dim filterManagerTCPPort As Long
138
139 Dim seqNo As Long
140 Dim machineName As String
141
142 Dim secondsRunning As Long
143
144 Dim filterHostname As String
145 Dim filterTCPPort As Integer
146 Dim filterUDPPort As Integer
147 Dim fileList As String
148 Dim lastModified As String
149
150 Dim fourtySevenDays As Integer
151
152 Dim UDPUpdateTime As Integer
153 Dim TCPUpdateTime As Integer
154
155 Dim protocolVersion As String
156 Dim connected As Boolean
157 Dim heartBeating As Boolean
158
159 Dim CUpTime As New CUpTime
160 Dim wksta As New CNetWksta
161
162 Dim windowBig As Boolean
163
164 Dim responseNumber As Integer
165
166 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 Private Sub Form_Load()
181
182 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 End
185 End If
186
187 ' Assume the host is run within the first 47 days of the machine starting.
188 fourtySevenDays = 0
189
190 protocolVersion = "1.1"
191
192 Status.Caption = "Loading"
193 Form1.Caption = "i-scream Winhost " & protocolVersion
194
195 CUpTime.Init
196
197 If CUpTime.isWin9x Then
198 x = MsgBox("Sorry, the i-scream host can only be used to monitor servers (i.e. not Win9x)", 48, "Not a server")
199 End
200 End If
201
202 windowBig = False
203
204 ''''TEMP
205 'filterManagerHostname = "killigrew.ukc.ac.uk"
206 'filterManagerTCPPort = 4567
207 ''''' END TEMP
208
209 'GoTo skip
210 On Error GoTo iniError
211 Dim buf As String * 256
212 Dim length As Long
213 length = GetPrivateProfileString("i-scream Winhost", "FilterManager", "<no value>", buf, Len(buf), App.Path & "/winhost.ini")
214 filterManagerHostname = Left$(buf, length)
215 length = GetPrivateProfileInt("i-scream Winhost", "FilterManagerPort", 0, App.Path & "/winhost.ini")
216 filterManagerTCPPort = length
217 If filterManagerHostname = "" Then
218 GoTo iniError
219 End If
220 On Error GoTo 0
221 skip:
222
223 Status.Caption = "Connecting to Filter Manager " & filterManagerHostname & ":" & filterManagerTCPPort
224 Reconfigure_Click
225
226 SystemTray.Icon = Val(Form1.Icon)
227 SystemTray.Action = 0
228
229
230 Exit Sub
231
232 iniError:
233 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 End
235
236 End Sub
237
238 Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
239 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 If x = 7 Then
241 Cancel = True
242 Else
243 SystemTray.Action = 2
244 End If
245
246 End Sub
247
248 Private Sub Hide_Click()
249 Form1.Visible = False
250 SystemTray.Icon = Val(Form1.Icon)
251 End Sub
252
253
254 Private Sub Reconfigure_Click()
255 ' establish a TCP connection to a filtermanager
256 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 End Sub
264
265
266
267 Private Sub SystemTray_MouseDblClk(ByVal Button As Integer)
268
269 Form1.Visible = True
270 Form1.SetFocus
271
272 End Sub
273
274 Private Sub TCPSock_Connect()
275
276 responseNumber = 0
277
278 ' Send something as soon as we connect to the server.
279 If connected = False Then
280 ' contact the FilterManager
281 TCPSock.SendData "STARTCONFIG" & vbCrLf
282 Else
283 ' Contact the Filter
284 TCPSock.SendData "HEARTBEAT" & vbCrLf
285 End If
286
287 End Sub
288
289 Private Sub TCPSock_DataArrival(ByVal bytesTotal As Long)
290
291 responseNumber = responseNumber + 1
292
293 ' Get the line from the server.
294 TCPSock.GetData response, vbString, bytesTotal
295
296 ' Remove linefeeds and returns from the line.
297 response = Replace(response, Chr(13), "")
298 response = Replace(response, Chr(10), "")
299
300 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 TCPSock.SendData "LASTMODIFIED" & vbCrLf
307 Text1.Text = "Requesting configuration from FilterManager:- " & vbCrLf
308 Text1.Text = Text1.Text & response & vbCrLf
309 Case 2:
310 If response = "ERROR" Then GoTo configError
311 lastModified = response
312 Text1.Text = Text1.Text & response & vbCrLf
313 TCPSock.SendData "FILELIST" & vbCrLf
314 ' New addition to the protocol.
315 Case 3:
316 If response = "ERROR" Then GoTo configError
317 fileList = response
318 Text1.Text = Text1.Text & response & vbCrLf
319 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 TCPSock.SendData "UDPUpdateTime" & vbCrLf
325 Case 5:
326 If response = "ERROR" Then GoTo configError
327 UDPUpdateTime = response
328 Text1.Text = Text1.Text & response & vbCrLf
329 TCPSock.SendData "TCPUpdateTime" & vbCrLf
330 Case 6:
331 If response = "ERROR" Then GoTo configError
332 TCPUpdateTime = response
333 Text1.Text = Text1.Text & response & vbCrLf
334 TCPSock.SendData "ENDCONFIG" & vbCrLf
335 Case 7:
336 If Not response = "OK" Then GoTo configError
337 Text1.Text = Text1.Text & response & vbCrLf
338 TCPSock.SendData "FILTER" & vbCrLf
339 Case 8:
340 Text1.Text = Text1.Text & response & vbCrLf
341 '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 TCPSock.SendData "END" & vbCrLf
354 Case 9:
355 If Not response = "OK" Then GoTo configError
356 connected = True
357 responseNumber = 0
358 TCPSock.Close
359 Text1.Text = Text1.Text & response & vbCrLf
360 'Text4.Text = Text4.Text & vbCrLf & " <closed>"
361 Status.Caption = "Configuration successful"
362 Label3.Caption = UDPUpdateTime
363 Label4.Caption = TCPUpdateTime
364 Timer1.Interval = 1000
365 End Select
366 Else
367 ' Perform a heartbeat (1.1)
368 heartBeating = True
369 On Error GoTo heartbeatError
370 Select Case responseNumber
371 Case 1:
372 If Not response = "OK" Then GoTo heartbeatError
373 Text1.Text = "Performing heartbeat: -" & vbCrLf
374 Text1.Text = Text1.Text & response & vbCrLf
375 TCPSock.SendData "CONFIG" & vbCrLf
376 Case 2:
377 If Not response = "OK" Then GoTo heartbeatError
378 Text1.Text = Text1.Text & response & vbCrLf
379 TCPSock.SendData fileList & vbCrLf
380 Case 3:
381 If Not response = "OK" Then GoTo heartbeatError
382 Text1.Text = Text1.Text & response & vbCrLf
383 TCPSock.SendData lastModified & vbCrLf
384 Case 4:
385 If Not response = "OK" Then
386 heartBeating = False
387 Reconfigure_Click
388 End If
389 Text1.Text = Text1.Text & response & vbCrLf
390 TCPSock.SendData "ENDHEARTBEAT" & vbCrLf
391 Case 5:
392 If Not response = "OK" Then GoTo heartbeatError
393 Text1.Text = Text1.Text & response & vbCrLf
394 TCPSock.Close
395 Status.Caption = "Heartbeat sent successfully."
396 End Select
397
398 End If
399
400
401 Exit Sub
402
403 configError:
404 heartBeating = False
405 Status.Caption = "FAILED to get configuration from the server"
406 Exit Sub
407 heartbeatError:
408 heartBeating = False
409 Status.Caption = "Heatbeat FAILED"
410 Exit Sub
411 End Sub
412
413 Private Sub Timer1_Timer()
414
415 Label3.Caption = Label3.Caption - 1
416 Label4.Caption = Label4.Caption - 1
417
418 Status.Caption = ""
419
420 If Label3.Caption < 1 Then
421
422 ' prepare the contents of the XML packet.
423 seqNo = seqNo + 1
424
425 netbiosName = TCPSock.LocalHostName
426
427 LocalIP = TCPSock.LocalIP
428 packetDate = Date2Num()
429
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 osName = GetVersion()
440 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 memTotal = memory& \ 1048576
466 memory& = memsts.dwAvailPhys
467 memFree = memory& \ 1048576
468 memory& = memsts.dwTotalVirtual
469 swapTotal = memory& \ 1048576
470 memory& = memsts.dwAvailVirtual
471 swapFree = memory& \ 1048576
472
473 CUpTime.Capture
474 cpu_time = CUpTime.CPUTime
475 percent_idle = CUpTime.PercentIdle
476
477 '' Doesn't work after 47 days :-/
478 'uptime = GetTickCount \ 1000
479
480 'secondsRunning = secondsRunning + UDPUpdateTime
481 'uptime = secondsRunning
482
483 uptime = CUpTime.MilliSecs / 1000#
484
485 userCount = wksta.LoggedOnUsers
486
487 ' build the contents of the XML packet
488 xml = "<packet seq_no=""" & seqNo & """ machine_name=""" & machineName & """ date=""" & packetDate & """ type=""data"" ip=""" & LocalIP & """>" & _
489 "<os>" & _
490 "<netbios_name>" & netbiosName & "</netbios_name>" & _
491 "<name>" & osName & "</name>" & _
492 "<version>" & osVersionMajor & "." & osVersionMinor & "</version>" & _
493 "<release>" & osBuild & "</release>" & _
494 "<platform>" & processorType & "</platform>" & _
495 "<uptime>" & uptime & "</uptime>" & _
496 "</os>" & _
497 "<users><count>" & userCount & "</count></users>" & _
498 "<cpu><idle>" & percent_idle & "</idle><user>" & cpu_time & "</user></cpu>" & _
499 "<memory><total>" & memTotal & "</total><free>" & memFree & "</free></memory>" & _
500 "<swap><total>" & swapTotal & "</total><free>" & swapFree & "</free></swap>" & _
501 "</packet>"
502 Text1.Text = "Last packet contained: -" & vbCrLf & xml
503
504 ' Use the first winsock control to send a UDP packet.
505 UDPSock.RemoteHost = filterHostname
506 UDPSock.RemotePort = filterUDPPort
507 UDPSock.SendData xml
508 Status.Caption = "UDP packet sent"
509 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
521 Function Date2Num() As Long
522 Dim x As Long
523 x = DateDiff("s", "1-1-1970", Now)
524 Date2Num = x
525 End Function