' Global variables loaded from arguments or configuration
Dim listenPort
listenPort = 8118 ' Defaults
serverPassword = "SrvPass"
sleepTime = 200
maxMsgLen = 4096

' Overridable functions

' On Success: Returns the User Name
' On Failure: Returns empty string
' Currently a single server password is used but this function can be changed to use some database
Function AuthenticateUser(ByVal user, ByVal password, socket, cons)
	On Error Resume Next
	AuthenticateUser = ""
	If Trim(password) = serverPassword And Trim(user) <> ""	Then AuthenticateUser = user
End Function


' Implementation

Set sf = CreateObject("newObjects.utilctls.SFMain")
Set Sleeper = CreateObject("newObjects.utilctls.COMSleeper")
Set NSMain = CreateObject("newObjects.net.NSMain")
Set varDict = CreateObject("newObjects.utilctls.varDictionary")
varDict.itemsAssignmentAllowed = True
varDict.enumItems = True
varDict.allowUnnamedValues = True
varDict.allowDuplicateNames = True

Function Max(x,y)
	Max = x
	If y > x Then Max = y
End Function
Function Min(x, y)
	Min = x
	If y < x Then Min = y
End Function

Sub Msg(s)
	WScript.Echo s
End Sub

' s - Socket, strm - stream to send
Function NewConnection(s)
	Dim o
	Set o = varDict.CreateNew
	o.Add "Socket", s
	Dim strm
	Set strm = CreateObject("newObjects.utilctls.SFStream")
	strm.SetStream s
	o.Add "Stream", strm
	o.Add "Msg",""
	o.Add "Authenticated", False
	o.Add "User", ""
	SendMessage o, "Enter   and press enter."
	Set NewConnection = o
End Function


Function GetMessageFromBuff(s)
	Dim nCr,r
	nCr = Max(InStr(s,vbCr),InStr(s,vbLf))
	If nCr > 0 Then
		r = Left(s,nCr)
		s = Mid(s,nCr + 1)
		nCr = Min(InStr(r,vbCr),InStr(r,vbLf)) - 1
		GetMessageFromBuff = Left(r,nCr)
	Else
		GetMessageFromBuff = ""
	End If
End Function

Sub ReadIncomingData(src,cons)
	On Error Resume Next
	Dim t, itm, arr
	Dim state
	Dim iters
	iters = 0
	
	Do
		state = src("Socket").Select
		If state And &H04 Then
			t = src("Stream").ReadText(256)
			If Err.Number <> 0 Then
				t = ""
				Exit Do
			End If
			If t = "" Then Exit Do
			src("Msg") = src("Msg") & t
			If iters > 1000 Then
				Msg "DEBUG: Over 1000 attempts to read incoming data on the same socket!"
				Exit Do
			End If
			' Size check
			If Len(src("Msg")) > maxMsgLen Then
				Msg "DEBUG: Message buffer full! Forcing send."
				src("Msg") = src("Msg") & vbCrLf
		  	    Exit Do
			End If
		Else
			Exit Do
		End If
		iters = iters + 1
	Loop
	
	Dim sTemp
	sTemp = src("Msg")
	t = GetMessageFromBuff(sTemp)
	src("Msg") = sTemp
		  		
	If t <> "" Then
		If Not src("Authenticated") Then
			' Try to authenticate
			arr = Split(t," ")
			If IsArray(arr) And UBound(arr) = 1 Then
				Msg "Authenticating " & t & " User=[" & arr(0) & "] Pass=[" & arr(1) & "]"
				
				Dim usr
				usr = AuthenticateUser(arr(0),arr(1),src("Socket"), cons)
				
				If usr <> "" Then
					src("Authenticated") = True
					src("User") = usr
					Msg "User " & usr & " from " & src("Socket").PeerAddress.TextAddress & " Authenticated"
					t = ""
					SendHelp src
					BroadcastMessage "#Server: " & src("User") & " logged in. Total users: " & cons.Count, cons
				Else
					src("Stream").WriteText "Invalid password", 1
					Msg "User " & arr(0) & " from " & src("Socket").PeerAddress.TextAddress & " failed to authentcate"
		  		src("Socket").Close		  	
				End If
		  Else
		  	Msg "User from " & src("Socket").PeerAddress.TextAddress & " invalid syntax"
		  	src("Stream").WriteText "Please input: username password", 1
		  	src("Socket").Close		  	
			End If	
		End If
	End If
	
	If src("Authenticated") And t <> "" Then
		If Left(t,1) = "#" Then
			' A command
			t = Mid(t,2)
			arr = Split(t," ")
			If IsArray(arr) And UBound(arr) >= 0 Then
				Select Case UCase(arr(0))
					Case "U"
						t = ""
						For I = 1 To cons.Count
							t = t & cons(I)("User") & " "
						Next
						SendMessage src, t
					Case "X"
						BroadcastMessage "User " & src("User") & " is exiting", cons
						src("Socket").Close
					Case "L"
						t = ""
						For I = 1 To cons.Count
							t = t & cons(I)("User") & " (" & cons(I)("Socket").PeerAddress.TextAddress & ")" & vbCrLf
						Next
						SendMessage src, t
					Case "P"
					  If UBound(arr) >= 1 Then
					  	For I = 1 To cons.Count
					  		If cons(I)("User") = Trim(arr(1)) Then
					  			SendMessage cons(I), src("User") & " to " & Mid(t,3)
					  		End If
					  	Next
						Else
							SendMessage src, "Error: Please spcify username (#P User )"
						End If
						t = ""
					Case Else
						SendMessage src, "#Server: Unrecognized command"
						SendHelp src
				End Select
			End If
		Else
			' Translate the message
			Msg "Spreading from " & src("User") & ": " & t
			For Each itm in cons
			  state = itm("Socket").Select
			  If CBool(state And &H02) And (Not (src Is itm)) And itm("Authenticated") Then
			  	Err.Clear
					itm("Stream").WriteText src("User") & ": " & t, 1
					If Err.Number <> 0 Then itm("Socket").Close
				End If
			Next
	  End If
	End If
