You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

118 lines
3.3 KiB

#! /usr/bin/env slope
; prattle - small realtime chat for localhost
; author:
; server
(define get-cln
(lambda ()
(define fh (file-open-read (append (env "HOME") "/bin/client.slo")))
(define code (list->string (read-all-lines fh) "\n"))
(close fh)
(define get-srv
(lambda ()
(define fh (file-open-read (append (env "HOME") "/bin/server.slo")))
(define code (list->string (read-all-lines fh) "\n"))
(close fh)
(define register-user
(lambda (username handle)
(assoc q handle username)))
(define de-register-user
(lambda (username handle)
(close handle)
(filter (lambda (i) (open? (car i))) q)))
(define get-users
(lambda ()
(lambda (u) (string-format "- %v" u))
(lambda (u) (not (regex-match? "^[-0-9]" u)))
(map car
(map cdr q))))))
(define broadcast
(lambda (l q)
(lambda (fh)
(if (equal? fh ioh)
(write (string-format "%v %v\r\n" "<-" l) fh)
(write (string-format "%v %v\r\n" "->" l) fh))))
(filter open? (map car q)))))
(define log (file-open-write (string-format "%v/tmp/chat-%v.log" (env "HOME") (timestamp))))
(define q (assoc [] log "-logger"))
(define scroll (list-seed 10 #f))
(define l #f)
(define handler
(lambda (ioh)
(set! q (assoc q ioh (length q)))
(for () (run) ; endless loop
(set! l #f)
(if (open? ioh)
(set! l (read-line ioh))
(close ioh))
(if (~bool l)
((regex-match? "^/join.*" l)
; announce to everybody else
(broadcast (string-format "### %v joined the chat" (ref (string->list l " ") -1)) q)
; then register
(set! q (register-user (ref (string->list l " ") -1) ioh))
(write (append "Users online:\n" (list->string (get-users) "\r\n") "\r\n") ioh)
(write (append (list->string (filter (lambda (i) i) scroll) "\r\n") "\r\n") ioh)
((regex-match? "^/leave.*" l)
(set! q (de-register-user (ref (string->list l " ") -1) ioh)))
((equal? l "/exit")
(close ioh))
((equal? l "/users")
(write (append "Users online:\n" (list->string (get-users) "\r\n") "\r\n") ioh))
((equal? l "/clear")
(write "\27[0;0H\27[2J" ioh))
((equal? l "/get-server")
(write (get-srv) ioh))
((equal? l "/get-client")
(write (get-cln) ioh))
((equal? l "/shutdown")
(set! run #f)
(if (not (regex-match? "^ */" l))
(set! scroll (cdr (append scroll (string-format "%v" l)))))
(broadcast l q))))))
(sleep 200)))))
(close stdin)
(close stdout)
(close stderr)
(define run #t)
(for () (run) ; endless loop
(sleep 1000))))