@@ -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 |
@@ -0,0 +1 @@ | |||||
../../LICENSE |
@@ -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 |
@@ -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 |
@@ -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 |
@@ -1,3 +1,4 @@ | |||||
require util.4th | |||||
80 constant COMMANDLINE_SIZE | 80 constant COMMANDLINE_SIZE | ||||
create commandline COMMANDLINE_SIZE allot | create commandline COMMANDLINE_SIZE allot | ||||
@@ -40,7 +41,7 @@ variable cmdready | |||||
k-right of (cursor-right) endof | k-right of (cursor-right) endof | ||||
endcase | endcase | ||||
else ( keyboard-event ) | else ( keyboard-event ) | ||||
drop \ just ignore an unknown keyboard event type | |||||
drop \ just ignore an unknown keyboard event | |||||
then then ; | then then ; | ||||
: commandline-getline ( -- c-addr u ) | : commandline-getline ( -- c-addr u ) | ||||
@@ -48,14 +49,16 @@ variable cmdready | |||||
: (update-cursorpos) ( -- ) | : (update-cursorpos) ( -- ) | ||||
s\" \033[" type | s\" \033[" type | ||||
(cursor@) 1+ s>d <# #s #> type | |||||
(cursor@) 1+ to-string type | |||||
s" G" type ; | s" G" type ; | ||||
: (carriage-return) ( -- ) | : (carriage-return) ( -- ) | ||||
13 emit ; | 13 emit ; | ||||
: commandline-redraw ( -- ) | : commandline-redraw ( -- ) | ||||
false stdout-logger | |||||
(carriage-return) | (carriage-return) | ||||
commandline-getline type | commandline-getline type | ||||
(update-cursorpos) ; | |||||
(update-cursorpos) | |||||
true stdout-logger ; | |||||
: commandline-reset ( -- ) | : commandline-reset ( -- ) | ||||
commandline COMMANDLINE_SIZE bl fill | commandline COMMANDLINE_SIZE bl fill | ||||
@@ -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 |
@@ -1,18 +1,21 @@ | |||||
require util.4th | |||||
256 constant CONNECTION_BUFFER_SIZE | 256 constant CONNECTION_BUFFER_SIZE | ||||
0 | 0 | ||||
cell +field connection.number | cell +field connection.number | ||||
cell +field connection.admin | |||||
cell +field connection.fd | cell +field connection.fd | ||||
cell +field connection.connected | cell +field connection.connected | ||||
cell +field connection.sendcount | |||||
cell +field connection.circuitid | |||||
cell +field connection.bufferlen | cell +field connection.bufferlen | ||||
CONNECTION_BUFFER_SIZE +field connection.buffer | CONNECTION_BUFFER_SIZE +field connection.buffer | ||||
constant /CONNECTION | 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 | MAX_CONNECTIONS /CONNECTION * constant CONNECTIONS_SIZE | ||||
create connections CONNECTIONS_SIZE allot | create connections CONNECTIONS_SIZE allot | ||||
connections CONNECTIONS_SIZE erase | connections CONNECTIONS_SIZE erase | ||||
@@ -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 ; |
@@ -1,88 +1,38 @@ | |||||
256 constant MAX_EVENTS | |||||
require util.4th | |||||
1024 constant MAX_EVENTS | |||||
0 | 0 | ||||
cell +field event.id | cell +field event.id | ||||
cell +field event.data | cell +field event.data | ||||
constant /EVENT | 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 | 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 -- ) | : 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 ) | : 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 | events.clear |
@@ -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] |
@@ -0,0 +1,4 @@ | |||||
: time ( a -- n ) | |||||
abort" argument not supported" | |||||
utime #1000000 um/mod nip ; |
@@ -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 |
@@ -0,0 +1,6 @@ | |||||
$4000 constant MSG_NOSIGNAL | |||||
2048 constant SOCK_NONBLOCK | |||||
sockaddr_in constant /sockaddr_in | |||||
4 constant /option_value |
@@ -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!) ; |
@@ -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 ; | |||||
@@ -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 ; |
@@ -1,10 +1,15 @@ | |||||
require util.4th | |||||
require torcontrol-constants.4th | |||||
require configuration.4th | |||||
require stdout-hook.4th | |||||
require check-gforth.4th | require check-gforth.4th | ||||
require eventloop.4th | require eventloop.4th | ||||
require event-constants.4th | require event-constants.4th | ||||
require server.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 ) | : handle-command-line? ( -- flag ) | ||||
clcounter @ 10 >= dup IF | clcounter @ 10 >= dup IF | ||||
0 clcounter ! | 0 clcounter ! | ||||
@@ -12,20 +17,40 @@ variable clcounter | |||||
1 clcounter +! | 1 clcounter +! | ||||
THEN ; | THEN ; | ||||
0 variable! dostimer | |||||
: handle-dos? ( -- flag ) | |||||
0 time dup dostimer @ > IF | |||||
DOS_UPDATE_INTERVAL + dostimer ! | |||||
true | |||||
ELSE | |||||
drop false | |||||
THEN ; | |||||
: custom-eventloop ( -- ) | : custom-eventloop ( -- ) | ||||
BEGIN | BEGIN | ||||
handle-command-line? IF | handle-command-line? IF | ||||
0 EVENT_COMMANDLINE events.enqueue | 0 EVENT_COMMANDLINE events.enqueue | ||||
THEN | THEN | ||||
handle-dos? IF | |||||
dos-update | |||||
THEN | |||||
eventloop.has-events? IF | eventloop.has-events? IF | ||||
eventloop.dispatch | eventloop.dispatch | ||||
ELSE | ELSE | ||||
server-idle? IF | server-idle? IF | ||||
1 ms false server-idle! | |||||
10 ms false server-idle! | |||||
THEN | THEN | ||||
0 0 events.enqueue eventloop.dispatch | 0 0 events.enqueue eventloop.dispatch | ||||
THEN | THEN | ||||
AGAIN ; | 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 | main |
@@ -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 ; |
@@ -0,0 +1,3 @@ | |||||
Optional runtime patches that can be applied with: | |||||
require patches/mypatch.4th |
@@ -0,0 +1 @@ | |||||
s\" https://git.lain.church/emil/moontalk\n\nType /help for commands." motd-current-banner motd-compose |
@@ -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) ; |
@@ -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 | |||||
@@ -1,19 +1,48 @@ | |||||
variable sendbuffer-len 0 sendbuffer-len ! | |||||
require util.4th | |||||
require configuration.4th | |||||
0 variable! sendbuffer-len | |||||
4096 constant SENDBUFFER_SIZE | 4096 constant SENDBUFFER_SIZE | ||||
create sendbuffer SENDBUFFER_SIZE allot | 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 ! ; | : sendbuffer-reset ( -- ) 0 sendbuffer-len ! ; | ||||
: (overflow?) ( n -- flag ) | : (overflow?) ( n -- flag ) | ||||
@@ -24,5 +53,5 @@ end-c-library | |||||
: sendbuffer-append ( str -- ) | : sendbuffer-append ( str -- ) | ||||
dup (overflow?) abort" sendbuffer overflow" (append) ; | dup (overflow?) abort" sendbuffer overflow" (append) ; | ||||
: sendbuffer-sanitize ( -- ) | : sendbuffer-sanitize ( -- ) | ||||
sendbuffer sendbuffer-len @ csanitize ; | |||||
sendbuffer sendbuffer-len @ sanitize ; | |||||
: sendbuffer@ ( -- str ) sendbuffer sendbuffer-len @ ; | : sendbuffer@ ( -- str ) sendbuffer sendbuffer-len @ ; |
@@ -1,9 +1,16 @@ | |||||
require unix/socket.fs | require unix/socket.fs | ||||
require socket-extensions.4th | |||||
require libs/xstring/xstring.4th | |||||
require util.4th | |||||
require extensions.4th | |||||
require connections.4th | require connections.4th | ||||
require commandline.4th | require commandline.4th | ||||
require motd.4th | require motd.4th | ||||
require motd-parser.4th | |||||
require proxyline-parser.4th | |||||
require torcontrol.4th | |||||
require dos.4th | |||||
require sendbuffer.4th | require sendbuffer.4th | ||||
AF_INET constant SERVER_SOCKET_DOMAIN | AF_INET constant SERVER_SOCKET_DOMAIN | ||||
@@ -12,15 +19,20 @@ AF_INET constant SERVER_SOCKET_DOMAIN | |||||
constant SERVER_SOCKET_TYPE | constant SERVER_SOCKET_TYPE | ||||
0 constant SERVER_SOCKET_PROTOCOL | 0 constant SERVER_SOCKET_PROTOCOL | ||||
0 constant SERVER_ADDR | 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. | \ 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. | \ Idle detection. | ||||
variable idle false idle ! | |||||
false variable! idle | |||||
: server-idle? ( -- flag ) idle @ ; | : server-idle? ( -- flag ) idle @ ; | ||||
: server-idle! ( flag -- ) idle ! ; | : server-idle! ( flag -- ) idle ! ; | ||||
@@ -43,7 +55,7 @@ create optval /option_value allot | |||||
saddr family w! ; | saddr family w! ; | ||||
: (assert-socket) ( result-n -- result-n ) | : (assert-socket) ( result-n -- result-n ) | ||||
dup 0< abort" socket() failed." ; | |||||
dup 0< abort" socket failed." ; | |||||
: (assert-bind) ( result-n -- ) | : (assert-bind) ( result-n -- ) | ||||
0< abort" bind failed." ; | 0< abort" bind failed." ; | ||||
: (assert-listen) ( result-n -- ) | : (assert-listen) ( result-n -- ) | ||||
@@ -76,8 +88,11 @@ create optval /option_value allot | |||||
(server-info) ; | (server-info) ; | ||||
: (perform-disconnect) ( connection-addr -- ) | : (perform-disconnect) ( connection-addr -- ) | ||||
dup connection.circuitid @ 0<> IF | |||||
dup connections.indexOf dos-remove-connection | |||||
THEN | |||||
dup connection.connected false swap ! | dup connection.connected false swap ! | ||||
connection.fd @ close() throw ; | |||||
connection.fd @ close throw ; | |||||
: (close-clients) ( -- ) | : (close-clients) ( -- ) | ||||
connections.count 0= IF | connections.count 0= IF | ||||
@@ -89,10 +104,10 @@ create optval /option_value allot | |||||
THEN | THEN | ||||
LOOP ; | LOOP ; | ||||
: (assert-close()) ( result-n -- ) | |||||
: (assert-close) ( result-n -- ) | |||||
0<> abort" close failed" ; | 0<> abort" close failed" ; | ||||
: (close-server) ( -- ) | : (close-server) ( -- ) | ||||
listenfd @ close() (assert-close()) ; | |||||
listenfd @ close (assert-close) ; | |||||
: (close-server-info) ( -- ) | : (close-server-info) ( -- ) | ||||
cr ." Closed server connections." cr ; | cr ." Closed server connections." cr ; | ||||
@@ -129,6 +144,9 @@ create optval /option_value allot | |||||
true (con!) | true (con!) | ||||
con (store-connection) ; | con (store-connection) ; | ||||
: (server-idle-accept) ( -- ) | : (server-idle-accept) ( -- ) | ||||
accept-connections @ invert IF | |||||
EXIT | |||||
THEN | |||||
(try-accept) dup 0< IF | (try-accept) dup 0< IF | ||||
(accept-error) | (accept-error) | ||||
ELSE | ELSE | ||||
@@ -179,17 +197,32 @@ create optval /option_value allot | |||||
THEN | THEN | ||||
LOOP ; | LOOP ; | ||||
: (to-string) ( n -- addr c ) s>d <# #s #> ; | |||||
: (connection.number>string) ( connection-addr -- c-addr u ) | : (connection.number>string) ( connection-addr -- c-addr u ) | ||||
connection.number @ (to-string) ; | |||||
connection.number @ to-string ; | |||||
: (connection.buffer>string) ( connection-addr -- c-addr u ) | : (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 ; | sendbuffer-sanitize ; | ||||
: (connected?) ( connection-addr -- ) | : (connected?) ( connection-addr -- ) | ||||
connection.connected @ ; | connection.connected @ ; | ||||
@@ -200,59 +233,156 @@ create optval /option_value allot | |||||
: (check-send) ( result-n -- ) | : (check-send) ( result-n -- ) | ||||
0< IF ." Warning: send failed." cr THEN ; | 0< IF ." Warning: send failed." cr THEN ; | ||||
: (send-sendbuffer) ( to-connection-addr -- ) | : (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 -- ) | : (try-send) ( from-connection-addr to-connection-addr -- ) | ||||
2dup (send?) IF | 2dup (send?) IF | ||||
nip (send-sendbuffer) | nip (send-sendbuffer) | ||||
ELSE | ELSE | ||||
2drop | 2drop | ||||
THEN ; | 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 | connections.count 0 DO | ||||
dup I connections.at (try-send) | 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 -- ) | : server-idle-accept ( eventdata-n eventid-n -- ) | ||||
2drop (server-idle-accept) ; | 2drop (server-idle-accept) ; | ||||
: server-idle-recv ( eventdata-n eventid-n -- ) | : server-idle-recv ( eventdata-n eventid-n -- ) | ||||
2drop (server-idle-recv) ; | 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) ( -- ) | : (prepare-motd) ( -- ) | ||||
\ TODO: FIXME: just write a proper parser at this point.... | |||||
sendbuffer-reset | 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) ( -- ) | : (prepare-empty-line) ( -- ) | ||||
sendbuffer-reset s\" Server: \n" sendbuffer-append ; | sendbuffer-reset s\" Server: \n" sendbuffer-append ; | ||||
: (prepare-identity) ( connection-addr -- ) | : (prepare-identity) ( connection-addr -- ) | ||||
sendbuffer-reset | 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 -- ) | : server-connection-new ( connection-addr eventid-n -- ) | ||||
drop ." New client connected!" cr | drop ." New client connected!" cr | ||||
dup (prepare-motd) (send-sendbuffer) | dup (prepare-motd) (send-sendbuffer) | ||||
@@ -265,8 +395,9 @@ variable (strend) | |||||
: server-commandline ( eventdata-n eventid-n -- ) | : server-commandline ( eventdata-n eventid-n -- ) | ||||
2drop commandline-ready? IF | 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 | ELSE | ||||
." error code: " . 2drop | ." error code: " . 2drop | ||||
THEN | THEN | ||||
@@ -285,6 +416,129 @@ variable (strend) | |||||
I connections.at (send-sendbuffer) | I connections.at (send-sendbuffer) | ||||
LOOP ; | 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-accept EVENT_IDLE eventhandlers.append | ||||
' server-idle-recv EVENT_IDLE eventhandlers.append | ' server-idle-recv EVENT_IDLE eventhandlers.append | ||||
' server-connection-new EVENT_CONNECTION_NEW eventhandlers.append | ' server-connection-new EVENT_CONNECTION_NEW eventhandlers.append | ||||
@@ -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 |
@@ -0,0 +1,2 @@ | |||||
0 constant TOR_CONTROL_AUTHMETHOD_NULL | |||||
1 constant TOR_CONTROL_AUTHMETHOD_COOKIE |
@@ -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" ; |
@@ -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 ; |