QBJS - Web Chat

[dbox]

You guys inspired me.  I saw all of the recent chat server posts and wondered how hard it would be to create a web chat client in QBJS.  For anyone interested you can try out the end result here:

QB Web Chat

The server is written in QB64.  I used luke's simple HTTP server as a starting point and modified it to be an HTTP chat server.  Here is the server code in case you want to play around with it:

Code: (Select All)

' QB Chat Server
' Author: dbox*
' *This originally started as luke's simple HTTP server.
' It has been modified to serve as an HTTP chat server.
' Here is the original source attribution:
' -------------------------------------------------------------------------------------
' HTTP 1.1 Compliant Web Server
' Author: luke
' Source: https://www.qb64.org/forum/index.php?topic=2052.0
' This program is made available for you to use, modify and distribute it as you wish,
' all under the condition you do not claim original authorship.
' -------------------------------------------------------------------------------------
$Console:Only
Option _Explicit
DefLng A-Z

Const MAX_CONNECTIONS = 8
Dim PORT As Integer: PORT = 8080
If _CommandCount > 0 Then
    PORT = Val(Command$(1))
End If

Const FALSE = 0
Const TRUE = -1
Dim Shared CRLF As String
CRLF = Chr$(13) + Chr$(10)
Const HTTP_10 = 1
Const HTTP_11 = 11
Const HTTP_GET = 1
Const HTTP_HEAD = 2
Const HTTP_POST = 3
Type connection_t
    handle As Long
    read_buf As String
    http_version As Integer
    method As Integer
    request_uri As String
    content_length As Integer
End Type

Type http_error_t
    code As Integer
    message As String
    connection As Integer
End Type

Type file_error_t
    failed As Integer
    code As Integer
End Type

Dim i
Dim num_active_connections
Dim server_handle
Dim Shared Connections(1 To MAX_CONNECTIONS) As connection_t
Dim Shared Http_error_info As http_error_t
Dim Shared File_error_info As file_error_t

'---------------------------------------------------------------------
' Chat server-specific initialization
'---------------------------------------------------------------------
Type Message
    sender As String
    message As String
    time As String
End Type

Const MAX_MESSAGE = 100
Dim Shared messages(MAX_MESSAGE) As Message
Dim Shared cmsg As _Unsigned Long
cmsg = 0

Open "chatlog.txt" For Append As #1
'---------------------------------------------------------------------

On Error GoTo error_handler

server_handle = _OpenHost("TCP/IP:" + LTrim$(Str$(PORT)))
Print "Listening on port:" + Str$(PORT)
Do
    If num_active_connections < MAX_CONNECTIONS Then
        Dim new_connection
        new_connection = _OpenConnection(server_handle)
        If new_connection Then
            num_active_connections = num_active_connections + 1
            For i = 1 To MAX_CONNECTIONS
                If Connections(i).handle = 0 Then
                    Dim empty_connection As connection_t
                    Connections(i) = empty_connection
                    Connections(i).handle = new_connection
                    num_active_connections = num_active_connections - 1
                    Exit For
                End If
            Next i
        End If
    End If

    For i = 1 To MAX_CONNECTIONS
        If Connections(i).handle Then
            Dim buf$
            Get #Connections(i).handle, , buf$
            If buf$ <> "" Then
                ' This is a bit of a hack workaround.
                ' We have no gaurantee that the sent message will not be fragmented.
                ' So there's a chance the full message will not be sent all at once.
                ' Unfortunately, there's no way I know of to tell from the connection
                ' if there is more to read.
                ' Hence, we sleep for .05 seconds and try to read from the connection again.
                ' We'll repeat this as long as we keep reading content.
                ' Will this ensure we read the entire body content?
                ' No, but it seems to work for most cases.
                While buf$ <> ""
                    Connections(i).read_buf = Connections(i).read_buf + buf$
                    _Delay .05
                    Get #Connections(i).handle, , buf$
                Wend
                process_request i
                http_error_complete:
            End If
        End If
    Next i
    _Limit 240
Loop



