AllSyntax.com: » Tutorials » Visual%20Basic » 2 » Coding A Webserver


	I start where the last man left off. - Thomas A. Edison

[login] | [Register]

Coding a Webserver

by: Common Exploit

Page: 3 of 4
(View All)

The Log Server Code

Add the following code to your form. The internal documentation is (for me) quite good so the code should be quite readable.

code:

'Array of connections 
Dim CN() As tConnection 
'Message buffer 
Dim buffer As String

Option Explicit

Private Sub Form_Load()

'Accept incoming Clients on port 255 
'This allows external clients to view 
'log server Log Server data 
ReDim CN(0) 
Wsock(0).LocalPort = 255 
Wsock(0).Listen

'Accept incoming notifications on Port 1 
'This allows other applications to send 
'data to be proxied to viewers. 
PLink(0).LocalPort = 1 
PLink(0).Listen

End Sub

Private Sub Timer_Timer()

Dim n As Integer 
Dim flds

'Loop while there is data in the buffer 
Do While Len(buffer) <> 0 
'The flds variant is used to hold the 
'array of messages in the buffer 
flds = Split(buffer, ":|:") 
'Iterate through the connections 
For n = 1 To UBound(CN) 
'If the connection has been autenticated 
'AND the socket is ok (7) 
If CN(n).State = tAuthenticated And Wsock(n).State = 7 Then 
'Send the left most item from the buffer 
'to connection n 
Wsock(n).SendData flds(0) & vbCrLf 
'Doesn't actually send data until 
'DoEvents called 
DoEvents 
End If 
Next n 
'This DoEvents allows the DataArrival event to 
'continue adding newly received information 
'to the buffer 
DoEvents 
'Remove the left most item from the buffer 
buffer = Right(buffer, Len(buffer) - (Len(flds(0)) + 3)) 
Loop 
Timer.Enabled = False

End Sub

Private Sub Wsock_ConnectionRequest(Index As Integer, _ 
ByVal requestID As Long)

'New incoming external connection 
Dim n As Long 
'Get the index of the next 
'WSock object 
n = Wsock.UBound + 1 
'Load the WSock Object 
Load Wsock(n)

'Create value of type tConnection 
'for this WSock object 
ReDim Preserve CN(n) 
'Set the Connection index to that of the 
'WSock control. 
CN(n).Index = Index 
'Set the state of the connection 
CN(n).State = tUsername

'Accept the connection 
Wsock(n).Accept (requestID)

'Display the connection message 
Wsock(n).SendData ConnectionMessage(n)

End Sub

Private Sub Wsock_DataArrival(Index As Integer, _ 
ByVal bytesTotal As Long)

'String Value to hold incoming data 
Dim StrVal As String

'Get the incoming data 
Wsock(Index).GetData StrVal, vbString

'Remove crlf characters 
StrVal = Replace(StrVal, Chr(10), "") 
StrVal = Replace(StrVal, Chr(13), "")

'Commands to be run regardless of 
'connection state. 
Select Case LCase(StrVal) 
Case "quit" 
'Send a disconnection Message 
Wsock(Index).SendData DisConnectionMessage 
DoEvents 
'Set connection state as tGone 
CN(Index).State = tGone 
'Close the WSock object 
Wsock(Index).Close 
End Select

'Process the incoming data dependant 
'upon the connection state 
Select Case CN(Index).State 
'Getting username 
Case tUsername 
'If the left hand side of the command is "user " 
If LCase(Left(StrVal, Len("user "))) = "user " Then 
'If the bit after user is not blank 
If Len(Right(StrVal, Len(StrVal) - Len("user "))) > 0 Then 
'Set the username for this connection 
CN(Index).username = Right(StrVal, Len(StrVal) - Len("user ")) 
'Change connection state to accept password 
CN(Index).State = tPassword 
Else 
'No user name 
Wsock(Index).SendData "No Username supplied." & vbCrLf 
DoEvents 
CN(Index).State = tUsername 
End If 
Else 
'Any other input while connection 
'is in the tUsername state 
Wsock(Index).SendData "Not logged in." & vbCrLf 
DoEvents 
CN(Index).State = tUsername 
End If

