@@ -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 | |||
create commandline COMMANDLINE_SIZE allot | |||
@@ -40,7 +41,7 @@ variable cmdready | |||
k-right of (cursor-right) endof | |||
endcase | |||
else ( keyboard-event ) | |||
drop \ just ignore an unknown keyboard event type | |||
drop \ just ignore an unknown keyboard event | |||
then then ; | |||
: commandline-getline ( -- c-addr u ) | |||
@@ -48,14 +49,16 @@ variable cmdready | |||
: (update-cursorpos) ( -- ) | |||
s\" \033[" type | |||
(cursor@) 1+ s>d <# #s #> type | |||
(cursor@) 1+ to-string type | |||
s" G" type ; | |||
: (carriage-return) ( -- ) | |||
13 emit ; | |||
: commandline-redraw ( -- ) | |||
false stdout-logger | |||
(carriage-return) | |||
commandline-getline type | |||
(update-cursorpos) ; | |||
(update-cursorpos) | |||
true stdout-logger ; | |||
: commandline-reset ( -- ) | |||
commandline COMMANDLINE_SIZE bl fill | |||
@@ -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 | |||
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 | |||
@@ -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 | |||
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 |
@@ -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 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 ! | |||
@@ -12,20 +17,40 @@ variable clcounter | |||
1 clcounter +! | |||
THEN ; | |||
0 variable! dostimer | |||
: handle-dos? ( -- flag ) | |||
0 time dup dostimer @ > IF | |||
DOS_UPDATE_INTERVAL + dostimer ! | |||
true | |||
ELSE | |||
drop false | |||
THEN ; | |||
: custom-eventloop ( -- ) | |||
BEGIN | |||
handle-command-line? IF | |||
0 EVENT_COMMANDLINE events.enqueue | |||
THEN | |||
handle-dos? IF | |||
dos-update | |||
THEN | |||
eventloop.has-events? IF | |||
eventloop.dispatch | |||
ELSE | |||
server-idle? IF | |||
1 ms false server-idle! | |||
10 ms false server-idle! | |||
THEN | |||
0 0 events.enqueue eventloop.dispatch | |||
THEN | |||
AGAIN ; | |||
: main ( -- ) ['] custom-eventloop catch close-server throw ; | |||
: main ( -- ) | |||
logger.open | |||
['] custom-eventloop catch close-server throw | |||
logger.close ; | |||
\ : main ( -- ) | |||
\ logger.open | |||
\ custom-eventloop close-server | |||
\ logger.close ; | |||
main |
@@ -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 | |||
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 ) | |||
@@ -24,5 +53,5 @@ end-c-library | |||
: sendbuffer-append ( str -- ) | |||
dup (overflow?) abort" sendbuffer overflow" (append) ; | |||
: sendbuffer-sanitize ( -- ) | |||
sendbuffer sendbuffer-len @ csanitize ; | |||
sendbuffer sendbuffer-len @ sanitize ; | |||
: sendbuffer@ ( -- str ) sendbuffer sendbuffer-len @ ; |
@@ -1,9 +1,16 @@ | |||
require unix/socket.fs | |||
require socket-extensions.4th | |||
require libs/xstring/xstring.4th | |||
require util.4th | |||
require extensions.4th | |||
require connections.4th | |||
require commandline.4th | |||
require motd.4th | |||
require motd-parser.4th | |||
require proxyline-parser.4th | |||
require torcontrol.4th | |||
require dos.4th | |||
require sendbuffer.4th | |||
AF_INET constant SERVER_SOCKET_DOMAIN | |||
@@ -12,15 +19,20 @@ AF_INET constant SERVER_SOCKET_DOMAIN | |||
constant SERVER_SOCKET_TYPE | |||
0 constant SERVER_SOCKET_PROTOCOL | |||
0 constant SERVER_ADDR | |||
50000 constant SERVER_PORT | |||
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 ! ; | |||
@@ -43,7 +55,7 @@ create optval /option_value allot | |||
saddr family w! ; | |||
: (assert-socket) ( result-n -- result-n ) | |||
dup 0< abort" socket() failed." ; | |||
dup 0< abort" socket failed." ; | |||
: (assert-bind) ( result-n -- ) | |||
0< abort" bind failed." ; | |||
: (assert-listen) ( result-n -- ) | |||
@@ -76,8 +88,11 @@ create optval /option_value allot | |||
(server-info) ; | |||
: (perform-disconnect) ( connection-addr -- ) | |||
dup connection.circuitid @ 0<> IF | |||
dup connections.indexOf dos-remove-connection | |||
THEN | |||
dup connection.connected false swap ! | |||
connection.fd @ close() throw ; | |||
connection.fd @ close throw ; | |||
: (close-clients) ( -- ) | |||
connections.count 0= IF | |||
@@ -89,10 +104,10 @@ create optval /option_value allot | |||
THEN | |||
LOOP ; | |||
: (assert-close()) ( result-n -- ) | |||
: (assert-close) ( result-n -- ) | |||
0<> abort" close failed" ; | |||
: (close-server) ( -- ) | |||
listenfd @ close() (assert-close()) ; | |||
listenfd @ close (assert-close) ; | |||
: (close-server-info) ( -- ) | |||
cr ." Closed server connections." cr ; | |||
@@ -129,6 +144,9 @@ create optval /option_value allot | |||
true (con!) | |||
con (store-connection) ; | |||
: (server-idle-accept) ( -- ) | |||
accept-connections @ invert IF | |||
EXIT | |||
THEN | |||
(try-accept) dup 0< IF | |||
(accept-error) | |||
ELSE | |||
@@ -179,17 +197,32 @@ create optval /option_value allot | |||
THEN | |||
LOOP ; | |||
: (to-string) ( n -- addr c ) s>d <# #s #> ; | |||
: (connection.number>string) ( connection-addr -- c-addr u ) | |||
connection.number @ (to-string) ; | |||
connection.number @ to-string ; | |||
: (connection.buffer>string) ( connection-addr -- c-addr u ) | |||
dup connection.buffer swap connection.bufferlen @ ; | |||
: (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 @ ; | |||
@@ -200,59 +233,156 @@ create optval /option_value allot | |||
: (check-send) ( result-n -- ) | |||
0< IF ." Warning: send failed." cr THEN ; | |||
: (send-sendbuffer) ( to-connection-addr -- ) | |||
connection.fd @ sendbuffer@ 0 send (check-send) ; | |||
: (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) | |||
@@ -265,8 +395,9 @@ variable (strend) | |||
: 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 | |||
@@ -285,6 +416,129 @@ variable (strend) | |||
I connections.at (send-sendbuffer) | |||
LOOP ; | |||
: user-help ( -- ) | |||
." User commands: " cr | |||
." help ( -- ) \ this help command" cr | |||
." users ( -- ) \ display the connected users" cr | |||
." whoami ( -- ) \ display your name" cr ; | |||
: user-users ( -- ) | |||
connections.count 0= IF | |||
EXIT | |||
THEN | |||
connections.count 0 DO | |||
I connections.at connection.connected @ IF | |||
." Anon " I connections.at (connection.number>string) type cr | |||
THEN | |||
LOOP ." TODO: implement last active time." cr ; | |||
: user-whoami ( connection-addr -- ) | |||
." You are Anon " (connection.number>string) type ." ." cr ; | |||
' user-help IS user-command-help | |||
' user-users IS user-command-users | |||
' user-whoami IS user-command-whoami | |||
: server-commands ( -- ) | |||
\ List server commands. | |||
." Server commands: " cr cr | |||
." You may enter any valid forth expression" cr cr | |||
." server-commands ( -- ) \ this help command" cr | |||
." server-admin ( user-n -- ) \ make a user admin" cr | |||
." server-users ( -- ) \ list connected users" cr | |||
." server-accept ( flag -- ) \ accept new connections" cr | |||
." server-accepting? ( -- ) \ check if the server is" cr | |||
." \ accepting connections" cr | |||
." server-disconnect ( user-n -- ) \ disconnect a user by closing the circuit" cr | |||
." server-broadcast ( msg-str -- ) \ broadcast a server message to" cr | |||
." \ all users" cr | |||
." server-message ( msg-str user-n -- ) \ send a server message to" cr | |||
." \ a specific user" cr | |||
; | |||
: help ( -- ) server-commands ; | |||
: (userid>connection) ( user-n -- connection-addr ) | |||
1- connections.at ; | |||
: server-admin ( user-n -- ) | |||
(userid>connection) connection.admin true swap ! ; | |||
: server-users ( -- ) | |||
connections.count 0= IF | |||
." No connected users." cr | |||
EXIT | |||
THEN | |||
connections.count 0 DO | |||
I connections.at dup connection.connected @ IF | |||
dup ." Anon " (connection.number>string) type | |||
." CircuitID " connection.circuitid @ . cr | |||
ELSE | |||
drop | |||
THEN | |||
LOOP ; | |||
: server-accept ( flag -- ) | |||
dup accept-connections ! IF | |||
." Server is set to accept new connections." cr | |||
ELSE | |||
." Server is set to not accept new connections." cr | |||
THEN ; | |||
: server-accepting? ( -- ) | |||
accept-connections @ IF | |||
." Server is currently accepting new connnections." cr | |||
ELSE | |||
." Server is currently not accepting new connections." cr | |||
THEN ; | |||
: server-disconnect ( user-n -- ) | |||
(userid>connection) dup connection.connected @ IF | |||
connection.circuitid @ torcontrol-close-circuit | |||
." Tor circuit closed." cr | |||
ELSE | |||
drop ." User not connected." cr | |||
THEN ; | |||
create broadcast-parser PARSER_SIZE allot | |||
: (nextline) ( -- line-str flag ) | |||
s\" \n" parser>>string IF | |||
parser-extract 1 parser>> | |||
parser-mark true | |||
ELSE | |||
parser-remaining 2dup nip 0> IF | |||
parser>>| true | |||
ELSE | |||
false | |||
THEN | |||
THEN ; | |||
: server-broadcast ( msg-str -- ) | |||
connections.count 0= IF | |||
EXIT | |||
THEN | |||
broadcast-parser new-parser | |||
BEGIN | |||
(nextline) | |||
WHILE | |||
s" Server" (format-sendbuffer) | |||
connections.count 0 DO | |||
I connections.at dup connection.connected @ IF | |||
(send-sendbuffer) | |||
ELSE | |||
drop | |||
THEN | |||
LOOP | |||
REPEAT 2drop ; | |||
: (assert-connected) ( connection-addr -- ) | |||
connection.connected @ invert abort" Not connected" ; | |||
: server-message ( msg-str user-n -- ) | |||
>r 2dup type | |||
s" Server" (format-sendbuffer) | |||
r> (userid>connection) dup (assert-connected) | |||
(send-sendbuffer) ; | |||
' server-broadcast redirect-broadcast-xt ! | |||
' server-idle-accept EVENT_IDLE eventhandlers.append | |||
' server-idle-recv EVENT_IDLE eventhandlers.append | |||
' server-connection-new EVENT_CONNECTION_NEW eventhandlers.append | |||
@@ -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 ; |