error_handler:
If Err = 100 Then 'HTTP error
    'Print "HTTP error"; Http_error_info.code; Http_error_info.message; " for connection"; Http_error_info.connection
    Resume http_error_complete
End If
'Print "error"; Err; "on line"; _ErrorLine
End

file_error_handleyour:
File_error_info.failed = TRUE
File_error_info.code = Err
Resume Next

Sub http_send_status (c, code, message As String)
    Dim s$
    s$ = "HTTP/1.1" + Str$(code) + " " + message + CRLF
    Put #Connections(c).handle, , s$
End Sub

Sub http_send_header (c, header As String, value As String)
    Dim s$
    s$ = header + ": " + value + CRLF
    Put #Connections(c).handle, , s$
End Sub

Sub http_end_headers (c)
    Put #Connections(c).handle, , CRLF
End Sub

Sub http_send_body (c, body As String)
    Put #Connections(c).handle, , body
End Sub

Sub http_do_get (c)
    http_do_post c
End Sub

Sub http_do_head (c)
    Dim s$
    s$ = "HTTP/1.1 200 OK" + CRLF + CRLF
    Put #Connections(c).handle, , s$
End Sub

Sub http_do_post (c)
    Dim As String action, body
    action = Connections(c).request_uri
    body = Connections(c).read_buf

    Dim response As String

    Select Case action
        Case "/connect": response = HandleConnect(body)
        Case "/disconnect": response = HandleDisconnect(body)
        Case "/get": response = HandleGet(body)
        Case "/send": response = HandleSend(body)
    End Select

    http_send_status c, 200, "OK"
    http_send_header c, "Content-Type", "text/plain"
    http_send_header c, "Content-Length", LTrim$(Str$(Len(response)))
    http_send_header c, "Access-Control-Allow-Origin", "*"
    http_send_header c, "Connection", "close"
    http_end_headers c
    http_send_body c, response

    close_connection c
End Sub

Function HandleConnect$ (body As String)
    AddMessage "system", body + " has entered the chat"
    HandleConnect$ = Str$(cmsg - 1)
End Function

Function HandleDisconnect$ (body As String)
    AddMessage "system", body + " has left the chat"
    HandleDisconnect$ = Str$(cmsg - 1)
End Function

Function HandleGet$ (body As String)
    Dim fmsg As Integer
    Dim response As String
    fmsg = Val(_Trim$(body))
    response = "["
    Dim As Integer i, idx
    For i = fmsg + 1 To cmsg
        idx = (i - 1) Mod MAX_MESSAGE + 1
        response = response + CRLF + "{ " + _
                   Q$("from") + ":" + Q$(messages(idx).sender) +  ", " + _
                   Q$("msg") + ":" + Q$(messages(idx).message) + ", " + _
                   Q$("time") + ":" + Q$(messages(idx).time) + " }"
        If i < cmsg Then response = response + ","
    Next i
    response = response + CRLF + "]"
    HandleGet$ = response
End Function

Function HandleSend$ (body As String)
    Print "send: ["; body; "]"
    Dim sender As String
    sender = "Unknown"

    Dim idx As Integer
    idx = InStr(body, ":")
    If idx > 0 Then
        sender = Mid$(body, 1, idx - 1)
        body = Mid$(body, idx + 1)
    End If
    AddMessage sender, _Trim$(body)
    HandleSend$ = Str$(cmsg)
End Function

Sub AddMessage (sender As String, message As String)
    Dim idx As Integer
    cmsg = cmsg + 1
    idx = (cmsg - 1) Mod MAX_MESSAGE + 1
    messages(idx).sender = JSONString(sender)
    messages(idx).message = JSONString(message)
    messages(idx).time = Date$ + " " + Time$

    LogMessage messages(idx)
End Sub