End Sub

Sub BroadcastMessage(s,cons)
	On Error Resume Next
	Msg "Broadcasting: " & s
	For Each itm in cons
	  state = itm("Socket").Select
	  If CBool(state And &H02) And itm("Authenticated") Then
	  	Err.Clear
			itm("Stream").WriteText s, 1
			If Err.Number <> 0 Then itm("Socket").Close
		End If
	Next
End Sub
Sub SendMessage(s,m)
	On Error Resume Next
	Msg "Sending to " & s("User") & ": " & m
	state = s("Socket").Select
	If state And &H02 Then
		Err.Clear
		s("Stream").WriteText m, 1
		If Err.Number <> 0 Then s("Socket").Close
	End If
End Sub

Sub SendHelp(src)
    SendMessage src, "#Server: Valid commands are:"
    SendMessage src, "#Server: #U   - Lists all the current users"
	SendMessage src, "#Server: #L   - Lists all the current users with their addresses"
	SendMessage src, "#Server: #X   - Exit"
	SendMessage src, "#Server: Any input not starting with # will be sent to all the connected users."
End Sub

Sub Main

	Dim b ' Helper variables
	Dim listener, bindAddress ' Sockets and dispatchers

	Msg "Creating listening socket ..."
	Set listener = NSMain.NewSocket
	listener.Blocking = False
	b = listener.Socket("AF_INET","SOCK_STREAM","IPPROTO_TCP")
	If Not b Then
      Msg "Cannot initialize the listener: " & listener.LastError
      Exit Sub
  End If
  
  Msg "Determining the listen address ..."
  Set bindAddress = NSMain.NewAddress
  bindAddress.AddressFamilyName = "AF_INET"
  bindAddress.Port = listenPort
  bindAddress.TextAddress = "0.0.0.0"
  
  Msg "Binding to 0.0.0.0:" & listenPort
  b = listener.Bind(bindAddress)
  If Not b Then
      Msg "Cannot listen on port " & listenPort
      Msg "Error: " & listener.LastError
      Exit Sub
  End If
  
  Msg "Starting to listen for connections ..."
  b = listener.Listen
  If Not b Then
    Msg "Cannot listen: " & listener.LastError
    Exit Sub
  End If

	Dim c ' A new connection
	Dim cons ' The accepted connections
	Dim state, I

	Set cons = varDict.CreateNew

  Do
  	' Msg "  Checking listener"
  	state = listener.Select
  	
  	If state And &H04 Then
  		' New connection
  		Set c = listener.Accept
  		Msg "Accepted new connection from " & c.PeerAddress.TextAddress
  		cons.Add "", NewConnection(c)
  		Msg "Connections: " & cons.Count
  	End If

	' Look for errors
	' Msg "  Looking for errors"
	For I = cons.Count To 1 Step -1
		If Not cons(I)("Socket").Valid Then
			Msg "Disconnecting " & cons(I)("User")
		  cons.Remove I
		Else
			On Error Resume Next
			state = cons(I)("Socket").Select
			If state And &H01 Or Err.Number <> 0 Then
				Msg "Disconnecting " & cons(I)("User")
				cons.Remove I
			End If
			On Error GoTo 0
	  End If
	Next
  	
  	' Cycle through the connections to see if there is anything to read
  	' Msg "  Spread data"
  	On Error Resume Next
  	For Each c In cons
  		Err.Clear
  	  If c("Socket").Valid Then
	  		state = c("Socket").Select
	  		If Err.Number <> 0 Then state = 0 ' Skip the cycle
	  		If state And &H04 Then
	  			' Data can be read
	  			ReadIncomingData c, cons
	  		End If
	    End If
  	Next
  	Sleeper.Sleep(sleepTime)
  	' Msg "Connections: " & cons.Count
  Loop
End Sub