--- /dev/null
+[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
--- /dev/null
+../../LICENSE
\ No newline at end of file
--- /dev/null
+#!/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
+++ /dev/null
-#!/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
--- /dev/null
+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
+require util.4th
80 constant COMMANDLINE_SIZE
create commandline COMMANDLINE_SIZE allot
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 )
: (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
--- /dev/null
+
+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
+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 !
-variable largest-index -1 largest-index !
+-1 variable! last-connection
+-1 variable! largest-index
MAX_CONNECTIONS /CONNECTION * constant CONNECTIONS_SIZE
create connections CONNECTIONS_SIZE allot
connections CONNECTIONS_SIZE erase
--- /dev/null
+\ 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 ;
-256 constant MAX_EVENTS
+require util.4th
+
+1024 constant MAX_EVENTS
0
cell +field event.id
cell +field event.data
constant /EVENT
-0
- cell +field eventlink.next
- /EVENT +field eventlink.event
-constant /EVENTLINK
+0 variable! current-event
+0 variable! last-event
-variable first-event
-variable last-event
-variable free-event
-MAX_EVENTS /EVENTLINK * constant EVENTS_SIZE
+MAX_EVENTS /EVENT * constant EVENTS_SIZE
create events EVENTS_SIZE allot
-: (translate) ( index-u -- eventlink-addr )
- /EVENTLINK * events + ;
-: (link-to-next) ( index-u -- )
- dup 1+ (translate) swap (translate) eventlink.next ! ;
-: (fix-last-link) ( -- )
- MAX_EVENTS 1- (translate) eventlink.next 0 swap ! ;
-: (set-first-free) ( -- )
- 0 (translate) free-event ! ;
-: (link-free) ( -- )
- MAX_EVENTS 0 DO I (link-to-next) LOOP
- (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 ! ;
+: (translate) ( index-u -- event-addr )
+ ]] /EVENT * events + [[ ; IMMEDIATE
+: (wrap) ( index-u -- index-u )
+ ]] MAX_EVENTS mod [[ ; IMMEDIATE
+: (read) ( addr -- data-u id-u )
+ ]] dup event.data @ swap event.id @ [[ ; IMMEDIATE
+: (write) ( data-u id-u addr -- )
+ ]] tuck event.id ! event.data ! [[ ; IMMEDIATE
+: events.has-item? ( -- flag )
+ current-event @ last-event @ <> ;
: events.enqueue ( data-u id-u -- )
- (next-free) dup >r (set-eventdata) r> (append-event) ;
-: (get-eventdata) ( eventlink-addr -- data-u id-u )
- 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) ;
+ last-event @ dup 1+ dup >r current-event @ = abort" Queue is full."
+ (translate) (write) r> (wrap) last-event ! ;
: events.dequeue ( -- data-u id-u )
- (assert-first-exists) (get-first-event) (set-first-event-to-next)
- dup (free-event) (get-eventdata) ;
-: events.has-item? ( -- flag ) (first-event-exists?) ;
+ events.has-item? invert abort" No events in queue."
+ current-event @ dup (translate) (read)
+ rot 1+ (wrap) current-event ! ;
+: events.clear ( -- )
+ 0 current-event !
+ 0 last-event !
+ events EVENTS_SIZE erase ;
-\ Clear events, initialize events array.
events.clear
--- /dev/null
+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]
--- /dev/null
+
+: time ( a -- n )
+ abort" argument not supported"
+ utime #1000000 um/mod nip ;
--- /dev/null
+
+
+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
--- /dev/null
+
+$4000 constant MSG_NOSIGNAL
+2048 constant SOCK_NONBLOCK
+
+sockaddr_in constant /sockaddr_in
+4 constant /option_value
--- /dev/null
+\ 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!) ;
--- /dev/null
+\ 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 ;
+
--- /dev/null
+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 ;
+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
-0 clcounter !
+\ TODO: integrate generic timed event handling into the event loop?
+
+0 variable! clcounter
: handle-command-line? ( -- flag )
clcounter @ 10 >= dup IF
0 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
--- /dev/null
+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 ;
--- /dev/null
+Optional runtime patches that can be applied with:
+
+require patches/mypatch.4th
--- /dev/null
+s\" https://git.lain.church/emil/moontalk\n\nType /help for commands." motd-current-banner motd-compose
--- /dev/null
+
+: 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) ;
--- /dev/null
+\ 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
+
-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.
-c-library sanitizelib
-\c void csanitize(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 csanitize csanitize a n -- void
-end-c-library
+CONFIG_C_FFI invert [IF]
+ variable last-is-newline
+ : (last) ( c-addr u -- c-addr )
+ 1- + ;
+ : (sanitize-char) ( c-addr -- )
+ dup c@ dup 32 < swap 126 > or IF
+ [char] ? swap c!
+ ELSE
+ drop
+ THEN ;
+ : sanitize ( c-addr u -- )
+ 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 )
: sendbuffer-append ( str -- )
dup (overflow?) abort" sendbuffer overflow" (append) ;
: sendbuffer-sanitize ( -- )
- sendbuffer sendbuffer-len @ csanitize ;
+ sendbuffer sendbuffer-len @ sanitize ;
: sendbuffer@ ( -- str ) sendbuffer sendbuffer-len @ ;
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
constant SERVER_SOCKET_TYPE
0 constant SERVER_SOCKET_PROTOCOL
0 constant SERVER_ADDR
- 50000 constant SERVER_PORT
- 128 constant SERVER_LISTEN_BACKLOG
+CONFIG_SERVER_PORT constant SERVER_PORT
+ 4 constant SERVER_LISTEN_BACKLOG
\ Listening file descriptor.
-variable listenfd
-0 listenfd !
+0 variable! 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 ! ;
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 -- )
(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
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 ;
true (con!)
con (store-connection) ;
: (server-idle-accept) ( -- )
+ accept-connections @ invert IF
+ EXIT
+ THEN
(try-accept) dup 0< IF
(accept-error)
ELSE
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 @ ;
-: (format-sendbuffer) ( from-connection-addr -- )
- >r sendbuffer-reset
- s" Anon " sendbuffer-append
- r@ (connection.number>string) sendbuffer-append
- s" : " sendbuffer-append
- r> (connection.buffer>string) sendbuffer-append
+ dup connection.buffer swap connection.bufferlen @ ;
+: (connection>name) ( connection-addr -- c-addr u )
+ s" Anon " pad place
+ (connection.number>string) pad +place
+ pad count ;
+: (expect-proxyline?) ( connection-addr -- flag )
+ 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 @ ;
: (check-send) ( result-n -- )
0< IF ." Warning: send failed." cr THEN ;
: (send-sendbuffer) ( to-connection-addr -- )
- connection.fd @ sendbuffer@ 0 send (check-send) ;
-: (send) ( from-connection-addr to-connection-addr -- )
- (send-sendbuffer) ;
+ connection.fd @ sendbuffer@ MSG_NOSIGNAL send (check-send) ;
: (try-send) ( from-connection-addr to-connection-addr -- )
2dup (send?) IF
nip (send-sendbuffer)
ELSE
2drop
THEN ;
-: server-recv ( from-connection-addr eventid-n )
- drop dup (format-sendbuffer)
+: (dos-update-stats) ( from-connection-addr -- )
+ 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)
-: (>str) ( startindex-n endindex-n str-addr -- c-addr u )
- tuck + -rot + tuck - ;
-: (newline?) ( char -- flag ) 10 = ;
-\ TODO: FIXME: refactor and create words to be able to conveniently
-\ TODO: FIXME: send "Server: ..." messages. This will be useful in the repl too.
+
+false variable! motd-cached
+create motd-cache SENDBUFFER_SIZE allot
+0 variable! motd-cache-length
+: (sendbuffer-motd-line-append) ( str -- )
+ s" Server: " sendbuffer-append
+ sendbuffer-append
+ s\" \n" sendbuffer-append ;
: (prepare-motd) ( -- )
-\ TODO: FIXME: just write a proper parser at this point....
sendbuffer-reset
- -1 (strstart) !
- -1 (strend) !
- motd@ 0 DO
- (strstart) @ -1 = IF
- I (strstart) !
- THEN
- 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 ;
+ motd-cached @ IF
+ motd-cache motd-cache-length @ sendbuffer-append
+ EXIT
+ THEN
+ motd@ ['] (sendbuffer-motd-line-append) parse-motd
+ sendbuffer@ dup motd-cache-length ! motd-cache swap move ;
: (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
- (connection.number>string) sendbuffer-append
- s\" \".\n" sendbuffer-append ;
+ s\" Server: You are now known as \"" sendbuffer-append
+ (connection>name) sendbuffer-append
+ s\" \".\n" sendbuffer-append ;
: server-connection-new ( connection-addr eventid-n -- )
drop ." New client connected!" cr
dup (prepare-motd) (send-sendbuffer)
: server-commandline ( eventdata-n eventid-n -- )
2drop commandline-ready? IF
- space commandline-getline ['] evaluate catch dup 0= IF
- drop ." ok"
+ commandline-getline 2dup logger.log cr
+ ['] evaluate catch dup 0= IF
+ drop
ELSE
." error code: " . 2drop
THEN
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
--- /dev/null
+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
--- /dev/null
+0 constant TOR_CONTROL_AUTHMETHOD_NULL
+1 constant TOR_CONTROL_AUTHMETHOD_COOKIE
--- /dev/null
+\ 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" ;
--- /dev/null
+
+: 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 ;
projects / public-moontalk.git / commitdiff