|
- require unix/socket.fs
-
- 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
- SOCK_STREAM
- SOCK_NONBLOCK or
- constant SERVER_SOCKET_TYPE
- 0 constant SERVER_SOCKET_PROTOCOL
- 0 constant SERVER_ADDR
- CONFIG_SERVER_PORT constant SERVER_PORT
- 4 constant SERVER_LISTEN_BACKLOG
-
- \ Listening file descriptor.
- 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.
- false variable! idle
- : server-idle? ( -- flag ) idle @ ;
- : server-idle! ( flag -- ) idle ! ;
-
- \ Temporary structs.
- create con /CONNECTION allot
- create saddr /sockaddr_in allot
- create optval /option_value allot
-
- : (assert-setsockopt) ( result-n -- )
- 0< abort" making socket reusable failed" ;
- : (optval-true!) ( -- )
- 1 optval l! ;
- : (make-reusable) ( socket-fd-n -- )
- (optval-true!)
- SOL_SOCKET SO_REUSEADDR optval /option_value setsockopt (assert-setsockopt) ;
-
- : (saddr!) ( protocol-n sin_addr-n port-n -- )
- htons saddr port w!
- saddr sin_addr l!
- saddr family w! ;
-
- : (assert-socket) ( result-n -- result-n )
- dup 0< abort" socket failed." ;
- : (assert-bind) ( result-n -- )
- 0< abort" bind failed." ;
- : (assert-listen) ( result-n -- )
- 0< abort" listen failed." ;
-
- : (erase-saddr) ( -- )
- saddr /sockaddr_in erase ;
- : (create-socket) ( -- )
- SERVER_SOCKET_DOMAIN
- SERVER_SOCKET_TYPE
- SERVER_SOCKET_PROTOCOL
- socket (assert-socket) listenfd ! ;
- : (make-socket-reusable) ( -- )
- listenfd @ (make-reusable) ;
- : (set-saddr) ( -- )
- SERVER_SOCKET_DOMAIN SERVER_ADDR SERVER_PORT (saddr!) ;
- : (bind-socket) ( -- )
- listenfd @ saddr /sockaddr_in bind (assert-bind) ;
- : (listen-socket) ( -- )
- listenfd @ SERVER_LISTEN_BACKLOG listen() (assert-listen) ;
- : (server-info) ( -- )
- cr cr ." Server listening at port: " SERVER_PORT . cr ;
- : initialize-server ( -- )
- (erase-saddr)
- (create-socket)
- (make-socket-reusable)
- (set-saddr)
- (bind-socket)
- (listen-socket)
- (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 ;
-
- : (close-clients) ( -- )
- connections.count 0= IF
- EXIT
- THEN
- connections.count 0 DO
- I connections.at connection.connected @ true = IF
- I connections.at (perform-disconnect)
- THEN
- LOOP ;
-
- : (assert-close) ( result-n -- )
- 0<> abort" close failed" ;
- : (close-server) ( -- )
- listenfd @ close (assert-close) ;
-
- : (close-server-info) ( -- )
- cr ." Closed server connections." cr ;
- : close-server ( -- )
- (close-clients) (close-server) (close-server-info) ;
-
- : (queue-disconnect) ( connection-addr -- )
- dup (perform-disconnect) EVENT_CONNECTION_CLOSED events.enqueue ;
-
- : (try-accept) ( -- c-result-n )
- listenfd @ 0 0 accept() ;
- : (accept-error) ( accept-result-n -- )
- errno EAGAIN <> abort" accept error" drop ;
- : (erase-connection) ( connection-addr -- )
- /CONNECTION erase ;
- : (set-connection-number) ( -- )
- connections.last dup connections.indexOf 1+ swap connection.number ! ;
- : (enqueue-new-connection) ( -- )
- connections.last EVENT_CONNECTION_NEW events.enqueue ;
- : (store-connection) ( connection-addr -- )
- dup >r connections.append IF
- (set-connection-number)
- (enqueue-new-connection)
- rdrop
- ELSE
- ." Warning: failed to store connection, disconnecting client." cr
- r> (perform-disconnect)
- THEN ;
- : (con!) ( fd-n connected-flag -- )
- con connection.connected !
- con connection.fd ! ;
- : (accept-connection) ( fd-n -- )
- con (erase-connection)
- true (con!)
- con (store-connection) ;
- : (server-idle-accept) ( -- )
- accept-connections @ invert IF
- EXIT
- THEN
- (try-accept) dup 0< IF
- (accept-error)
- ELSE
- (accept-connection)
- THEN ;
-
- : (connected?) ( connection-addr -- flag )
- connection.connected @ ;
- : (try-recv) ( connection-addr -- recv-result-n )
- dup connection.fd @
- swap connection.buffer
- CONNECTION_BUFFER_SIZE
- MSG_DONTWAIT
- recv ;
- : (recv-error?) ( c-result-n -- flag ) 0< ;
- : (recv) ( recv-result-n connection-addr -- )
- 2dup connection.bufferlen ! swap
- 0> IF
- EVENT_CONNECTION_RECV events.enqueue
- ELSE \ disconnected
- (queue-disconnect)
- THEN ;
- : (recv-warning) ( -- ) ." Warning: recv failed, disconnecting client." cr ;
- : (recv-error) ( recv-result-n connection-addr -- )
- errno EAGAIN <> IF
- (queue-disconnect) drop
- (recv-warning)
- ELSE
- 2drop
- THEN ;
- : (connection-recv) ( connection-addr -- )
- dup (try-recv) tuck (recv-error?) IF
- (recv-error)
- ELSE
- (recv)
- THEN ;
-
- : (server-idle-recv) ( -- )
- true server-idle!
- connections.count 0= IF
- EXIT
- THEN
- connections.count 0 DO
- I connections.at dup (connected?) IF
- (connection-recv)
- ELSE
- drop
- THEN
- LOOP ;
-
- : (connection.number>string) ( connection-addr -- c-addr u )
- connection.number @ to-string ;
- : (connection.buffer>string) ( connection-addr -- c-addr u )
- 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 @ ;
- : (different-connection?) ( from-connection-addr to-connection-addr -- )
- <> ;
- : (send?) ( from-connection-addr to-connection-addr -- )
- tuck (different-connection?) swap (connected?) and ;
- : (check-send) ( result-n -- )
- 0< IF ." Warning: send failed." cr THEN ;
- : (send-sendbuffer) ( to-connection-addr -- )
- 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 ;
- : (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 ;
- : 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) ;
-
- 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) ( -- )
- sendbuffer-reset
- 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 \"" 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)
- dup (prepare-empty-line) (send-sendbuffer)
- dup (prepare-identity)
- (send-sendbuffer) ;
-
- : server-connection-closed ( connection-addr eventid-n -- )
- 2drop ." Client disconnected." cr ;
-
- : server-commandline ( eventdata-n eventid-n -- )
- 2drop commandline-ready? IF
- commandline-getline 2dup logger.log cr
- ['] evaluate catch dup 0= IF
- drop
- ELSE
- ." error code: " . 2drop
- THEN
- cr
- commandline-reset
- ELSE
- commandline-key? IF
- commandline-key commandline-handlekey
- commandline-redraw
- THEN
- THEN ;
-
- : server-motd-changed ( eventdata-n eventid-n -- )
- 2drop (prepare-motd)
- connections.count 0 DO
- I connections.at (send-sendbuffer)
- LOOP ;
-
- : user-help ( -- )
- ." User commands: " cr
- ." help ( -- ) \ this help command" cr
- ." users ( -- ) \ display the connected users" cr
- ." whoami ( -- ) \ display your name" cr ;
-
- : user-users ( -- )
- connections.count 0= IF
- EXIT
- THEN
- connections.count 0 DO
- I connections.at connection.connected @ IF
- ." Anon " I connections.at (connection.number>string) type cr
- THEN
- LOOP ." TODO: implement last active time." cr ;
-
- : user-whoami ( connection-addr -- )
- ." You are Anon " (connection.number>string) type ." ." cr ;
-
- ' user-help IS user-command-help
- ' user-users IS user-command-users
- ' user-whoami IS user-command-whoami
-
- : server-commands ( -- )
- \ List server commands.
- ." Server commands: " cr cr
- ." You may enter any valid forth expression" cr cr
- ." server-commands ( -- ) \ this help command" cr
- ." server-admin ( user-n -- ) \ make a user admin" cr
- ." server-users ( -- ) \ list connected users" cr
- ." server-accept ( flag -- ) \ accept new connections" cr
- ." server-accepting? ( -- ) \ check if the server is" cr
- ." \ accepting connections" cr
- ." server-disconnect ( user-n -- ) \ disconnect a user by closing the circuit" cr
- ." server-broadcast ( msg-str -- ) \ broadcast a server message to" cr
- ." \ all users" cr
- ." server-message ( msg-str user-n -- ) \ send a server message to" cr
- ." \ a specific user" cr
- ;
-
- : help ( -- ) server-commands ;
-
- : (userid>connection) ( user-n -- connection-addr )
- 1- connections.at ;
-
- : server-admin ( user-n -- )
- (userid>connection) connection.admin true swap ! ;
-
- : server-users ( -- )
- connections.count 0= IF
- ." No connected users." cr
- EXIT
- THEN
- connections.count 0 DO
- I connections.at dup connection.connected @ IF
- dup ." Anon " (connection.number>string) type
- ." CircuitID " connection.circuitid @ . cr
- ELSE
- drop
- THEN
- LOOP ;
-
- : server-accept ( flag -- )
- dup accept-connections ! IF
- ." Server is set to accept new connections." cr
- ELSE
- ." Server is set to not accept new connections." cr
- THEN ;
-
- : server-accepting? ( -- )
- accept-connections @ IF
- ." Server is currently accepting new connnections." cr
- ELSE
- ." Server is currently not accepting new connections." cr
- THEN ;
-
- : server-disconnect ( user-n -- )
- (userid>connection) dup connection.connected @ IF
- connection.circuitid @ torcontrol-close-circuit
- ." Tor circuit closed." cr
- ELSE
- drop ." User not connected." cr
- THEN ;
-
- create broadcast-parser PARSER_SIZE allot
- : (nextline) ( -- line-str flag )
- s\" \n" parser>>string IF
- parser-extract 1 parser>>
- parser-mark true
- ELSE
- parser-remaining 2dup nip 0> IF
- parser>>| true
- ELSE
- false
- THEN
- THEN ;
- : server-broadcast ( msg-str -- )
- connections.count 0= IF
- EXIT
- THEN
- broadcast-parser new-parser
- BEGIN
- (nextline)
- WHILE
- s" Server" (format-sendbuffer)
- connections.count 0 DO
- I connections.at dup connection.connected @ IF
- (send-sendbuffer)
- ELSE
- drop
- THEN
- LOOP
- REPEAT 2drop ;
- : (assert-connected) ( connection-addr -- )
- connection.connected @ invert abort" Not connected" ;
- : server-message ( msg-str user-n -- )
- >r 2dup type
- s" Server" (format-sendbuffer)
- r> (userid>connection) dup (assert-connected)
- (send-sendbuffer) ;
-
- ' server-broadcast redirect-broadcast-xt !
-
- ' server-idle-accept EVENT_IDLE eventhandlers.append
- ' server-idle-recv EVENT_IDLE eventhandlers.append
- ' server-connection-new EVENT_CONNECTION_NEW eventhandlers.append
- ' server-connection-closed EVENT_CONNECTION_CLOSED eventhandlers.append
- ' server-recv EVENT_CONNECTION_RECV eventhandlers.append
- ' server-commandline EVENT_COMMANDLINE eventhandlers.append
- ' server-motd-changed EVENT_MOTD_CHANGED eventhandlers.append
-
- initialize-server
|