'Getting password 
Case tPassword 
'If left hand side of command is "pass " 
If LCase(Left(StrVal, Len("pass "))) = "pass " Then 
'If value is not blank 
If Len(Right(StrVal, Len(StrVal) - Len("pass "))) > 0 Then 
'set the connection password 
CN(Index).password = Right(StrVal, Len(StrVal) - Len("pass ")) 
'Is the username/password valid? 
If ValidPassword(CN(Index).username, CN(Index).password) Then 
'Set the connection stsate to authenticated 
CN(Index).State = tAuthenticated 
'Send a message to the client to tell them 
'that they authenticated ok 
Wsock(Index).SendData "Authenticated." & vbCrLf 
DoEvents 
Else 
'Invalid user/pass 
Wsock(Index).SendData "Invalid username/password. Login fails." & vbCrLf 
DoEvents 
'Increment the connection retry value 
CN(Index).ReTries = CN(Index).ReTries + 1 
'On 3 retries 
If CN(Index).ReTries = 3 Then 
'Send quitting message 
Wsock(Index).SendData "3 failed logins. Disconnecting." & vbCrLf 
DoEvents 
'Set the connection state as gone 
CN(Index).State = tGone 
'Close the socket 
Wsock(Index).Close 
Else 
'If connection not @ max retries 
'set the connection state back to tUsername 
CN(Index).State = tUsername 
End If 
End If 
Else 
'Password is blank 
Wsock(Index).SendData "No Password Supplied. Login fails." & vbCrLf 
DoEvents 
CN(Index).State = tUsername 
End If 
Else 
'Command is not pass *** 
Wsock(Index).SendData "Expecting password. Login fails." & vbCrLf 
DoEvents 
'Set the connection stats back to tUsername 
CN(Index).State = tUsername 
End If

'Commands to accept if the connection 
'has been authenticated 
Case tAuthenticated 
Select Case LCase(StrVal) 
Case "quit" 
Wsock(Index).SendData DisConnectionMessage 
DoEvents 
CN(Index).State = tGone 
Wsock(Index).Close 
Case Else 
'Unrecognised command 
Wsock(Index).SendData "Command not recognised." & vbCrLf 
DoEvents 
End Select

End Select

End Sub

Private Sub PLink_ConnectionRequest(Index As Integer, _ 
ByVal requestID As Long)

Dim n As Long

'Incoming connection from 
'an application 
n = PLink.UBound + 1 
'load the next PLink socket 
Load PLink(n) 
'Accept the connection 
PLink(n).Accept (requestID)

End Sub

Private Sub PLink_DataArrival(Index As Integer, _ 
ByVal bytesTotal As Long)

'When data arrives from application

Dim StrVal, sp, s As String 
Dim n, x As Integer 
Dim strvals()

'Get the incoming data 
PLink(Index).GetData StrVal, vbString

'Remove crlf characters 
StrVal = Replace(StrVal, Chr(10), "") 
StrVal = Replace(StrVal, Chr(13), "")

'Add the incoming message to the 
'message buffer 
buffer = buffer & StrVal & ":|:"

'Enable the timer to read data from 
'the buffer and send it to connected, 
'authenticated clients 
Timer.Enabled = True

End Sub

Private Function ConnectionMessage(cid As Long) As String

'A connection message 
'This could be loaded from a file, 
'the registry, or a database

Dim cm As String

cm = "" & vbCrLf 
cm = cm & " ================================================== 
=" & vbCrLf 
cm = cm & " Log Server v1.0 by Simon Barnett." & vbCrLf 
cm = cm & " Connected to Log Server at " & Now() & vbCrLf 
cm = cm & " Your Connection ID is: " & CStr(cid) & vbCrLf 
cm = cm & " There are currently : " & CStr(UserCount) & " sessions open." & vbCrLf 
cm = cm & " ==================================================

" & vbCrLf 
cm = cm & vbCrLf

ConnectionMessage = cm

End Function

Private Function DisConnectionMessage() As String

'A DISconnection message 
'This could be loaded from a file, 
'the registry, or a database

Dim dm As String 
dm = vbCrLf & "Bye then!" & vbCrLf 
DisConnectionMessage = dm

End Function

Private Function UserCount() As Integer

'Get a count of active 
'external sockets 
Dim n As Integer 
UserCount = 0 
'Iterate through sockets 
For n = 1 To Wsock.UBound 
'If the socted is ok (7) 
If Wsock(n).State = 7 Then 
'Increment UserCount value 
UserCount = UserCount + 1 
DoEvents 
End If 
Next

End Function

Private Sub Wsock_Error(Index As Integer, _ 
ByVal Number As Integer, _ 
Description As String, _ 
ByVal Scode As Long, _ 
ByVal Source As String, _ 
ByVal HelpFile As String, _ 
ByVal HelpContext As Long, _ 
CancelDisplay As Boolean)

'If the client disconnent is not clean then this event 
'will fire to handle socket/connection cleanup

If Number = 10053 Then 
'Set the connection stat as tGone 
CN(Index).State = tGone 
'Close the socket 
Wsock(Index).Close 
End If 
End Sub

Private Function ValidPassword(username As String, _ 
password As String)

'Validation for passed username and 
'password combination. 
'Usernames/Password should NOT be hard coded

If username = "username And password = "password" Then 
ValidPassword = True 
Else 
ValidPassword = False 
End If

End Function

« Prev.

1 | 2 | 3 | 4 |

Next »

No Comments for this page.

You Must be logged in or a member to comment.

	Tutorial Stats
12,247	Views
0	Total Comments
0	Rating of 5 ( Votes)

	Tutorial Options
· Login to Rate This Article
· Login to Post a Comment
· Read more by this author

	Related
· Getting Started with VB 6.0
· Using Crystal Reports in VB
Your Article Here

Coding a Webserver

The Log Server Code

Tutorial Stats

Tutorial Options

Related