QBJS - Web Chat - Printable Version

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

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