Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
QB64PE Chat Server
#2
And, for those that are interested, here's the current HOST for the chat program:

Code: (Select All)
OPTION _EXPLICIT

CONST Port = "7319", IP = "172.93.60.23"
CONST FullPort = "TCP/IP:" + Port
CONST FullIP = FullPort + ":" + IP
CONST SaveFile = "Chat History.log"


TYPE User_type
name AS STRING * 10
handle AS LONG
last_active AS _FLOAT
END TYPE

DIM SHARED AS LONG NumClients 'up to 1000 connections
DIM SHARED AS User_type users(1000)
DIM AS LONG host, i
DIM AS STRING recieved, ChatLog

OpenHost host 'start the hosting program
OPEN SaveFile FOR BINARY AS #123
ChatLog = SPACE$(LOF(123))
GET #123, 1, ChatLog ' get the old chat's history.


DO ' main program loop
AddNewClient host ' now we've checked for any new clients
ValidateClients ' and we've validated that everyone is still connected
FOR i = 1 TO NumClients
IF _CONNECTED(users(i).handle) = 0 THEN _CONTINUE 'we don't have to get or send data to someone disconnected
recieved$ = GetMessage(users(i).handle)
IF recieved$ <> "" THEN ' we got something from the client
Processmessage recieved, i ' process it and do whatever we need to
_DELAY .05 'a fragment of a second so we will hopefully not "merge" messages.
END IF
NEXT
_LIMIT 30
LOOP

SUB Processmessage (msg AS STRING, client AS LONG)
DIM AS LONG p, i
DIM AS STRING cmd, tmp, broadcast
SHARED ChatLog AS STRING
IF msg = "" THEN EXIT SUB
tmp = msg 'if there's no command string, it's just text to send and chat with.

'first, look for a command string
IF LEFT$(msg, 1) = "/" THEN 'all command strings start with a slash
p = INSTR(msg, ":")
IF p THEN 'we have what should be a command delimiter ("/name:" or "/msg:", ect)
cmd = MID$(msg, 2, p - 2) 'the command should now be delimited
tmp = MID$(msg, p + 1) 'and whatever we do with the command should be left over
END IF
END IF

SELECT CASE _TRIM$(UCASE$(cmd$))
CASE "USERLIST" 'get current list of user's online
tmp = "Current Users Online"
FOR i = 2 TO NumClients
IF _TRIM$(users(i).name) <> "" THEN tmp = tmp + " -- " + users(i).name
NEXT
SendMessage client, tmp
PRINT "SENT -->"; tmp
CASE "NAME" 'change name
IF users(client).name = SPACE$(10) THEN
broadcast = tmp + " has entered the chat!"
ELSE
broadcast = _TRIM$(users(client).name) + " has been changed to " + tmp
END IF
users(client).name = tmp

CASE "MSG" 'private message
'tmp here contains both who and what we want to say
CASE "PING" 'client should send a ping response every few minutes so we know it's active.
users(client).last_active = ExtendedTimer 'update activity timer
SendMessage client, "/PING:" 'respond to let it know we're still alive as well
CASE "QUIT", "EXIT"
CLOSE users(client).handle
broadcast = _TRIM$(users(client).name) + " disconnected."
FOR i = client TO NumClients - 1
users(i).handle = users(i + 1).handle
users(i).name = users(i + 1).name
users(i).last_active = users(i + 1).last_active
NEXT
NumClients = NumClients - 1
CASE "" 'there was no command
broadcast = LEFT$(_TRIM$(users(client).name) + ": " + msg, 65535)
CASE ELSE 'unrecognized command
SendMessage client, _TRIM$(users(0).name) + ": Command Not Recognized"
END SELECT

IF broadcast <> "" THEN 'we need to send a message to all clients
PRINT broadcast
FOR i = 1 TO NumClients
SendMessage i, broadcast
NEXT
broadcast = broadcast + CHR$(10)
PUT #123, , broadcast
ChatLog = ChatLog + broadcast
broadcast = "" 'clear the broadcast message after sending it
END IF
msg = ""
END SUB

SUB SendMessage (client AS LONG, msg AS STRING)
DIM AS STRING temp
DIM AS _UNSIGNED INTEGER i
msg = LEFT$(msg, 65535) 'make certain our message fits the limits for this little program.
i = LEN(msg)
IF i = 0 THEN EXIT SUB 'don't bother sending blank messages.
temp = MKI$(i) + msg
PUT #users(client).handle, , temp
END SUB




FUNCTION GetMessage$ (client AS LONG)
DIM AS _UNSIGNED INTEGER i
DIM AS STRING recieved
GET #client, , i
recieved = SPACE$(i)
GET #client, , recieved
GetMessage = recieved
END FUNCTION



SUB OpenHost (host AS LONG)
DIM AS STRING myname
_TITLE "Steve Mini Messanger Host"
host = _OPENHOST(FullPort) 'port on Steve's laptop which is going to host the chat server
IF host THEN
PRINT "[Beginning new host chat session!]"
NumClients = 0 'client 0 is the host itself, so it can also be used as a client
users(0).handle = _OPENCLIENT(FullIP)
IF users(0).handle = 0 THEN PRINT "ERROR: could not attach host's personal client to host!"
'Input "Enter your name:", myname$ 'to custom server feedback
myname$ = "[HOST]" ' which I don't personally care to do each time I start the host
PRINT "[Chat session active! Connected to server as ["; myname$; "]"
ELSE
PRINT "ERROR: Could not begin new host!"
PRINT "Diagnose firewall, port forwarding, and other issues, and then try again later."
END
END IF ' host
END SUB


