significant update from OP

bots/moonchat/moonchat.service

@@ -0,0 +1,13 @@
+[Unit]
+Description=All bots for MoonChat
+After=network.target
+
+[Service]
+User=moonchat
+Group=moonchat
+ExecStart=/opt/moonchat/moonchat.sh
+ExecReload=/opt/moonchat/moonchat.sh
+Restart=always
+
+[Install]
+WantedBy=default.target

client/moontalk-tcl/LICENSE

@@ -0,0 +1 @@
+../../LICENSE

client/moontalk-tcl/moontk.tcl

@@ -0,0 +1,196 @@
+#!/usr/bin/wish
+
+# Default values.
+set host "7ks473deh6ggtwqsvbqdurepv5i6iblpbkx33b6cydon3ajph73sssad.onion"
+set port "50000"
+set username "anonymous"
+set reconnect_max_tries -1
+set reconnect_time 10000
+
+set notification_exe   "/usr/bin/aplay"
+set notification_file  "./notification.wav"
+set notification_delay 1000
+
+# Don't touch these
+set identity "Anon ?"
+set reconnect_try 0
+set sock 0
+set notification_cooldown 0
+
+proc window_visibility {w val} {
+  if {$val} {
+      wm deiconify $w
+  } else {
+      wm withdraw $w
+  }
+}
+
+proc on_user_connect {w} {
+    global reconnect_try
+    set reconnect_try 0
+    window_visibility . true
+    socket_connect
+    window_visibility $w false
+}
+
+proc display_connect_dialog {} {
+    global reconnect_try
+    global host
+    global port
+    set w .wconnect
+    if { [winfo exists $w] } {
+        window_visibility $w true
+        focus $w
+    } else {
+        toplevel $w
+        wm title $w "MoonTk - Connect to MoonTalk"
+        set callback_wrapper "on_user_connect $w"
+        pack [label $w.lh -text "Host:"] -anchor w
+        pack [entry $w.eh -textvariable host] -fill x
+        pack [label $w.lp -text "Port:"] -anchor w
+        pack [entry $w.ep -textvariable port] -fill x
+        pack [button $w.bc -text "connect" -command $callback_wrapper]
+        bind $w.eh <Return> $callback_wrapper
+        bind $w.eh <KP_Enter> $callback_wrapper
+        bind $w.ep <Return> $callback_wrapper
+        bind $w.ep <KP_Enter> $callback_wrapper
+        focus $w
+    }
+}
+
+wm title . "MoonTk"
+pack [entry .input] -side bottom -fill x
+pack [scrollbar .sy -command {.messages yview}] -side right -fill y
+pack [text .messages -wrap none -xscrollcommand {.sx set} -yscrollcommand {.sy set}] -fill both -expand 1
+pack [scrollbar .sx -orient horizontal -command {.messages xview}] -fill x
+
+proc socket_connect {} {
+    global sock
+    global host
+    global port
+    append_message "Connecting to $host:$port..."
+    if {[catch {socket -async $host $port} sock]} {
+        on_socket_connection_failed
+    } else {
+        fconfigure $sock -blocking false
+        fconfigure $sock -translation binary
+        fileevent $sock readable on_socket_receive
+        fileevent $sock writable on_socket_connect
+    }
+}
+
+proc on_socket_connect {} {
+    global reconnect_try
+    global sock
+    set error [fconfigure $sock -error]
+    if {$error ne ""} {
+        catch {close $sock}
+        on_socket_connection_failed
+        return
+    }
+    append_message "Successfully connected to the server."
+    fileevent $sock writable {}
+    set reconnect_try 0
+}
+
+proc on_socket_connection_failed {} {
+    global reconnect_time
+    global reconnect_max_tries
+    global reconnect_try
+    if { $reconnect_max_tries != -1
+         && $reconnect_try >= $reconnect_max_tries } {
+        tk_messageBox -message "Maximum reconnect tries reached." -type ok
+        display_connect_dialog
+    } else {
+        set reconnect_try [expr {$reconnect_try + 1}]
+        append_message "Failed to connect to the server, retrying in [expr {$reconnect_time/1000}] seconds."
+        after $reconnect_time socket_connect
+    }
+}
+
+proc on_socket_disconnect {} {
+    append_message "Disconnected from server..."
+    socket_connect
+}
+
+proc parse_identity {data} {
+    global identity
+    regexp -all {^Server: You are now known as \"(.+)\"\.} $data whole_match ident
+    if {[info exists ident]} {
+        set identity $ident
+    }
+}
+
+proc reset_notification {} {
+    global notification_cooldown
+    set notification_cooldown 0
+}
+
+proc play_notification {} {
+    global notification_exe
+    global notification_file
+    global notification_cooldown
+    global notification_delay
+    set notification_cooldown 1
+    exec $notification_exe $notification_file "&"
+    after $notification_delay reset_notification
+}
+
+proc on_socket_receive {} {
+    global sock
+    global identity
+    global notification_cooldown
+    set error [fconfigure $sock -error]
+    # catch gets = read error
+    # eof = other side disconnected
+    if { $error ne ""
+         || [catch {gets $sock} data]
+         || [eof $sock]} {
+      catch {close $sock}
+      on_socket_disconnect
+      return
+    }
+    if {[string match "Server: *" $data]} {
+        parse_identity $data
+    }
+    if { !$notification_cooldown } {
+      play_notification
+    }
+    append_message $data
+}
+
+proc send_message {msg} {
+    global sock
+    global identity
+    set formatted_msg [format_message $msg]
+    puts $sock $formatted_msg
+    flush $sock
+    append_message "$identity: $formatted_msg"
+}
+proc timestamp {} {
+    return [clock format [clock seconds] -gmt true -format {%Y/%m/%d %H:%M:XX}]
+}
+proc format_message {msg} {
+    global username
+    set ts [timestamp]
+    if {[string match "/*" $msg]} {
+        return $msg
+    } else {
+        return "<$ts $username> $msg"
+    }
+}
+
+proc append_message {msg} {
+    .messages insert end "$msg\n"
+    .messages see end
+}
+
+proc user_enter {} {
+    send_message [.input get]
+    .input delete 0 end
+}
+bind .input <Return> user_enter
+bind .input <KP_Enter> user_enter
+
+window_visibility . false
+display_connect_dialog

client/moontalk.tcl

@@ -1,37 +0,0 @@
-#!/usr/bin/tclsh
-
-# Originally written by an Anon. Slightly modified.
-
-package require Tk
-
-set ::name anonymous
-set ::usernu x
-
-set ::host 7ks473deh6ggtwqsvbqdurepv5i6iblpbkx33b6cydon3ajph73sssad.onion
-
-pack [text .msgs] -fill both -expand 1
-pack [entry .entry] -fill x
-
-proc add_msg { msg } {
-    .msgs insert end "$msg\n"
-    .msgs yview end
-}
-
-proc get_msg {} {
-    set curdate [clock format [clock seconds] -format "%Y/%m/%d %T"]
-    return "<$curdate $::name:$::usernu> [.entry get]"
-}
-
-bind .entry <Return> {
-    set msg [get_msg]
-    puts $::fd $msg
-    flush $::fd
-    add_msg $msg
-    .entry delete 0 end
-}
-
-fileevent [set fd [socket $::host 50000]] readable {
-    add_msg [gets $::fd]
-}
-
-chan configure $::fd -translation binary

server/eventloop-server-experiment/CHANGELOG

@@ -0,0 +1,28 @@
+16.02.2024
+* stdout redirection/hooking implemented
+* added admin commands
+* added user commands
+* implemented logging
+
+14.02.2024
+* C FFI has been made optional
+  this is to allow this server to run on android using the existing gforth app
+
+09.02.2024
+* improved denial of service protections:
+  - we now parse the proxy line from Tor to get the circuit id which we can
+    use to close Tor circuits
+  - we now track the connections, bytes and the lines per tor circuit
+
+08.02.2024
+* implemented torcontrol
+* simplified and improved the motd parser
+
+06.02.2024
+* added this changelog
+* simplified and improved performance of the event queue events.4th
+* refactoring variable -> variable!
+* added server commands:
+  - server-commands, server-users, server-accept, server-accepting?,
+    server-disconnect, server-ban-circuit (placeholder), server-broadcast,
+    server-message

server/eventloop-server-experiment/commandline.4th

@@ -1,3 +1,4 @@
+require util.4th
 
 80 constant COMMANDLINE_SIZE
 create commandline COMMANDLINE_SIZE allot
@@ -40,7 +41,7 @@ variable cmdready
       k-right of (cursor-right) endof
     endcase
   else ( keyboard-event )
-    drop \ just ignore an unknown keyboard event type
+    drop \ just ignore an unknown keyboard event
   then then ;
 
 : commandline-getline ( -- c-addr u )
@@ -48,14 +49,16 @@ variable cmdready
 
 : (update-cursorpos) ( -- )
   s\" \033[" type
-  (cursor@) 1+ s>d <# #s #> type
+  (cursor@) 1+ to-string type
   s" G" type ;
 : (carriage-return) ( -- )
   13 emit ;
 : commandline-redraw ( -- )
+  false stdout-logger
   (carriage-return)
   commandline-getline type
-  (update-cursorpos) ;
+  (update-cursorpos)
+  true stdout-logger ;
 
 : commandline-reset ( -- )
   commandline COMMANDLINE_SIZE bl fill

server/eventloop-server-experiment/configuration.4th

@@ -0,0 +1,12 @@
+
+true constant CONFIG_C_FFI
+
+23232 constant CONFIG_SERVER_PORT
+
+s" logs/" sconstant CONFIG_LOG_DIR
+
+ TOR_CONTROL_AUTHMETHOD_COOKIE   constant CONFIG_TOR_CONTROL_AUTHMETHOD
+            1 24 lshift 127 or   constant CONFIG_TOR_CONTROL_ADDR
+                          9051   constant CONFIG_TOR_CONTROL_PORT
+s" /run/tor/control.authcookie" sconstant CONFIG_TOR_CONTROL_COOKIE_FILEPATH
+\                s" mypassword" sconstant CONFIG_TOR_CONTROL_PASSWORD

server/eventloop-server-experiment/connections.4th

@@ -1,18 +1,21 @@
+require util.4th
 
 256 constant CONNECTION_BUFFER_SIZE
-
 0
   cell                    +field connection.number
+  cell                    +field connection.admin
   cell                    +field connection.fd
   cell                    +field connection.connected
+  cell                    +field connection.sendcount
+  cell                    +field connection.circuitid
   cell                    +field connection.bufferlen
   CONNECTION_BUFFER_SIZE  +field connection.buffer
 constant /CONNECTION
 
-1024 10 * constant MAX_CONNECTIONS
+32 constant MAX_CONNECTIONS
 
-variable last-connection -1 last-connection !
+-1 variable! last-connection
-variable largest-index -1 largest-index !
+-1 variable! largest-index
 MAX_CONNECTIONS /CONNECTION * constant CONNECTIONS_SIZE
 create connections CONNECTIONS_SIZE allot
 connections CONNECTIONS_SIZE erase

server/eventloop-server-experiment/dos.4th

@@ -0,0 +1,123 @@
+\ Denial of service protection.
+\ TODO: Use hash table instead?
+
+require util.4th
+
+[UNDEFINED] MAX_CONNECTIONS [IF] 32 constant MAX_CONNECTIONS [THEN]
+
+             10 constant DOS_UPDATE_INTERVAL
+           1024 constant DOS_BYTES_PER_INTERVAL
+             10 constant DOS_LINES_PER_INTERVAL
+              3 constant DOS_MAX_CONNECTIONS
+MAX_CONNECTIONS constant DOS_MAX_MAPPINGS
+
+\ TODO: is 0 a valid circuit id?
+\ TODO: if not, then we could use the circuit id instead of dos.set
+0
+  cell +field dos.set
+  cell +field dos.circuit-id
+  cell +field dos.handled
+  cell +field dos.connections
+  cell +field dos.total-bytes
+  cell +field dos.total-lines
+  cell +field dos.bytes
+  cell +field dos.lines
+constant /DOS
+
+/DOS DOS_MAX_MAPPINGS * constant DOS_ARRAY_SIZE
+create dos DOS_ARRAY_SIZE alloterase
+
+\ Lookup table: connection index -> dos stats
+create doslt DOS_MAX_MAPPINGS cells alloterase
+
+: (translate) ( index-n -- dos-addr )
+  /DOS * dos + ;
+: (init-dos) ( free-addr circuit-id-n -- dos-addr )
+  over dos.circuit-id !
+  true over dos.set ! ;
+: (find) ( circuit-id-n -- dos-addr )
+  0 swap dos DOS_ARRAY_SIZE + dos DO ( -- free-addr circuit-id-n )
+    I dos.set @ IF
+      dup I dos.circuit-id @ = IF
+        2drop I UNLOOP EXIT
+      THEN
+    ELSE
+      over 0= IF
+        nip I swap
+      THEN
+    THEN
+  /DOS +LOOP
+  (init-dos) ;
+: (lttranslate) ( connection-index-n -- lookup-addr )
+  cells doslt + ;
+: (lookup) ( connection-index-n -- dos-addr )
+  (lttranslate) @ ;
+
+: (mod-connections) ( n dos-addr -- ) dos.connections +! ;
+: (inc-connections) ( dos-addr -- ) 1 swap (mod-connections) ;
+: (dec-connections) ( dos-addr -- ) -1 swap (mod-connections) ;
+: dos-add-connection ( circuit-id-n connection-index-n -- )
+  (lttranslate) dup @ 0= IF
+    swap (find) tuck (inc-connections) !
+  ELSE
+    2drop EXIT
+  THEN ;
+: dos-remove-connection ( connection-index-n -- )
+\ erase if last connection
+  (lttranslate) dup 0<> IF
+    dup @ >r 0 swap ! r>
+    dup (dec-connections)
+    dup dos.connections @ 0= IF
+      /DOS erase
+    ELSE
+      drop
+    THEN
+  ELSE
+    drop
+  THEN ;
+: dos-add-bytes ( bytes-n connection-index-n -- )
+  (lookup) dos.bytes +! ;
+: dos-add-lines ( lines-n connection-index-n -- )
+  (lookup) dos.lines +! ;
+: (update) ( dos-addr -- )
+  dup dos.bytes @ over dos.total-bytes +!
+  dup dos.lines @ over dos.total-lines +!
+  0 over dos.bytes !
+  0 over dos.lines !
+  drop ;
+: dos-update ( -- )
+\ add time interval bytes and lines to total and set to 0
+  dos DOS_ARRAY_SIZE + dos DO
+    I dos.set @ IF
+      I (update)
+    THEN
+  /DOS +LOOP ;
+
+: (check-bytes) ( dos-addr -- flag ) dos.bytes @ DOS_BYTES_PER_INTERVAL > ;
+: (check-lines) ( dos-addr -- flag ) dos.lines @ DOS_LINES_PER_INTERVAL > ;
+: (check-connections) ( dos-addr -- flag ) dos.connections @ DOS_MAX_CONNECTIONS > ;
+: dos-handled! ( flag connection-index-n -- )
+  (lttranslate) @ dos.handled ! ;
+: dos-handled? ( connection-index-n -- flag )
+  (lttranslate) @ dos.handled @ ;
+: dos? ( connection-index-n -- flag )
+  (lttranslate) @
+  dup  (check-bytes) over (check-lines)
+  rot  (check-connections) or or ;
+
+: (.dos-info) ( dos-addr -- )
+  dup ." CircuitID: " dos.circuit-id @ . cr
+  dup ." Connections: " dos.connections @ . cr
+  dup ." Total bytes: " dos.total-bytes @ . cr
+  dup ." Total lines: " dos.total-lines @ . cr
+  dup ." Bytes: " dos.bytes @ . cr
+  dup ." Lines: " dos.lines @ . cr
+  drop ;
+: .dos-info ( connection-index-u -- )
+  (lttranslate) @ (.dos-info) ;
+: .dos ( -- )
+  dos DOS_ARRAY_SIZE + dos DO
+    I dos.set @ IF
+      cr I (.dos-info)
+    THEN
+  /DOS +LOOP ;

server/eventloop-server-experiment/events.4th

@@ -1,88 +1,38 @@
-256 constant MAX_EVENTS
+require util.4th
+
+1024 constant MAX_EVENTS
 
 0
   cell +field event.id
   cell +field event.data
 constant /EVENT
 
-0
+0 variable! current-event
-  cell   +field eventlink.next
+0 variable! last-event
-  /EVENT +field eventlink.event
-constant /EVENTLINK
 
-variable first-event
+MAX_EVENTS /EVENT * constant EVENTS_SIZE
-variable last-event
-variable free-event
-MAX_EVENTS /EVENTLINK * constant EVENTS_SIZE
 create events EVENTS_SIZE allot
 
-: (translate) ( index-u -- eventlink-addr )
+: (translate) ( index-u -- event-addr )
-  /EVENTLINK * events + ;
+  ]] /EVENT * events + [[ ; IMMEDIATE
-: (link-to-next) ( index-u -- )
+: (wrap) ( index-u -- index-u )
-  dup 1+ (translate) swap (translate) eventlink.next ! ;
+  ]] MAX_EVENTS mod [[ ; IMMEDIATE
-: (fix-last-link) ( -- )
+: (read) ( addr -- data-u id-u )
-  MAX_EVENTS 1- (translate) eventlink.next 0 swap ! ;
+  ]] dup event.data @ swap event.id @ [[ ; IMMEDIATE
-: (set-first-free) ( -- )
+: (write) ( data-u id-u addr -- )
-  0 (translate) free-event ! ;
+  ]] tuck event.id ! event.data ! [[ ; IMMEDIATE
-: (link-free) ( -- )
+: events.has-item? ( -- flag )
-  MAX_EVENTS 0 DO I (link-to-next) LOOP
+  current-event @ last-event @ <> ;
-  (fix-last-link)
-  (set-first-free) ;
-: (free-available?) ( -- flag )
-  free-event @ 0<> ;
-: (assert-free-available) ( -- )
-  (free-available?) invert abort" no free eventlinks available." ;
-: (next-free) ( -- eventlink-addr )
-  (assert-free-available)
-  free-event @ dup eventlink.next @ free-event ! ;
-
-: events.clear ( -- )
-  0 first-event ! 0 last-event !
-  events EVENTS_SIZE erase
-  (link-free) ;
-: (set-next-null) ( eventlink-addr -- )
-  dup eventlink.next 0 swap ! ;
-: (first-event-exists?) ( -- flag ) first-event @ 0<> ;
-: (last-event-exists?) ( -- flag ) last-event @ 0<> ;
-: (as-first-event) ( eventlink-addr -- ) first-event ! ;
-: (as-last-event) ( eventlink-addr -- ) last-event ! ;
-: (after-last-event) ( eventlink-addr -- )
-  dup last-event @ eventlink.next !
-  last-event ! ;
-: (append-event) ( eventlink-addr -- )
-  (set-next-null)
-  (first-event-exists?) invert IF
-    dup (as-first-event)
-  THEN
-  (last-event-exists?) IF
-    dup (after-last-event)
-  ELSE
-    dup (as-last-event)
-  THEN drop ;
-: (set-eventdata) ( data-u id-u eventlink-addr -- )
-  eventlink.event tuck event.id ! event.data ! ;
 : events.enqueue ( data-u id-u -- )
-  (next-free) dup >r (set-eventdata) r> (append-event) ;
+  last-event @ dup 1+ dup >r current-event @ = abort" Queue is full."
-: (get-eventdata) ( eventlink-addr -- data-u id-u )
+  (translate) (write) r> (wrap) last-event ! ;
-  eventlink.event dup event.data @ swap event.id @ ;
-: (assert-first-exists) ( -- )
-  (first-event-exists?) invert abort" no events in queue" ;
-: (check-first-and-last) ( -- )
-  first-event @ 0= IF
-    0 last-event !
-  THEN ;
-: (get-first-event) ( -- eventlink-addr )
-  first-event @ ;
-: (free-event) ( eventlink-addr -- )
-  dup eventlink.next free-event @ swap !
-  free-event ! ;
-: (set-first-event-to-next) ( -- )
-  first-event @ eventlink.next @ first-event !
-  (check-first-and-last) ;
 : events.dequeue ( -- data-u id-u )
-  (assert-first-exists) (get-first-event) (set-first-event-to-next)
+  events.has-item? invert abort" No events in queue."
-  dup (free-event) (get-eventdata) ;
+  current-event @ dup (translate) (read)
-: events.has-item? ( -- flag ) (first-event-exists?) ;
+  rot 1+ (wrap) current-event ! ;
+: events.clear ( -- )
+  0 current-event !
+  0 last-event !
+  events EVENTS_SIZE erase ;
 
-\ Clear events, initialize events array.
 events.clear

server/eventloop-server-experiment/extensions.4th

@@ -0,0 +1,16 @@
+require unix/socket.fs
+
+require configuration.4th
+
+s" gforth" environment? [IF]
+  s" 0.7.3" compare 0= [IF]
+    require extensions/gforth-0.7.3.4th
+  [ELSE]
+\   we assume the latest version, as 0.7.3 is more than 10 years old already
+    require extensions/gforth-latest.4th
+  [THEN]
+  require extensions/generic.4th
+[ELSE]
+  2drop cr ." We should never reach this." cr
+  abort
+[THEN]

server/eventloop-server-experiment/extensions/generic.4th

@@ -0,0 +1,4 @@
+
+: time ( a -- n )
+  abort" argument not supported"
+  utime #1000000 um/mod nip ;

server/eventloop-server-experiment/extensions/gforth-0.7.3.4th

@@ -0,0 +1,26 @@
+
+
+CONFIG_C_FFI invert [IF]
+  cr
+  ." To run this program on Gforth 0.7.3 we need the C FFI, as setsockopt" cr
+  ." is not available in 0.7.3." cr
+  abort
+[THEN]
+
+\ Gforth 0.7.3 doesn't seem to have these defined.
+     2 Constant AF_INET
+   $40 Constant MSG_DONTWAIT
+ $4000 constant MSG_NOSIGNAL
+  2048 constant SOCK_NONBLOCK
+     1 constant SOL_SOCKET
+     2 Constant SO_REUSEADDR
+    11 constant EAGAIN
+
+sockaddr_in nip constant /sockaddr_in
+4               constant /option_value
+
+' closesocket alias close
+
+c-library socketextlib
+  c-function setsockopt setsockopt n n n a n -- n ( sockfd level optname optval optlen -- r )
+end-c-library

server/eventloop-server-experiment/extensions/gforth-latest.4th

@@ -0,0 +1,6 @@
+
+$4000 constant MSG_NOSIGNAL
+2048  constant SOCK_NONBLOCK
+
+sockaddr_in constant /sockaddr_in
+4           constant /option_value

server/eventloop-server-experiment/libs/parser/parser.4th

@@ -0,0 +1,64 @@
+\ Simple stateful parsing module.
+
+0
+  cell +field parser-string
+  cell +field parser-size
+  cell +field parser-marker
+  cell +field parser-cursor
+constant PARSER_SIZE
+
+variable context
+: (context@) ( -- parser-addr ) context @ ;
+: (context!) ( parser-addr -- ) context ! ;
+
+: (string@) ( -- c-addr ) (context@) parser-string @ ;
+: (string!) ( c-addr -- ) (context@) parser-string ! ;
+: (size@) ( -- u ) (context@) parser-size @ ;
+: (size!) ( u -- ) (context@) parser-size ! ;
+: (marker@) ( -- u ) (context@) parser-marker @ ;
+: (marker!) ( u -- ) (context@) parser-marker ! ;
+: (cursor@) ( -- u ) (context@) parser-cursor @ ;
+: (cursor!) ( u -- ) (context@) parser-cursor ! ;
+
+: new-parser ( c-addr u parser-addr -- )
+  (context!) (size!) (string!) 0 dup (marker!) (cursor!) ;
+: restore-parser ( parser-addr -- ) (context!) ;
+: current-parser ( -- parser-addr ) (context@) ;
+
+: parser-here      ( -- u ) (cursor@) ;
+: parser-marker    ( -- u ) (marker@) ;
+: parser-mark      ( -- )   (cursor@) (marker!) ;
+: parser-backtrack ( -- )   (marker@) (cursor!) ;
+
+: parser-remaining ( -- c-addr u )
+  (string@) (cursor@) + (size@) (cursor@) - ;
+
+: parser-extract ( -- c-addr u )
+  (string@) (marker@) + (cursor@) (marker@) - ;
+
+: parser>>| ( -- )   (size@) (cursor!) ;
+: parser|<< ( -- )   0 (cursor!) ;
+: parser>>  ( u -- ) (cursor@) + (size@) min 0 max (cursor!) ;
+: parser<<  ( u -- ) negate parser>> ;
+
+: parser>>string ( c-addr u -- flag )
+  parser-remaining 2swap search IF
+    drop (string@) - (cursor!) true
+  ELSE
+    2drop false
+  THEN ;
+
+: parser>>|string ( c-addr u -- flag )
+  parser>>string ;
+
+: parser>>string| ( c-addr u -- flag )
+  dup -rot parser>>string IF
+    parser>> true
+  ELSE
+    drop false
+  THEN ;
+
+: with-parser ( xt parser-addr -- )
+    (context@) >r (context!) execute r> (context!) ;
+: with-new-parser ( xt str parser-addr -- )
+    (context@) >r new-parser execute r> (context!) ;

server/eventloop-server-experiment/libs/xstring/xstring.4th

@@ -0,0 +1,22 @@
+\ An extended string is essentially the same
+\ as a counted string, with the only difference that
+\ instead of storing max 1 char length of a string,
+\ we can store up to cell sized strings.
+
+\ Copy an extended string to 
+: xplace ( c-addr u a-addr -- )
+    swap dup >r over ! ( c-addr a-addr )
+    cell + r> move ;
+: xcount ( a-addr -- c-addr u )
+    dup cell + swap @ ;
+: +xplace ( c-addr u a-addr -- )
+    2dup >r >r xcount ( c-addr u c-addr u )
+    + swap ( c-addr a-addr u )
+    move ( -- )
+    r> r> +! ;
+
+\ single char
+create somechar 1 chars allot align
+: +xplace-char ( n a-addr -- )
+    swap somechar c! somechar 1 rot +xplace ;
+

server/eventloop-server-experiment/logger.4th

@@ -0,0 +1,28 @@
+require libs/xstring/xstring.4th
+
+require extensions.4th
+
+0 variable! logfd
+
+: (log-filepath) ( -- str )
+  CONFIG_LOG_DIR pad xplace
+  0 time to-string pad +xplace
+  s" .log" pad +xplace
+  pad xcount ;
+
+(log-filepath) sconstant log-filepath
+
+: logger.open ( -- )
+  log-filepath r/w create-file throw logfd ! ;
+: logger.close ( -- )
+  logfd @ close-file drop ;
+
+: logger.flush ( -- )
+  logfd @ flush-file drop ;
+
+: logger.log ( str -- )
+  logfd @ 0<> IF
+    logfd @ write-file drop
+  ELSE
+    2drop
+  THEN ;

server/eventloop-server-experiment/main.4th

@@ -1,10 +1,15 @@
+require util.4th
+require torcontrol-constants.4th
+require configuration.4th
+require stdout-hook.4th
 require check-gforth.4th
 require eventloop.4th
 require event-constants.4th
 require server.4th
 
-variable clcounter
+\ TODO: integrate generic timed event handling into the event loop?
-0 clcounter !
+
+0 variable! clcounter
 : handle-command-line? ( -- flag )
   clcounter @ 10 >= dup IF
     0 clcounter !
@@ -12,20 +17,40 @@ variable clcounter
     1 clcounter +!
   THEN ;
 
+0 variable! dostimer
+: handle-dos? ( -- flag )
+  0 time dup dostimer @ > IF
+    DOS_UPDATE_INTERVAL + dostimer !
+    true
+  ELSE
+    drop false
+  THEN ;
+
 : custom-eventloop ( -- )
   BEGIN
     handle-command-line? IF
       0 EVENT_COMMANDLINE events.enqueue
     THEN
+    handle-dos? IF
+      dos-update
+    THEN
     eventloop.has-events? IF
       eventloop.dispatch
     ELSE
       server-idle? IF
-        1 ms false server-idle!
+        10 ms false server-idle!
       THEN
       0 0 events.enqueue eventloop.dispatch
     THEN
   AGAIN ;
 
-: main ( -- ) ['] custom-eventloop catch close-server throw ;
+: main ( -- )
+  logger.open
+  ['] custom-eventloop catch close-server throw 
+  logger.close ;
+\ : main ( -- )
+\   logger.open
+\   custom-eventloop close-server
+\   logger.close ;
+
 main

server/eventloop-server-experiment/motd-parser.4th

@@ -0,0 +1,18 @@
+require libs/parser/parser.4th
+
+create motd-parser PARSER_SIZE allot
+create motd-line-delim 10 c,
+
+: (motd-delim) ( -- str )
+  motd-line-delim 1 ;
+variable (append-xt)
+: (append) ( str -- )
+  (append-xt) @ execute ;
+: parse-motd ( motd-str append-line-xt -- )
+  (append-xt) ! motd-parser new-parser
+  BEGIN
+    parser-mark (motd-delim) parser>>string
+  WHILE
+    parser-extract (append)
+    (motd-delim) nip parser>>
+  REPEAT ;

server/eventloop-server-experiment/patches/README

@@ -0,0 +1,3 @@
+Optional runtime patches that can be applied with:
+
+require patches/mypatch.4th

server/eventloop-server-experiment/patches/motd.4th

@@ -0,0 +1 @@
+s\" https://git.lain.church/emil/moontalk\n\nType /help for commands." motd-current-banner motd-compose

server/eventloop-server-experiment/patches/unsanitized-message.4th

@@ -0,0 +1,9 @@
+ 
+: server-message-unsanitized ( msg-str user-n -- )
+  sendbuffer-reset
+  cr >r
+  s" Server: " sendbuffer-append
+               sendbuffer-append
+  s\" \n"      sendbuffer-append
+  r> 1- connections.at dup (assert-connected)
+  (send-sendbuffer) ;

server/eventloop-server-experiment/proxyline-parser.4th

@@ -0,0 +1,33 @@
+\ Tor specific words.
+
+require libs/parser/parser.4th
+
+create proxyline-parser PARSER_SIZE allot
+
+: (expect&skip) ( str -- )
+  tuck parser>>string invert abort" parsing exception" parser>> ;
+: (extract-before) ( str -- )
+  parser-mark (expect&skip) 1 parser<< parser-extract 1 parser>> ;
+: (hexstr>value) ( str -- n )
+  hex 2>r 0 0 2r> >number 2drop d>s decimal ;
+: (parse-circuitid) ( -- circuitid-n )
+  s" :" (extract-before) pad place
+  s"  " (extract-before) pad +place
+  pad count (hexstr>value) ;
+: proxyline>circuitid ( line-str -- circuitid-n remaining-str )
+  proxyline-parser new-parser
+  s" PROXY TCP6 fc00:dead:beef:4dad::" (expect&skip) (parse-circuitid)
+  s\" \r\n" (expect&skip) parser-remaining ;
+
+\ TODO: removeme
+: proxyline-test1 ( -- )
+  s\" PROXY TCP6 fc00:dead:beef:4dad::ffff:ffff ::1 65535 42\r\n" proxyline>circuitid
+  2drop 4294967295 <> abort" ASDF" ;
+
+: proxyline-test2 ( -- )
+  s\" PROXY TCP6 fc00:dead:beef:4dad::AABB:CCDD ::1 65535 42\r\n" proxyline>circuitid
+  2drop 2864434397 <> abort" ASDF" ;
+
+proxyline-test1
+proxyline-test2
+

server/eventloop-server-experiment/sendbuffer.4th

@@ -1,19 +1,48 @@
-variable sendbuffer-len 0 sendbuffer-len !
+require util.4th
+require configuration.4th
+
+0 variable! sendbuffer-len
 4096 constant SENDBUFFER_SIZE
 create sendbuffer SENDBUFFER_SIZE allot
 
-\ Calling C here is just optimization.
+CONFIG_C_FFI invert [IF]
-c-library sanitizelib
+  variable last-is-newline
-\c void csanitize(char *buffer, int buffersize) {
+  : (last) ( c-addr u -- c-addr )
-\c     int lastIsNewline = buffer[buffersize-1] == '\n' ? 1 : 0;
+    1- + ;
-\c     for(int i = 0; i<buffersize; i++) {
+  : (sanitize-char) ( c-addr -- )
-\c         if(buffer[i]<32 || buffer[i]>126) { buffer[i] = '?'; }
+    dup c@ dup 32 < swap 126 > or IF
-\c     }
+      [char] ? swap c!
-\c     if(lastIsNewline) { buffer[buffersize-1] = '\n'; }
+    ELSE
-\c     return;
+      drop
-\c }
+    THEN ;
-    c-function csanitize csanitize a n -- void
+  : sanitize ( c-addr u -- )
-end-c-library
+    dup 0<= IF
+      2drop EXIT
+    THEN
+    2dup (last) c@ 10 = last-is-newline !
+    2dup
+    bounds DO
+      I (sanitize-char)
+    LOOP
+    last-is-newline @ IF
+      (last) 10 swap c!
+    ELSE
+      2drop
+    THEN ;
+[ELSE]
+  \ Calling C here is just optimization.
+  c-library sanitizelib
+  \c void sanitize(char *buffer, int buffersize) {
+  \c     int lastIsNewline = buffer[buffersize-1] == '\n' ? 1 : 0;
+  \c     for(int i = 0; i<buffersize; i++) {
+  \c         if(buffer[i]<32 || buffer[i]>126) { buffer[i] = '?'; }
+  \c     }
+  \c     if(lastIsNewline) { buffer[buffersize-1] = '\n'; }
+  \c     return;
+  \c }
+      c-function sanitize sanitize a n -- void
+  end-c-library
+[THEN]
 
 : sendbuffer-reset ( -- ) 0 sendbuffer-len ! ;
 : (overflow?) ( n -- flag )
@@ -24,5 +53,5 @@ end-c-library
 : sendbuffer-append ( str -- )
   dup (overflow?) abort" sendbuffer overflow" (append) ;
 : sendbuffer-sanitize ( -- )
-  sendbuffer sendbuffer-len @ csanitize ;
+  sendbuffer sendbuffer-len @ sanitize ;
 : sendbuffer@ ( -- str ) sendbuffer sendbuffer-len @ ;

server/eventloop-server-experiment/server.4th

@@ -1,9 +1,16 @@
 require unix/socket.fs
 
-require socket-extensions.4th
+require libs/xstring/xstring.4th
+
+require util.4th
+require extensions.4th
 require connections.4th
 require commandline.4th
 require motd.4th
+require motd-parser.4th
+require proxyline-parser.4th
+require torcontrol.4th
+require dos.4th
 require sendbuffer.4th
 
 AF_INET constant SERVER_SOCKET_DOMAIN
@@ -12,15 +19,20 @@ AF_INET constant SERVER_SOCKET_DOMAIN
         constant SERVER_SOCKET_TYPE
       0 constant SERVER_SOCKET_PROTOCOL
       0 constant SERVER_ADDR
-  50000 constant SERVER_PORT
+CONFIG_SERVER_PORT constant SERVER_PORT
-    128 constant SERVER_LISTEN_BACKLOG
+      4 constant SERVER_LISTEN_BACKLOG
 
 \ Listening file descriptor.
-variable listenfd
+0 variable! listenfd
-0 listenfd !
+
+\ If we should accept new connections.
+true variable! accept-connections
+
+\ If we should echo back command responses.
+true variable! command-echo
 
 \ Idle detection.
-variable idle false idle !
+false variable! idle
 : server-idle? ( -- flag ) idle @ ;
 : server-idle! ( flag -- ) idle ! ;
 
@@ -43,7 +55,7 @@ create optval /option_value allot
   saddr family w! ;
 
 : (assert-socket) ( result-n -- result-n )
-  dup 0< abort" socket() failed." ;
+  dup 0< abort" socket failed." ;
 : (assert-bind) ( result-n -- )
   0< abort" bind failed." ;
 : (assert-listen) ( result-n -- )
@@ -76,8 +88,11 @@ create optval /option_value allot
   (server-info) ;
 
 : (perform-disconnect) ( connection-addr -- )
+  dup connection.circuitid @ 0<> IF
+    dup connections.indexOf dos-remove-connection
+  THEN
   dup connection.connected false swap !
-      connection.fd @ close() throw ;
+      connection.fd @ close throw ;
 
 : (close-clients) ( -- )
   connections.count 0= IF
@@ -89,10 +104,10 @@ create optval /option_value allot
     THEN
   LOOP ;
 
-: (assert-close()) ( result-n -- )
+: (assert-close) ( result-n -- )
   0<> abort" close failed" ;
 : (close-server) ( -- )
-  listenfd @ close() (assert-close()) ;
+  listenfd @ close (assert-close) ;
 
 : (close-server-info) ( -- )
   cr ." Closed server connections." cr ;
@@ -129,6 +144,9 @@ create optval /option_value allot
   true (con!)
   con (store-connection) ;
 : (server-idle-accept) ( -- )
+  accept-connections @ invert IF
+    EXIT
+  THEN
   (try-accept) dup 0< IF
     (accept-error)
   ELSE
@@ -179,17 +197,32 @@ create optval /option_value allot
     THEN
   LOOP ;
 
-: (to-string) ( n -- addr c )  s>d <# #s #> ;
 : (connection.number>string) ( connection-addr -- c-addr u )
-  connection.number @ (to-string) ;
+  connection.number @ to-string ;
 : (connection.buffer>string) ( connection-addr -- c-addr u )
-  dup connection.buffer swap connection.bufferlen @ ;
+  dup connection.buffer swap connection.bufferlen @  ;
-: (format-sendbuffer) ( from-connection-addr -- )
+: (connection>name) ( connection-addr -- c-addr u )
-  >r sendbuffer-reset
+  s" Anon " pad place
-     s" Anon "                     sendbuffer-append
+  (connection.number>string) pad +place
-     r@ (connection.number>string) sendbuffer-append
+  pad count ;
-     s" : "                        sendbuffer-append
+: (expect-proxyline?) ( connection-addr -- flag )
-     r> (connection.buffer>string) sendbuffer-append
+  connection.circuitid @ 0= ;
+: (parse-proxyline) ( connection-addr -- )
+  dup >r (connection.buffer>string) proxyline>circuitid
+  dup r@ connection.bufferlen ! r@ connection.buffer swap move
+  r> connection.circuitid ! ;
+: (last-sendbuffer-char) ( -- c )
+  sendbuffer@ + 1- c@ ;
+: (maybe-append-newline) ( -- )
+  (last-sendbuffer-char) 10 <> IF
+    s\" \n" sendbuffer-append
+  THEN ;
+: (format-sendbuffer) ( msg-str from-str -- )
+  sendbuffer-reset
+  sendbuffer-append
+  s" : " sendbuffer-append
+         sendbuffer-append
+  (maybe-append-newline)
   sendbuffer-sanitize ;
 : (connected?) ( connection-addr -- )
   connection.connected @ ;
@@ -200,59 +233,156 @@ create optval /option_value allot
 : (check-send) ( result-n -- )
   0< IF ." Warning: send failed." cr THEN ;
 : (send-sendbuffer) ( to-connection-addr -- )
-  connection.fd @ sendbuffer@ 0 send (check-send) ;
+  connection.fd @ sendbuffer@ MSG_NOSIGNAL send (check-send) ;
-: (send) ( from-connection-addr to-connection-addr -- )
-  (send-sendbuffer) ;
 : (try-send) ( from-connection-addr to-connection-addr -- )
   2dup (send?) IF
     nip (send-sendbuffer)
   ELSE
     2drop
   THEN ;
-: server-recv ( from-connection-addr eventid-n )
+: (dos-update-stats) ( from-connection-addr -- )
-  drop dup (format-sendbuffer)
+  dup connections.indexOf
+  swap (connection.buffer>string) nip over dos-add-bytes
+  1 swap dos-add-lines ;
+: (dos-protect?) ( connection-addr -- flag )
+  connections.indexOf dos? ;
+: (dos-protect) ( connection-addr -- )
+  ." DOS protection enabled for circuit:" cr
+  dup connections.indexOf .dos-info
+  dup connections.indexOf true swap dos-handled!
+  connection.circuitid @ torcontrol-close-circuit ;
+: (is-command?) ( str -- flag )
+  1 min s" /" compare 0= ;
+create command-parser PARSER_SIZE allot
+: (extract-command) ( str -- str )
+  command-parser new-parser 1 parser>> parser-remaining ;
+: (parse-command) ( str -- str flag )
+  2dup (is-command?) IF
+    (extract-command) true
+  ELSE
+    false
+  THEN ;
+4096 constant REDIRECT_BUFFER_SIZE
+create server-redirect-buffer REDIRECT_BUFFER_SIZE allot
+create server-emit-buffer 1 chars allot
+variable redirect-broadcast-xt
+: (server-redirect-reset) ( -- )
+  s" " server-redirect-buffer xplace ;
+: (server-redirect-flush) ( -- )
+  server-redirect-buffer xcount redirect-broadcast-xt @ execute
+  (server-redirect-reset) ;
+: (server-type) ( str -- )
+\ overflow check 
+  dup cell + server-redirect-buffer xcount nip + REDIRECT_BUFFER_SIZE <= IF
+    server-redirect-buffer +xplace
+  ELSE
+    2drop
+  THEN ;
+: (server-emit) ( c -- )
+  server-emit-buffer c!
+  server-emit-buffer 1 chars (server-type) ;
+: (enable-redirect) ( -- )
+  ['] (server-emit) stdout-hook-emit
+  ['] (server-type) stdout-hook-type
+  (server-redirect-reset) ;
+: (disable-redirect) ( -- )
+  (server-redirect-flush)
+  stdout-hook-reset ;
+: (depth-evaluate) ( command-str -- )
+  depth 2 - >r
+  ['] evaluate catch IF
+    2drop ." An error has occured." cr
+  THEN
+  depth r> <> abort" aborting to fix stack." ;
+: (dispatch-admin-command) ( connection-addr command-str -- flag )
+  rot connection.admin @ IF
+    ['] (depth-evaluate) catch IF 2drop THEN true
+  ELSE
+    2drop false
+  THEN ;
+\ TODO: user command dispatching is very basic for now
+\ TODO: maybe make commands extendible at runtime?
+defer user-command-help   ( -- )
+defer user-command-users  ( -- )
+defer user-command-whoami ( connection-addr -- )
+' noop is user-command-help
+' noop is user-command-users
+' drop is user-command-whoami
+: (dispatch-user-command) ( connection-addr command-str -- )
+  2dup s" help" startswith IF
+    3drop user-command-help
+  ELSE 2dup s" users" startswith IF
+    3drop user-command-users
+  ELSE 2dup s" whoami" startswith IF
+    2drop user-command-whoami
+  ELSE
+    3drop ." Unknown user command." cr
+  THEN THEN THEN ;
+: (handle-command) ( connection-addr -- )
+  dup (connection.buffer>string) (parse-command) IF
+    (enable-redirect)
+    3dup (dispatch-admin-command) IF
+      3drop
+    ELSE
+      (dispatch-user-command)
+    THEN
+    (disable-redirect)
+  ELSE
+    2drop drop
+  THEN ;
+: (handle-broadcast) ( connection-addr -- )
+  dup >r (connection.buffer>string) r@ (connection>name) (format-sendbuffer)
+  r> (dos-update-stats)
+  sendbuffer@ type
   connections.count 0 DO
     dup I connections.at (try-send)
-  LOOP drop ;
+  LOOP ;
+: server-recv ( from-connection-addr eventid-n )
+  drop
+  dup (expect-proxyline?) IF
+    dup (parse-proxyline)
+    dup connection.circuitid @ over connections.indexOf dos-add-connection
+    dup (connection.buffer>string) nip 0= IF
+        drop EXIT
+    THEN
+  THEN
+  dup connections.indexOf dos-handled? IF
+    drop EXIT
+  THEN
+  dup (dos-protect?) IF
+    (dos-protect)
+  ELSE
+    dup (handle-broadcast)
+    (handle-command)
+  THEN ;
 
 : server-idle-accept ( eventdata-n eventid-n -- )
   2drop (server-idle-accept) ;
 : server-idle-recv ( eventdata-n eventid-n -- )
   2drop (server-idle-recv) ;
-variable (strstart)
+
-variable (strend)
+false variable! motd-cached
-: (>str) ( startindex-n endindex-n str-addr -- c-addr u )
+create motd-cache SENDBUFFER_SIZE allot
-  tuck + -rot + tuck - ;
+0 variable! motd-cache-length
-: (newline?) ( char -- flag ) 10 = ;
+: (sendbuffer-motd-line-append) ( str -- )
-\ TODO: FIXME: refactor and create words to be able to conveniently
+  s" Server: " sendbuffer-append
-\ TODO: FIXME: send "Server: ..." messages. This will be useful in the repl too.
+               sendbuffer-append
+  s\" \n"      sendbuffer-append ;
 : (prepare-motd) ( -- )
-\ TODO: FIXME: just write a proper parser at this point....
   sendbuffer-reset
-  -1 (strstart) !
+  motd-cached @ IF
-  -1 (strend) !
+    motd-cache motd-cache-length @ sendbuffer-append
-  motd@ 0 DO
+    EXIT
-    (strstart) @ -1 = IF
+  THEN
-      I (strstart) !
+  motd@ ['] (sendbuffer-motd-line-append) parse-motd
-    THEN
+  sendbuffer@ dup motd-cache-length ! motd-cache swap move ;
-    dup I + c@ (newline?) IF
-      I (strend) !
-    THEN
-    (strend) @ -1 <> IF
-      s" Server: " sendbuffer-append
-      dup (strstart) @ (strend) @ rot (>str) sendbuffer-append
-      s\" \n" sendbuffer-append
-      -1 (strstart) !
-      -1 (strend) !
-    THEN
-  LOOP drop ;
 : (prepare-empty-line) ( -- )
   sendbuffer-reset s\" Server: \n" sendbuffer-append ;
 : (prepare-identity) ( connection-addr -- )
   sendbuffer-reset
-  s\" Server: You are now known as \"Anon " sendbuffer-append
+  s\" Server: You are now known as \"" sendbuffer-append
-  (connection.number>string)                sendbuffer-append
+  (connection>name)                    sendbuffer-append
-  s\" \".\n"                                sendbuffer-append ;
+  s\" \".\n"                           sendbuffer-append ;
 : server-connection-new ( connection-addr eventid-n -- )
   drop ." New client connected!" cr
   dup (prepare-motd) (send-sendbuffer)
@@ -265,8 +395,9 @@ variable (strend)
 
 : server-commandline ( eventdata-n eventid-n -- )
   2drop commandline-ready? IF
-    space commandline-getline ['] evaluate catch dup 0= IF
+    commandline-getline 2dup logger.log cr
-      drop ."  ok"
+    ['] evaluate catch dup 0= IF
+      drop
     ELSE
       ." error code: " . 2drop
     THEN
@@ -285,6 +416,129 @@ variable (strend)
     I connections.at (send-sendbuffer)
   LOOP ;
 
+: user-help ( -- )
+  ." User commands: " cr
+  ." help   ( -- ) \ this help command" cr
+  ." users  ( -- ) \ display the connected users" cr
+  ." whoami ( -- ) \ display your name" cr ;
+
+: user-users ( -- )
+  connections.count 0= IF
+    EXIT
+  THEN
+  connections.count 0 DO
+    I connections.at connection.connected @ IF
+      ." Anon " I connections.at (connection.number>string) type cr
+    THEN
+  LOOP ." TODO: implement last active time." cr ;
+
+: user-whoami ( connection-addr -- )
+  ." You are Anon " (connection.number>string) type ." ." cr ;
+
+' user-help IS user-command-help
+' user-users IS user-command-users
+' user-whoami IS user-command-whoami
+
+: server-commands ( -- )
+\ List server commands.
+  ." Server commands: " cr cr
+  ." You may enter any valid forth expression" cr cr
+  ." server-commands    ( -- )         \ this help command" cr
+  ." server-admin       ( user-n -- )  \ make a user admin" cr
+  ." server-users       ( -- )         \ list connected users" cr
+  ." server-accept      ( flag -- )    \ accept new connections" cr
+  ." server-accepting?  ( -- )         \ check if the server is" cr
+  ."                                   \ accepting connections" cr
+  ." server-disconnect  ( user-n -- )  \ disconnect a user by closing the circuit" cr
+  ." server-broadcast   ( msg-str -- ) \ broadcast a server message to" cr
+  ."                                   \ all users" cr
+  ." server-message     ( msg-str user-n -- ) \ send a server message to" cr
+  ."                                          \ a specific user" cr
+;
+
+: help ( -- ) server-commands ;
+
+: (userid>connection) ( user-n -- connection-addr )
+  1- connections.at ;
+
+: server-admin ( user-n -- )
+  (userid>connection) connection.admin true swap ! ;
+
+: server-users ( -- )
+  connections.count 0= IF
+    ." No connected users." cr
+    EXIT
+  THEN
+  connections.count 0 DO
+    I connections.at dup connection.connected @ IF
+      dup ." Anon " (connection.number>string) type
+          ."  CircuitID " connection.circuitid @ . cr
+    ELSE
+      drop
+    THEN
+  LOOP ;
+
+: server-accept ( flag -- )
+  dup accept-connections ! IF
+    ." Server is set to accept new connections." cr
+  ELSE
+    ." Server is set to not accept new connections." cr
+  THEN ;
+
+: server-accepting? ( -- )
+  accept-connections @ IF
+    ." Server is currently accepting new connnections." cr
+  ELSE
+    ." Server is currently not accepting new connections." cr
+  THEN ;
+
+: server-disconnect ( user-n -- )
+  (userid>connection) dup connection.connected @ IF
+    connection.circuitid @ torcontrol-close-circuit
+    ." Tor circuit closed." cr
+  ELSE
+    drop ." User not connected." cr
+  THEN ;
+
+create broadcast-parser PARSER_SIZE allot
+: (nextline) ( -- line-str flag )
+  s\" \n" parser>>string IF
+    parser-extract 1 parser>>
+    parser-mark true
+  ELSE
+    parser-remaining 2dup nip 0> IF
+      parser>>| true
+    ELSE
+      false
+    THEN
+  THEN ;
+: server-broadcast ( msg-str -- )
+  connections.count 0= IF
+    EXIT
+  THEN
+  broadcast-parser new-parser
+  BEGIN
+    (nextline)
+  WHILE
+    s" Server" (format-sendbuffer)
+    connections.count 0 DO
+      I connections.at dup connection.connected @ IF
+        (send-sendbuffer)
+      ELSE
+        drop
+      THEN
+    LOOP
+  REPEAT 2drop ;
+: (assert-connected) ( connection-addr -- )
+  connection.connected @ invert abort" Not connected" ;
+: server-message ( msg-str user-n -- )
+  >r 2dup type
+  s" Server" (format-sendbuffer)
+  r> (userid>connection) dup (assert-connected)
+  (send-sendbuffer) ;
+
+' server-broadcast redirect-broadcast-xt !
+
 ' server-idle-accept       EVENT_IDLE              eventhandlers.append
 ' server-idle-recv         EVENT_IDLE              eventhandlers.append
 ' server-connection-new    EVENT_CONNECTION_NEW    eventhandlers.append

server/eventloop-server-experiment/stdout-hook.4th

@@ -0,0 +1,66 @@
+require util.4th
+require logger.4th
+
+\ The standard output will only be redirected in application code,
+\ not globally in gforth.
+
+\ We always log to a file but we have an optional hook.
+
+true variable! (stdout)
+true variable! (stdout-logger)
+true variable! (stdout-hook)
+
+: oldtype type ;
+: oldemit emit ;
+
+defer (emit)
+defer (type)
+
+: type ( str -- )
+  (stdout) @ IF 2dup oldtype THEN
+  (stdout-logger) @ IF 2dup logger.log THEN
+  (stdout-hook) @ IF 2dup (type) THEN
+  2drop ;
+
+create (emit-buffer) 1 chars allot
+: emit ( c -- )
+  (emit-buffer) c! (emit-buffer) 1 chars type ;
+
+: ." ( "str" -- )
+  [char] " parse
+  state @ IF
+    ]] sliteral type [[
+  ELSE
+    type
+  THEN ; immediate
+: space ( -- ) bl emit ;
+: cr ( -- ) 10 emit ;
+: . ( n -- )
+  to-string type bl emit ;
+: .s ( -- )
+  ." < " depth . ." > "
+  depth 0> IF
+    depth 0
+    BEGIN 2dup > WHILE 1+ rot >r REPEAT
+    drop 0
+    BEGIN 2dup > WHILE 1+ r> dup . -rot REPEAT
+    2drop
+  THEN ;
+
+: stdout ( flag -- ) (stdout) ! ;
+: stdout-logger ( flag -- ) (stdout-logger) ! ;
+: stdout-hook ( flag -- ) (stdout-hook) ! ;
+
+: stdout-hook-reset ( -- )
+  ['] drop IS (emit)
+  ['] 2drop is (type) ;
+
+: stdout-hook-emit ( xt -- )
+\ xt ( c -- )
+  is (emit) ;
+
+: stdout-hook-type ( xt -- )
+\ xt ( str -- )
+  is (type) ;
+
+stdout-hook-reset

server/eventloop-server-experiment/torcontrol-constants.4th

@@ -0,0 +1,2 @@
+0 constant TOR_CONTROL_AUTHMETHOD_NULL
+1 constant TOR_CONTROL_AUTHMETHOD_COOKIE

server/eventloop-server-experiment/torcontrol.4th

@@ -0,0 +1,97 @@
+\ Simple torcontrol interface that only supports closing circuits.
+\ We only support the authcookie authentication. We can retrieve the authcookie
+\ file location by doing the following:
+\
+\  telnet localhost 9051
+\  PROTOCOLINFO
+\
+\ The user that this server is running under must have permission to read
+\ the tor cookie file. On Debian the user must be added to the debian-tor group.
+\
+\ TODO: write a proper client for this?
+\ TODO: at least check for success responses?
+\ TODO: we only support ipv4 for now
+
+require unix/socket.fs
+
+require util.4th
+require extensions.4th
+
+512 constant TORCONTROL_SENDBUFFER_SIZE
+512 constant TORCONTROL_RECVBUFFER_SIZE
+ 32 constant TORCONTROL_COOKIE_FILESIZE
+ 64 constant TORCONTROL_COOKIE_SIZE
+
+           CONFIG_TOR_CONTROL_ADDR  constant TORCONTROL_ADDR
+           CONFIG_TOR_CONTROL_PORT  constant TORCONTROL_PORT
+CONFIG_TOR_CONTROL_COOKIE_FILEPATH sconstant TORCONTROL_COOKIE_FILEPATH
+
+create torcontrol-cookie TORCONTROL_COOKIE_SIZE allot
+create torcontrol-sendbuffer TORCONTROL_SENDBUFFER_SIZE allot
+create torcontrol-recvbuffer TORCONTROL_RECVBUFFER_SIZE allot
+
+CONFIG_TOR_CONTROL_AUTHMETHOD TOR_CONTROL_AUTHMETHOD_COOKIE = [IF]
+  variable (file)
+  : (zero-prefix) ( c -- str )
+    16 < IF s" 0" ELSE 0 0 THEN ;
+  : (byte>hex) ( c -- str )
+    hex to-string decimal ;
+  : (binarycookie>hexcookie) ( binary-str -- )
+    s" " pad place
+    over + swap DO
+      I c@ dup
+      (zero-prefix) pad +place
+      (byte>hex) pad +place
+    LOOP
+    pad count torcontrol-cookie swap move ;
+  : torcontrol-load-cookie ( str -- )
+    r/o open-file throw (file) !
+    torcontrol-recvbuffer TORCONTROL_COOKIE_FILESIZE (file) @ read-file abort" torcontrol read failed"
+    TORCONTROL_COOKIE_FILESIZE <> abort" torcontrol read failed."
+    torcontrol-recvbuffer TORCONTROL_COOKIE_FILESIZE (binarycookie>hexcookie)
+    (file) @ close-file abort" torcontrol close-file failed" ;
+    
+    TORCONTROL_COOKIE_FILEPATH torcontrol-load-cookie
+[THEN]
+
+variable (tcsocket)
+variable (tcsendbuffer-len)
+create (tcsaddr) /sockaddr_in alloterase
+: (reset) ( -- ) 0 (tcsendbuffer-len) ! ;
+: (append) ( str -- )
+  dup >r torcontrol-sendbuffer (tcsendbuffer-len) @ + swap move
+  r> (tcsendbuffer-len) +! ;
+: (sendbuffer@) ( -- str )
+  torcontrol-sendbuffer (tcsendbuffer-len) @ ;
+: (cookie) ( -- str ) torcontrol-cookie TORCONTROL_COOKIE_SIZE ;
+: (lf) ( -- str ) s\" \r\n" ;
+: torcontrol-close-circuit ( circuit-id-n -- )
+  (reset)
+  CONFIG_TOR_CONTROL_AUTHMETHOD CASE
+    TOR_CONTROL_AUTHMETHOD_NULL OF
+      s" AUTHENTICATE " (append) (lf) (append)
+    ENDOF
+    TOR_CONTROL_AUTHMETHOD_COOKIE OF
+      s" AUTHENTICATE " (append) (cookie) (append) (lf) (append)
+    ENDOF
+    ." unknown auth method with id " . abort
+  ENDCASE
+  
+  s" CLOSECIRCUIT " (append) to-string (append) (lf) (append)
+  S" QUIT" (append) (lf) (append)
+  
+  AF_INET SOCK_STREAM 0 socket (tcsocket) !
+  
+  TORCONTROL_PORT htons (tcsaddr) port w!
+  TORCONTROL_ADDR (tcsaddr) sin_addr l!
+  AF_INET (tcsaddr) family w!
+  (tcsocket) @ (tcsaddr) /sockaddr_in connect 0<> abort" connect failed"
+  (tcsocket) @ torcontrol-sendbuffer (tcsendbuffer-len) @ 0 send (tcsendbuffer-len) @ <> abort" send failed"
+  BEGIN
+    (tcsocket) @ torcontrol-recvbuffer TORCONTROL_RECVBUFFER_SIZE 0 recv
+\    dup 0> IF
+\      torcontrol-recvbuffer over type
+\    THEN
+    0=
+  UNTIL
+  (tcsocket) @ close 0<> abort" close failed" ;

server/eventloop-server-experiment/util.4th

@@ -0,0 +1,25 @@
+
+: sconstant ( "name" str -- )
+  2>r : 2r> postpone sliteral postpone ; ;
+
+: variable! ( "name" value-n -- )
+  create , ;
+
+: alloterase ( n -- )
+  here over allot swap erase ;
+
+: 3dup ( a b c -- a b c a b c )
+  >r 2dup r@ -rot r> ;
+
+: 3drop ( a b c -- )
+  2drop drop ;
+
+: to-string ( n -- str )
+  s>d <# #s #> ;
+
+: startswith ( str prefix-str -- flag )
+  2>r over swap 2r> search IF
+    drop =
+  ELSE
+    3drop false
+  THEN ;