Option Explicit
Private Const debuggo As Boolean = False
Private url As String
Private userson() As String
'Private sockettouser() As String
Private dataset As String
Private Const verstring As String = "VB2 messenger server v0.6"
Private x As Double
Private userdb(500, 1)
Private newestnick As String
Private timersocket As Double, timerdata As String
Private userdbcount As Double
Private Sub cmdoff_Click()
If (wsHTTP.State <> 0) Then
wsHTTP.Close
txtconnectips.Text = txtconnectips.Text & "Closing port: " & wsHTTP.LocalPort & vbCrLf
lblState = "Off."
Form2.Hide
End If
End Sub
Private Sub cmdOn_Click()
If (wsHTTP.State <> 2) Then
wsHTTP.LocalPort = 801
wsHTTP.Listen
txtconnectips.Text = txtconnectips.Text & "Listening to port: " & wsHTTP.LocalPort & vbCrLf & "Ammount of Sockets Ready: " & ws2.Count & vbCrLf
lblState = "Listening..."
Form2.Show
End If
End Sub
Private Sub Command1_Click()
Form2.Show
Form2.Move Form1.CurrentX + Form1.Width, 0
Form1.Move 0, 0
End Sub
Private Sub Command2_Click()
If (Not Val(txttimer.Text) = 0) Then
timershutdown.Interval = Val(txttimer.Text)
sendall ("0:SERVER: Server is shutting down in " & Val(txttimer.Text) & " seconds.")
timershutdown.Enabled = True
End If
End Sub
Private Sub Form_Load()
Dim temp As Double
'temp = Shell("stunnel-4.03.exe server.conf", vbNormalFocus)
'txtconnectips.Text = "Stunnel Initialized on port 802 (" & temp & ")" & vbCrLf
ReDim userson(1) As String
ReDim sockettouser(1) As String
lblstats.Caption = lblstats.Caption & wsHTTP.LocalHostName & vbCrLf
lblstats.Caption = lblstats.Caption & wsHTTP.LocalIP & vbCrLf
lblstats.Caption = lblstats.Caption & "Bytes Recieved: 0" & vbCrLf
Call getdb
wsHTTP.LocalPort = 801
txtconnectips.Text = txtconnectips.Text & "Listening to port: " & wsHTTP.LocalPort & vbCrLf & "Ammount of Sockets Ready: " & ws2.Count & vbCrLf
wsHTTP.Listen
lblState = "Listening..."
'x = ws2.LBound - 1
Form2.Show
Form2.Move Form1.CurrentX + Form1.Width, 0
Form1.Move 0, 0
'Form2.CurrentX =,form1.CurrentY
'Form2.CurrentY = Form1.CurrentY
End Sub
Function searchforuser(ByVal nick As String) As Double
Dim x As Double
Dim found As Boolean
For x = LBound(sockettouser) To UBound(sockettouser)
If (sockettouser(x) = nick) Then
found = True
searchforuser = x
End If
Next x
If found = False Then searchforuser = -1
End Function
Private Sub Form_Unload(Cancel As Integer)
Call TerminateTask("stunnel-4.03.exe")
End Sub
Private Sub sendslow_Timer()
Static x As Double
If x = 0 Then
x = 1
sendslow.Enabled = True
End If
If x = 2 Then
ws2(timersocket).SendData (timerdata)
x = 0
sendslow.Enabled = False
Else: x = x + 1
End If
End Sub
Private Sub TimeoutTimer_Timer()
Dim x As Integer
For x = ws2.LBound To ws2.UBound
If (ws2(x).State = 8) Then
Call disconnectuserwsocket(x)
ws2(x).Close
End If
Next x
End Sub
Private Sub Timer1_Timer(index As Integer)
Static x As Double
If x = 0 Then x = ws2.LBound
If (ws2(x).State = 7) Then
ws2(x).SendData dataset
End If
If (x + 1 < ws2.UBound) Then
If ws2(x + 1).State = 0 Then Timer1(index).Interval = 1
If ws2(x + 1).State = 7 Then Timer1(index).Interval = 25
End If
If x = ws2.UBound Then
x = ws2.LBound - 1
Timer1(index).Enabled = False
End If
x = x + 1
End Sub
Private Sub timernewnick_Timer()
sendall ("0:Server: " & newestnick & " has joined the conversation." & vbCrLf)
timernewnick.Enabled = False
End Sub
Private Sub timershutdown_Timer()
Call dbout
closeall ("Server closed")
Unload Form2
End
End Sub
Private Sub txtreqs_Change()
txtreqs.SelLength = 0
txtreqs.SelStart = Len(txtreqs)
End Sub
Private Sub ws2_DataArrival(index As Integer, ByVal bytesTotal As Long)
Dim blank As String
Dim temp As String
Dim nick As String
Dim identified As Boolean
ws2(index).GetData blank, "string"
Dim x As Double
If Mid(blank, 1, 1) = 8 And Mid(blank, 2, 1) = 0 And Mid(blank, 3, 1) = 1 And Mid(blank, 4, 1) = ":" Then
'outdated nick code
End If
If Mid(blank, 1, 4) = "500:" Then
'Code for Privmsg INC
identified = True
Dim incmsg() As String
Dim outgoingsocket As Double
Call explode(Mid(blank, 5), incmsg(), ":")
outgoingsocket = searchforuser(incmsg(1))
If (outgoingsocket = -1) Then
timersocket = index
timerdata = 599
Call sendslow_Timer
txtreqs.Text = txtreqs.Text & "599:" & incmsg(0) & "->" & incmsg(1) & vbCrLf
'sendall (399)
Else
'ws2(index).SendData ("301:" & incmsg(1) & ": " & incmsg(2) & vbCrLf)
timersocket = outgoingsocket
timerdata = "501:" & incmsg(0) & ":" & incmsg(1) & ": " & incmsg(2)
Call sendslow_Timer
txtreqs.Text = txtreqs.Text & "501/2:" & incmsg(0) & " sais to " & incmsg(1) & ": " & incmsg(2) & vbCrLf
End If
End If
If Mid(blank, 1, 1) = 4 And Mid(blank, 2, 1) = 0 And Mid(blank, 3, 1) = 0 And Mid(blank, 4, 1) = ":" Then
'Code for registering
identified = True
Dim incarray() As String, inc As String, alreadyused As Boolean
inc = Mid(blank, 5)
Call explode(inc, incarray(), ":")
For x = LBound(userdb, 1) To UBound(userdb, 1)
If (userdb(x, 0) = incarray(0)) Then
alreadyused = True
End If
Next x
If (Not alreadyused) Then
userdb(userdbcount, 0) = incarray(0)
userdb(userdbcount, 1) = incarray(1)
userdbcount = userdbcount + 1
Call dbout
ws2(index).SendData "401"
txtreqs.Text = txtreqs.Text & "(" & index & ")401: " & incarray(0) & vbCrLf
Else
ws2(index).SendData "402"
txtreqs.Text = txtreqs.Text & "(" & index & ")402: " & incarray(0) & vbCrLf
End If
End If
If Mid(blank, 1, 1) = 8 And Mid(blank, 2, 1) = 0 And Mid(blank, 3, 1) = 2 And Mid(blank, 4, 1) = ":" Then
identified = True
Dim incstr As String
incstr = Mid(blank, 5)
Dim userpw() As String
Call explode(incstr, userpw(), ":")
Dim xx As Double
Dim logged As Boolean
For xx = LBound(userdb, 1) To UBound(userdb, 1)
If (userpw(0) = userdb(xx, 0) And userpw(1) = userdb(xx, 1)) Then logged = True
Next xx
If (logged = True) Then
ws2(index).SendData "803"
txtreqs.Text = txtreqs.Text & "(" & index & ")803: " & userpw(0) & vbCrLf
nick = userpw(0)
newestnick = nick
timernewnick.Enabled = True
'sendall (nick & " has connected to the room." & vbCrLf)
sendall ("0:Server: " & nick & " has left the conversation." & vbCrLf)
For x = LBound(userson) To UBound(userson)
If (userson(x) = "") Then
userson(x) = nick
x = UBound(userson) + 1
End If
Next x
sockettouser(index) = nick
sendall ("1: " & implode(userson(), "ÿ") & vbCrLf)
ReDim Preserve userson(UBound(userson) + 1)
ReDim Preserve sockettouser(UBound(sockettouser) + 1)
Else
ws2(index).SendData "804"
txtreqs.Text = txtreqs.Text & "(" & index & ")804: " & userpw(0) & vbCrLf
End If
End If
If Mid(blank, 1, 1) = 3 And Mid(blank, 2, 1) = 0 And Mid(blank, 3, 1) = 1 And Mid(blank, 4, 1) = ":" Then
identified = True
Dim incmsg2() As String
Dim outgoingsocketset As Double
Call explode(Mid(blank, 5), incmsg2(), ":")
outgoingsocketset = searchforuser(incmsg2(1))
If (outgoingsocketset = -1) Then
timersocket = index
timerdata = 399
Call sendslow_Timer
txtreqs.Text = txtreqs.Text & "399:" & incmsg2(0) & "->" & incmsg2(1) & vbCrLf
'sendall (399)
Else
'ws2(index).SendData ("301:" & incmsg(1) & ": " & incmsg(2) & vbCrLf)
timersocket = outgoingsocketset
timerdata = "301:" & incmsg2(0) & ":" & incmsg2(1) & ": " & incmsg2(2) & vbCrLf
Call sendslow_Timer
txtreqs.Text = txtreqs.Text & "301/2:" & incmsg2(0) & " sais to " & incmsg2(1) & ": " & incmsg2(2) & vbCrLf
End If
End If
If (Mid(blank, 1, 1) = 0) Then
identified = True
Dim sendstring As String
sendstring = blank & vbCrLf
sendall (sendstring)
End If
If identified = False Then
txtreqs.Text = "CANT IDENTIFY! " & blank
End If
If debuggo Then
'debug code -->
txtreqs.Text = txtreqs & blank & vbCrLf
txtreqs.SetFocus
txtreqs.SelLength = 0
txtreqs.SelStart = Len(txtreqs.Text)
'<-- debug code
End If
End Sub
Function implode(ByRef data() As String, ByVal connectchar As String) As String
Dim x As Double
For x = LBound(data) To UBound(data)
If (data(x) <> "") Then implode = implode & data(x) & connectchar
Next x
End Function
Private Sub closeall(ByVal data As String)
Dim x As Double
For x = ws2.LBound To ws2.UBound
If (ws2(x).State = 7) Then
ws2(x).SendData data
ws2(x).Close
End If
Next x
End Sub
Private Sub ws2_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 (Number = 8 Or Number = 10053) Then
Call disconnectuserwsocket(index)
ws2(index).Close
Else
MsgBox Number & " " & Description
End If
End Sub
Private Sub ws2_SendComplete(index As Integer)
Static datarecievedbytes As Double
Static linkscompleted As Double
linkscompleted = linkscompleted + 1
datarecievedbytes = datarecievedbytes + ws2(index).BytesReceived
lblstats.Caption = ""
lblstats.Caption = lblstats.Caption & wsHTTP.LocalHostName & vbCrLf
lblstats.Caption = lblstats.Caption & wsHTTP.LocalIP & vbCrLf
lblstats.Caption = lblstats.Caption & "Bytes Recieved: " & datarecievedbytes & vbCrLf
lblstats.Caption = lblstats.Caption & "Completed Connections: " & linkscompleted & vbCrLf
End Sub
Private Sub wsHTTP_ConnectionRequest(ByVal requestID As Long)
Dim x As Double
For x = ws2.LBound To ws2.UBound
If (ws2(x).State = 0) Then
ws2(x).LocalPort = 80
ws2(x).Accept requestID
txtconnectips.Text = txtconnectips & ws2(x).RemoteHostIP & " (" & ws2(x).RemoteHost & ")" & " Connected on Socket " & x & vbCrLf
x = ws2.UBound + 1
End If
Next x
End Sub
Private Sub disconnectuserwsocket(ByVal index As Integer)
Dim nick As String
Dim x As Double
nick = sockettouser(index)
killslow.Enabled = True
killslow.Tag = nick
For x = LBound(userson) To UBound(userson)
If (userson(x) = nick) Then userson(x) = ""
Next x
sendall ("1: " & implode(userson(), "ÿ"))
End Sub
Private Sub sendall(ByVal data As String)
dataset = data
Dim x As Double
For x = Timer1.LBound To Timer1.UBound
If (Not Timer1(x).Enabled) Then
Timer1(x).Enabled = True
'txtconnectips.Text = txtconnectips & wsHTTP.RemoteHost & ":" & x
x = Timer1.UBound + 1
End If
Next x
txtreqs.Text = txtreqs.Text & data
End Sub
Private Sub explode(ByVal data As String, ByRef newarray() As String, ByVal explchar As String)
Dim x As Integer
Dim lastx As Integer
Dim usercount As Double
For x = 1 To Len(data)
If (Mid(data, x, 1) = explchar) Then
ReDim Preserve newarray(usercount)
newarray(usercount) = Mid(data, lastx + 1, x - lastx - 1)
lastx = x
usercount = usercount + 1
End If
Next x
End Sub
Private Sub getdb()
Dim nFileNumber As Integer
Dim sLine As String
Dim x As Double
Dim temparray() As String
nFileNumber = FreeFile()
Open "vbmsgDB.txt" For Input As #nFileNumber
Do While Not EOF(nFileNumber)
Line Input #nFileNumber, sLine
sLine = Mid(sLine, 2)
sLine = Mid(sLine, 1, Len(sLine) - 1)
Call explode(sLine, temparray(), ":")
userdb(x, 0) = temparray(0)
userdb(x, 1) = temparray(1)
x = x + 1
Loop
Close #nFileNumber
userdbcount = x
End Sub
Private Sub dbout()
Dim intnewfilenum As Integer, x As Double
intnewfilenum = FreeFile()
Open "vbmsgDB.txt" For Output As #intnewfilenum
For x = 0 To userdbcount - 1
Write #intnewfilenum, userdb(x, 0) & ":" & userdb(x, 1) & ":"
Next x
Close #intnewfilenum
End Sub