Function JSONString$ (s As String)
    s = Replace(_Trim$(s), Chr$(13) + Chr$(10), "\n")
    s = Replace(s, Chr$(10), "\n")
    s = Replace(s, Chr$(34), "\" + Chr$(34))
    JSONString$ = s
End Function

Sub LogMessage (msg As Message)
    Print #1, msg.time; " - "; msg.sender
    Print #1, msg.message
End Sub

Function Replace$ (s As String, searchString As String, newString As String)
    Dim ns As String
    Dim i As Integer

    Dim slen As Integer
    slen = Len(searchString)

    For i = 1 To Len(s) '- slen + 1
        If Mid$(s, i, slen) = searchString Then
            ns = ns + newString
            i = i + slen - 1
        Else
            ns = ns + Mid$(s, i, 1)
        End If
    Next i

    Replace = ns
End Function


Function Q$ (value As String)
    Q$ = Chr$(34) + value + Chr$(34)
End Function


Sub close_connection (c)
    Close #Connections(c).handle
    Connections(c).handle = 0
End Sub


Sub process_request (c)
    Dim eol
    Dim l As String
    Do
        eol = InStr(Connections(c).read_buf, CRLF)
        If eol = 0 Then Exit Sub
        l = Left$(Connections(c).read_buf, eol - 1)
        Connections(c).read_buf = Mid$(Connections(c).read_buf, eol + 2)
        If Connections(c).http_version = 0 Then 'First line not yet read
            process_start_line c, l
        Else
            If l = "" Then
                'headers complete; act upon request now
                Select Case Connections(c).method
                    Case HTTP_GET
                        http_do_get c
                    Case HTTP_POST
                        http_do_post c
                    Case HTTP_HEAD
                        http_do_head c
                End Select
                Exit Sub
            Else
                process_header c, l
            End If
        End If
    Loop
End Sub

Sub process_start_line (c, l As String)
    '7230 3.1.1
    'METHOD uri HTTP/x.y
    Dim sp1, sp2
    sp1 = InStr(l, " ")
    If sp1 = 0 Then http_error 400, "Bad Request", c

    '7231 4.3
    Select Case Left$(l, sp1 - 1)
        Case "GET"
            Connections(c).method = HTTP_GET
        Case "HEAD"
            Connections(c).method = HTTP_HEAD
        Case "POST"
            Connections(c).method = HTTP_POST
        Case Else
            http_error 501, "Not Implemented", c
    End Select

    sp2 = InStr(sp1 + 1, l, " ")
    If sp2 = 0 Or sp2 - sp1 = 1 Then http_error 400, "Bad Request", c
    Connections(c).request_uri = Mid$(l, sp1 + 1, sp2 - sp1 - 1)

    '7230 2.6
    If Mid$(l, sp2 + 1, 5) <> "HTTP/" Then
        http_error 400, "Bad Request", c
    End If
    Select Case Mid$(l, sp2 + 6)
        Case "1.0"
            Connections(c).http_version = HTTP_10
        Case "1.1"
            Connections(c).http_version = HTTP_11
        Case Else
            http_error 505, "HTTP Version Not Supported", c
    End Select
End Sub

Sub process_header (c, l As String)
    ' ignoring headers for now
End Sub

Sub http_error (code, message As String, connection)
    http_send_status connection, code, message
    http_send_header connection, "Content-Length", "0"
    http_send_header connection, "Connection", "close"
    http_end_headers connection
    close_connection connection
    Http_error_info.code = code
    Http_error_info.message = message
    Http_error_info.connection = connection
    Error 100
End Sub

If you want to connect to your own server just change the address at the top of the chat window to http://localhost:8080 (or whatever port you decide to use).

It was definitely an interesting exercise and gave me a number of ideas about new web functionality that I might want to add to QBJS's standard libraries.

Here is the client code in case you want to hot rod that side:

Code: (Select All)

Import Dom From "lib/web/dom.bas"

Dim Shared As Object txtAddress, txtUsername, btnConnect, textbox, msgPanel
Dim Shared lastMsg As Integer
Dim Shared username As String
Dim Shared connected As Integer
Dim Shared refreshing As Integer
Dim Shared sending As Integer
Dim Shared sndMsg As Integer

_Title "QB Chat"
sndMsg = _SndOpen("https://raw.githubusercontent.com/boxgaming/qbjs/main/samples/apps/new-message.ogg")

InitUI

SetTimeout sub_Refresh, 1000

' HTTP Event Handlers
' ---------------------------------------------------------------
Sub OnConnect (response)
    If Not connected Then
        lastMsg = Val(response)
        connected = -1
        txtAddress.disabled = true
        txtUsername.disabled = true
        btnConnect.innerText = "Disconnect"
    Else
        connected = 0
        txtAddress.disabled = false
        txtUsername.disabled = false
        btnConnect.innerText = "Connect"
    End If
End Sub

Sub OnSend (response)
    sending = 0
End Sub

Sub Refresh
    If connected And Not refreshing Then
        refreshing = -1
        HttpSend txtAddress.value + "/get", "POST", lastMsg, sub_OnRefresh
    End If
    SetTimeout sub_Refresh, 1000
End Sub

Sub OnRefresh (response)
    Dim playSound As Integer
    Dim res As Object
    res = JSON.parse(response)
    Dim i as Integer
    For i = 0 To res.length-1
        AddMessage res[i]
        If res[i].from <> username Then
            playSound = -1
        End If
    Next i
    lastMsg = lastMsg + res.length
    msgPanel.scrollTop = msgPanel.scrollHeight;
    If playSound Then _SndPlay sndMsg
    refreshing = 0
End Sub

Sub OnRefresError
    refreshing = 0
End Sub


' UI Event Handlers
' ----------------------------------------------------------
Sub OnClickConnect
    If txtUsername.value = "" Then
        Dom.Alert "Enter a username"
        Exit Sub
    End If
   
    If Not connected Then
        username = txtUsername.value
        Print "Setting username: [" + username + "]"
        HttpSend txtAddress.value + "/connect", "POST", username, sub_OnConnect
    Else
        HttpSend txtAddress.value + "/disconnect", "POST", username, sub_OnConnect
    End If   
End Sub

Function OnKeyPress (event)
    If event.keyCode = 13 Then
        'Print textbox.value
        Dim msg as String
        msg = _Trim$(textbox.value)
        If msg <> "" Then SendMessage msg
        OnKeyPress = false
    End If
End Function

Sub SendMessage (msg As String)
    Dim timeout As Integer
    While sending And timeout < 1000
        _Delay .01
        timeout = timeout + 1
    Wend
    sending = -1
    Dim body As String
    body = username + ":" + _Trim$(textbox.value)
    'Print "sending: [ " + body + " ]"
    HttpSend txtAddress.value + "/send", "POST", body, sub_OnSend
    textbox.value = ""
End Sub

Sub OnResize
    'msgPanel.height = Dom.Container().height - 100
    msgPanel.style.height = (_ResizeHeight - 200) + "px"
End Sub

' ----------------------------------------------------

Sub InitUI
    Dim As Object container, panel, btnSend, apanel
   
    Dom.GetImage(0).style.display = "none"
   
    container = Dom.Container
    container.style.letterSpacing = "normal"
    container.style.backgroundColor = "#333"
    Dom.Event window, "resize", sub_OnResize
   
    ' Create the login panel
    apanel = Dom.Create("div")
    apanel.style.display = "grid"
    apanel.style.margin = "auto 15%"
    apanel.style.textAlign = "left"
    apanel.style.fontWeight = "bold"
    Dom.Create "div", apanel, "Host"
    Dom.Create "div", apanel, "Username"
    Dom.Create "div", apanel
    apanel.style.gridTemplateColumns = "auto auto auto"
    txtAddress = Dom.Create("input", apanel, "https://chat.boxgaming.co")
    txtUsername = Dom.Create("input", apanel)
    btnConnect = Dom.Create("button", apanel, "Connect")
    Dom.Event btnConnect, "click", sub_OnClickConnect

    ' Create the message window
    msgPanel = Dom.Create("div")
    msgPanel.style.backgroundColor = "#444"
    msgPanel.style.overflowY = "auto"
    msgPanel.style.height = "300px"
    msgPanel.style.margin = "auto 15%"
    msgPanel.style.textAlign = "left"
    msgPanel.style.padding = "10px"

    ' Create send message control
    Dim sendLabel As Object
    panel = Dom.Create("div")
    panel.style.margin = "auto 15%"
    sendLabel = Dom.Create("div", panel, "Send Message")
    sendLabel.style.textAlign = "left"
    sendLabel.style.fontWeight = "bold"
    sendLabel.style.backgroundColor = "#666"
    sendLabel.style.padding = "4px"
    sendLabel.style.color = "#ccc"
    textbox = Dom.Create("textarea", panel)
    textbox.style.width = "100%"
    textbox.style.height = "100px"
    Dom.Event textbox, "keydown", func_OnKeyPress
   
    OnResize
End Sub

Sub AddMessage (msg As Object)
    Dim As Object mc, s, t, m

    mc = Dom.Create("div", msgPanel)
    mc.style.marginBottom = "10px"

    s = Dom.Create("div", mc)
    If msg.from = "system" Then
        s.style.color = "#00f4af"
    Else
        s.style.color = "#00aff4"
    End If
    s.style.fontWeight = "bold"
    s.innerHTML = msg.from

    t = Dom.Create("span", s)
    t.style.color = "#999"
    t.style.fontWeight = "normal"
    t.style.marginLeft = "8px"
    t.style.fontSize = ".8em"
    t.innerHTML = msg.time

    m = Dom.Create("div", mc)
    m.style.color = "#efefef"
    m.style.whiteSpace = "pre"
    m.innerHTML = msg.msg
   
End Sub


Sub HttpSend(url, method, message, callbackFn, errorCallbackFn)
$If Javascript Then
    const client = new XMLHttpRequest();
    client.open(method, url);
    client.setRequestHeader("Content-Length", message.length);
    client.send(message);
    client.onreadystatechange = function() {
        if (this.readyState == 4) {
            if (this.status == 200) {
                if (callbackFn) {
                    callbackFn(this.responseText);
                }
            }
            else { // assume any other status is an error
                if (errorCallbackFn) {
                    errorCallbackFn(this.responseText);
                }
            }
        }
    };
$End If
End Sub

Sub SetTimeout(callbackFn, millis)
$If Javascript Then
    setTimeout(callbackFn, millis);
$End If
End Sub

[MasterGy]

how many people does this serve? I also wrote a chat program recently, I'm just waiting for the server part to be uploaded to a server. I don't understand anything based on the code Congratulations! This network is an interesting area.

[bplus]

Hmm is there another bplus?

Or is that chat from the future? here now it's Sat 2022-12-17 but only 14:15 PM

This bplus is working on GUI structure that's doing nothing new with apps but trying to make it easier to use as coder.

[dbox]

Hmm is there another bplus?

Or is that chat from the future? here now it's Sat 2022-12-17 but only 14:15 PM

This bplus is working on GUI structure that's doing nothing new with apps but trying to make it easier to use as coder.

Must have been some sort of bplus imposter!

[dbox]

how many people does this serve?

I'm not really sure how many concurrent users the server will support.  I haven't tried to stress test it yet.

I don't understand anything based on the code Congratulations! This network is an interesting area.

Thanks @MasterGy, I feel the same way when I see your excellent 3d examples. I'm always impressed but I don't understand your code either.

That reminds me, one of the next things I'm working on for QBJS is _MapTriangle, which will use WebGL. I'd love to see some of your work one the web.

[vince]

so Steve writes a chat program and now there's three, go figure

[dbox]

They say imitation is the sincerest form of flattery.

[Pete]

Yep, nothing says "I love you" like copyright infringement... Just kidding. Actually Pete wrote a chat program, in October, but I wasn't able to get it to communicate over my network. Too many router/firewall issues. I couldn't get Steve's to work, either. Got a damn virus warning and it got quarantined with that one.

Fun stuff, but often too complicated due to numerous security issues. This is why I usually slave shell to third party apps like wget and Curl for a lot of other website stuff. Those developers worked out most, if not all, of the security protocols. QB stared going downhill in this regard when you had to recommend to everyone to use Port Talk.

Good luck with it. Oh, and don't mind Vince. He is too busy getting ready for The Dallas Cowboy Cheerleader tryouts to make a chat program.

Pete