Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
QB64PE Chat Server
#1
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.  Big Grin

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?
Reply
#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
#3
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.
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#4
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.  Tongue
Reply
#5
[Image: image.png]

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!  Big Grin

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.  Smile
Reply
#6
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?
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#7
Server and client have both now gotten one step smarter once again.  Smile

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.
Reply
#8
@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 Smile
grymmjack (gj!)
GitHubYouTube | Soundcloud | 16colo.rs
Reply
#9
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

Find my programs here in Dav's QB64 Corner
Reply
#10
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. Tongue

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".  Smile

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.
Reply




Users browsing this thread: 6 Guest(s)