QB64PE Chat Server

[SMcNeill]

A work-in-progress, but it's now to the point that it does the very barest of TCP/IP communication back and forth across the internet.

For those that are brave, you might give this a shot and see how badly it glitches out on you. 

Code: (Select All)

OPTION _EXPLICIT

$COLOR:32



CONST Port = "7319", IP = "172.93.60.23"

CONST FullPort = "TCP/IP:" + Port

CONST FullIP = FullPort + ":" + IP



DIM SHARED AS LONG client 'up to 1000 connections

DIM AS STRING recieved

DIM SHARED AS STRING nam

DIM SHARED AS LONG MainDisplay, TextArea, InputArea

DIM SHARED AS _FLOAT NextPing, server_active

DIM SHARED AS _BYTE TimeStamp 'toggle type display variables

DIM SHARED AS _UNSIGNED LONG DefaultColor, AudibleAlert



DIM ChatLen AS LONG, ChatLog AS STRING, tempString AS STRING



MainDisplay = _NEWIMAGE(1280, 720, 32)

TextArea = _NEWIMAGE(1280, 600, 32)

InputArea = _NEWIMAGE(1280, 120, 32)

DefaultColor = White

TimeStamp = -1

AudibleAlert = -1



SCREEN MainDisplay



client = _OPENCLIENT(FullIP)

IF client THEN

    PRINT "Connected to Steve's Chat!"

    server_active = ExtendedTimer + 300 'server is now counted as being "active" for the next 5 minutes

    GET #client, , ChatLen

    ChatLog = SPACE$(ChatLen)

    DO

        GET #client, , tempString

        ChatLog = ChatLog + tempString

        _LIMIT 30

    LOOP UNTIL LEN(ChatLog) >= ChatLen



    INPUT "Enter your name =>"; nam

    SendMessage "/NAME:" + nam

    _KEYCLEAR 'clear the input buffer, Steve, you big idiot!

    '_KEYHIT will still hold the name in that buffer as it's independent to INPUT!



    CLS

    PRINT ChatLog



    NextPing = ExtendedTimer

    DO '                                                      main program loop

        recieved$ = GetMessage

        ProcessInput recieved$ '                      deal with any server command type messages

        IF recieved$ <> "" THEN '                          we got something from the clien

            _DEST TextArea

            IF TimeStamp THEN COLOR Yellow: PRINT "[" + TIME$ + "]  ";: COLOR DefaultColor

            PRINT recieved$ '                              it should just be a message of some sort

        END IF

        InputJunk



        IF ExtendedTimer > NextPing THEN 'send a message to the server that we're still active

            SendMessage "/PING:" '        that message is a simple PING

            NextPing = ExtendedTimer + 30 'and send this every 30 seconds so we don't disconnect.

        END IF



        IF ExtendedTimer > server_active THEN

            PRINT: PRINT "Sorry.  It appears the server has went offline."

            PRINT "We are now terminating this chat client."

            PRINT: PRINT "Please try back again later."

            _DELAY 2: _KEYCLEAR: SLEEP: SYSTEM

        END IF



        CLS , 0, MainDisplay

        _PUTIMAGE (0, 600)-(1279, 719), InputArea, MainDisplay

        _PUTIMAGE (0, 0)-(1279, 599), TextArea, MainDisplay



        _DISPLAY

        _LIMIT 30

    LOOP

ELSE

    PRINT "Sorry.  Could not connect at this time."

    PRINT "Check Firewall, port forwarding, or other internet TCP/IP blockades."

    END

END IF



SUB ProcessInput (what AS STRING)

    SELECT CASE what

        CASE "/PING:" 'the server send us back a /PING response

            server_active = ExtendedTimer + 300

            what = ""

    END SELECT

    IF AudibleAlert _ANDALSO RIGHT$(what, 22) = " has entered the chat!" THEN BEEP

END SUB





SUB InputJunk

    DIM AS LONG k

    DIM AS STRING temp

    STATIC send$

    _DEST InputArea

    CLS , LightGray

    k = _KEYHIT

    SELECT CASE k

        CASE ASC("v"), ASC("V")

            IF _KEYDOWN(100306) OR _KEYDOWN(100305) THEN

                send$ = send$ + _CLIPBOARD$

            ELSE

                send$ = send$ + CHR$(k)

            END IF

        CASE 32 TO 255

            send$ = send$ + CHR$(k)

        CASE 8

            send$ = LEFT$(send$, LEN(send$) - 1)

        CASE 13

            'do some client side command handling, in case we change some local settings ourselves.

            temp = _TRIM$(send$)

            IF UCASE$(LEFT$(temp, 6)) = "/NAME:" THEN

                nam$ = LEFT$(MID$(temp$, 7), 10)

                send$ = "/NAME:" + nam$

            END IF

            IF UCASE$(LEFT$(temp, 12)) = "/TIMESTAMPS:" THEN

                send$ = ""

                temp$ = UCASE$(_TRIM$(MID$(temp$, 13)))

                IF TimeStamp = 0 THEN

                    IF temp$ = "ON" THEN TimeStamp = -1: SystemMessage "Timestamps are now ON."

                ELSE

                    IF temp$ = "OFF" THEN TimeStamp = 0: SystemMessage "Timestamps are now OFF."

                END IF

                EXIT SUB

            END IF

            IF UCASE$(LEFT$(temp, 7)) = "/ALERT:" THEN

                send$ = ""

                temp$ = UCASE$(_TRIM$(MID$(temp$, 8)))

                IF AudibleAlert = 0 THEN

                    IF temp$ = "ON" THEN AudibleAlert = -1: SystemMessage "Audible Alerts are now ON, for when people join the server."

                ELSE

                    IF temp$ = "OFF" THEN AudibleAlert = 0: SystemMessage "Audible Alerts are now OFF, for when people join the server."

                END IF

                EXIT SUB

            END IF



            SELECT CASE UCASE$(temp)

                CASE "/QUIT", "EXIT", "/QUIT:", "/EXIT:"

                    SendMessage "/EXIT:"

                    SYSTEM

                CASE "/USERS", "/USER", "/LIST", "/USERS:", "/USER:", "/LIST:", "/USERLIST", _

                        "/USERSLIST", "/USERLIST:", "/USERSLISTS:"

                    SendMessage "/USERLIST:"

                    send$ = ""

            END SELECT

            IF send$ <> "" THEN SendMessage send$

            send$ = ""

    END SELECT

    IF TimeStamp THEN COLOR Yellow: PRINT "[" + TIME$ + "]  ";: COLOR DefaultColor

    PRINT nam + ": " + send$ + " (" + STR$(LEN(send$)) + "/65500)"

    _DEST TextArea

    IF _EXIT THEN

        SendMessage "/EXIT:"

        SYSTEM

    END IF