SUB AddNewClient (host AS LONG)
DIM AS LONG newclient, l
SHARED AS STRING ChatLog
newclient = _OPENCONNECTION(host) ' receive any new connection
IF newclient THEN
NumClients = NumClients + 1
users(NumClients).handle = newclient
users(NumClients).name = "" 'make certain to blank name until the /name command comes in to set it
users(NumClients).last_active = ExtendedTimer
IF NumClients > 1 THEN 'the server doesn't need the log itself
l = LEN(ChatLog)
PRINT "LOG SENT -- Length"; l, NumClients
PUT #newclient, , l

_DELAY .05
PUT #newclient, , ChatLog
END IF
END IF
END SUB


SUB ValidateClients
DIM AS LONG i, clientcheck
DIM AS STRING disconnectmessage
clientcheck = 2 'skip 1 as it would always be the hosts client-connection to itself
DO UNTIL clientcheck > NumClients
IF ExtendedTimer - users(clientcheck).last_active > 300 THEN '300 seconds of inactivity
disconnectmessage = _TRIM$(users(clientcheck).name) + " disconnected."
PRINT disconnectmessage
FOR i = 1 TO NumClients
SendMessage i, disconnectmessage
NEXT
CLOSE users(clientcheck).handle
FOR i = clientcheck TO NumClients - 1
users(i).handle = users(i + 1).handle
users(i).name = users(i + 1).name
users(i).last_active = users(i + 1).last_active
NEXT
NumClients = NumClients - 1
ELSE
clientcheck = clientcheck + 1
END IF
LOOP
END SUB

FUNCTION ExtendedTimer##
'Simplified version of the TimeStamp routine, streamlined to only give positive values based on the current timer.
'Note: Only good until the year 2100, as we don't do all the fancy calculations for leap years.
'A timer should work quickly and efficiently in the background; and the less we do, the less lag we might insert
'into a program.

DIM m AS INTEGER, d AS INTEGER, y AS INTEGER
DIM s AS _FLOAT, day AS STRING
day = DATE$
m = VAL(LEFT$(day, 2))
d = VAL(MID$(day, 4, 2))
y = VAL(RIGHT$(day, 4)) - 1970
SELECT CASE m 'Add the number of days for each previous month passed
CASE 2: d = d + 31
CASE 3: d = d + 59
CASE 4: d = d + 90
CASE 5: d = d + 120
CASE 6: d = d + 151
CASE 7: d = d + 181
CASE 8: d = d + 212
CASE 9: d = d + 243
CASE 10: d = d + 273
CASE 11: d = d + 304
CASE 12: d = d + 334
END SELECT
IF (y MOD 4) = 2 AND m > 2 THEN d = d + 1 'add a day if this is leap year and we're past february
d = (d - 1) + 365 * y 'current month days passed + 365 days per each standard year
d = d + (y + 2) \ 4 'add in days for leap years passed
s = d * 24 * 60 * 60 'Seconds are days * 24 hours * 60 minutes * 60 seconds
ExtendedTimer## = (s + TIMER)
END FUNCTION
Reply


Messages In This Thread
QB64PE Chat Server - by SMcNeill - 05-29-2024, 03:39 PM
RE: QB64PE Chat Server - by SMcNeill - 05-29-2024, 11:15 PM
RE: QB64PE Chat Server - by PhilOfPerth - 05-29-2024, 11:27 PM
RE: QB64PE Chat Server - by SMcNeill - 05-29-2024, 11:39 PM
RE: QB64PE Chat Server - by SMcNeill - 05-30-2024, 03:08 AM
RE: QB64PE Chat Server - by PhilOfPerth - 05-30-2024, 05:31 AM
RE: QB64PE Chat Server - by SMcNeill - 05-30-2024, 11:08 AM
RE: QB64PE Chat Server - by grymmjack - 05-30-2024, 11:52 AM
RE: QB64PE Chat Server - by Dav - 05-30-2024, 07:35 PM
RE: QB64PE Chat Server - by TerryRitchie - 05-30-2024, 10:30 PM
RE: QB64PE Chat Server - by SMcNeill - 05-30-2024, 10:33 PM
RE: QB64PE Chat Server - by SMcNeill - 05-30-2024, 07:40 PM
RE: QB64PE Chat Server - by PhilOfPerth - 05-30-2024, 11:36 PM
RE: QB64PE Chat Server - by Dav - 06-02-2024, 05:59 PM
RE: QB64PE Chat Server - by SMcNeill - 06-05-2024, 12:08 PM
RE: QB64PE Chat Server - by Kernelpanic - 06-05-2024, 03:02 PM
RE: QB64PE Chat Server - by madscijr - 06-05-2024, 06:45 PM
RE: QB64PE Chat Server - by Dav - 06-06-2024, 12:13 PM
RE: QB64PE Chat Server - by madscijr - 06-06-2024, 01:01 PM
RE: QB64PE Chat Server - by SMcNeill - 06-05-2024, 09:42 PM
RE: QB64PE Chat Server - by madscijr - 06-05-2024, 11:49 PM
RE: QB64PE Chat Server - by SMcNeill - 06-06-2024, 12:41 AM
RE: QB64PE Chat Server - by Kernelpanic - 06-07-2024, 11:40 PM
RE: QB64PE Chat Server - by SMcNeill - 06-08-2024, 12:47 AM
RE: QB64PE Chat Server - by SMcNeill - 06-08-2024, 03:08 PM
RE: QB64PE Chat Server - by Kernelpanic - 06-08-2024, 06:35 PM



Users browsing this thread: 21 Guest(s)