END SUB



SUB SystemMessage (sysmes AS STRING)

    _DEST TextArea

    COLOR Yellow

    PRINT sysmes

    COLOR DefaultColor

    _DEST InputArea

END SUB



SUB SendMessage (msg AS STRING)

    DIM AS STRING temp

    DIM AS _UNSIGNED INTEGER i

    msg = LEFT$(msg, 65535)

    i = LEN(msg)

    IF i = 0 THEN EXIT SUB 'don't bother sending blank messages.

    temp = MKI$(i) + msg

    PUT client, , temp

    _DELAY .1 'wait a moment before we return to get/send more messages

    msg = "" 'reset to blank after we send it

END SUB



FUNCTION GetMessage$

    DIM AS _UNSIGNED _BYTE b

    DIM AS _UNSIGNED INTEGER i

    DIM AS STRING recieved

    GET #client, , i

    recieved = SPACE$(i)

    GET #client, , recieved

    GetMessage = recieved

END FUNCTION





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

I'll leave the host up and running all day, but I may not be around the whole time to chat or interact with anyone, and I don't guarantee that the server won't explode spontaniously and die a horrible death.  But, at the moment, it seems stable with an client base of ONE person testing it.  LOL!!

Okies... now I have TWO people testing it -- Steve and Steve2!  Yay!!

Anyone want to take bets on how long it takes before this simple chat dies and has to be rebooted and restarted?

[SMcNeill]

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

[PhilOfPerth]

For what it's worth, I may have beaten your last update, but I sent a "hi", then waited a couple minutes and closed,
then came back, and it locked up.

[SMcNeill]

Give it a shot now, if you want, @PhillOfPerth 
It's all up and running smoothly ATM, from what I can tell.   

....from what I can tell. 

[SMcNeill]

As you guys can see, if you click on the image above and expand it, things do appear to be working...  The only problem is everyone is passing each other like ships in the night! 

Most folks are now in bed, or wrappped up watching Netflix or some such, and there's just nobody staying active in the channel to send messages to each other.  Maybe there'll be some more of us around tomorrow to give things a nice push and chatter with each other for a bit. 

[PhilOfPerth]

I just tried again, and left myself logged in for about an hour, to try to get a response, but on return I found I had been disconnected - presumably timed out.
Maybe I need to move to NJ or somewhere closer to the action?

[SMcNeill]

Server and client have both now gotten one step smarter once again. 

Now we're acting more like a proper server/client and sending /PING back and forth to each other every 30 seconds.  If either side goes more than 5 minutes without recieving that /PING from the other, it'll assume that particular connection has died and will proceed to close things out properly for us.

In other words, we should no longer "time out" just for being inactive.  Folks can now open a client, connect, and stay online for as long as they want, and the client/host will gently remind each other every little bit that they're still alive.  (At least, until one side isn't any longer, in which case THEN we time out.)

Folks can feel free to grab and compile the code in the first post in this topic if they want -- it's now the latest version client which I have available. Hopefully, the server will now hang around all day long, without timing itself out (or others), just for it being quiet for too long.

[grymmjack]

@SMcNeill can you put this into GitHub?

Also, this is fun. It was nice talking to you and ultraman this AM.

Keep up the great work

[Dav]

I never realized until studying this code that CLS can use an image.handle.  That's neat. 

Chat works fine the few times I've connected. 

- Dav

[SMcNeill]

We now have Timestamps enabled for the client.  You can now lurk, come back an hour later, and then see how much you missed someone else by.

Also added in the first real client-side commands, so folks can now start to DO things to change the client a little bit.  At the moment, we now have:

/NAME:newname
/QUIT
/EXIT
/TIMESTAMPS:ON|OFF
/ALERT:ON|OFF

Not a lot of options for folks to tweak or play around with, but what do you expect from a chat client that's all of what?  Two days old now?  There's still a reason this is flagged "Work-In-Progress". 

Edit: And we now have audible alerts (just a simple BEEP) for when someone new logs into the chat client, and this setting can be toggled on/off with the new /ALERT: command, for anyone interested. Default is starting in the ON state.