#!/bin/sh
#|
exec mzscheme -r "$0" "$@"
|#

;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

;;=============================================================================
;; Configuration

(define *port*         12321)
(define *client-num*   100)
(define *beep-delay*   (* 60 2))
(define *screen-width* 80)
(define *passwords*    (load-relative "passwd.ss"))

(define (greetings)
  (for-each (lambda (line) (display line) (newline))
            '(""
              "Welcome to the Scheme simple chat server."
              "Use /help to get available commands,"
              "    /who to check who's in,"
              "    /quit to get back to the real world."
              "Bugs, comments etc: eli@barzilay.org")))

;;=============================================================================
;; Utilities

(define (eprintf . args)
  (apply fprintf (current-error-port) args))

(define (string->lowcase-symbol str)
  (string->symbol (string-downcase str)))

(define (current-date-string)
  (define (padnum2 n)
    (let ((str (number->string n))) (if (< n 10) (string-append "0" str) str)))
  (define months #(#f "Jan" "Feb" "Mar" "Apr" "May" "Jun"
                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  (define days #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
  (define d (seconds->date (current-seconds)))
  (string-append
   (vector-ref days (date-week-day d)) ", " (padnum2 (date-day d)) " "
   (vector-ref months (date-month d)) " " (padnum2 (date-year d)) " "
   (padnum2 (date-hour d)) ":" (padnum2 (date-minute d)) ":"
   (padnum2 (date-second d))))

(define (log-message msg . args)
  (let ((msg (apply format msg args)))
    (eprintf "[~a] ~a\n" (current-date-string) msg)))

(define (split-line-for-screen str)
  (if (<= (string-length str) *screen-width*)
    (list str)
    (cons (substring str 0 *screen-width*)
          (split-line-for-screen
           (string-append
            "  " (substring str *screen-width* (string-length str)))))))

;;=============================================================================
;; Telnet

(define (filter-telnet-output)
  (define real-in (current-input-port))
  (define (process)
    (let ((ch (read-char)))
      (unless (eof-object? ch)
        (when (eq? ch #\newline) (write-char #\return))
        (write-char ch)
        (process))))
  (let-values (((i o) (make-pipe)))
    (begin0 (parameterize ((current-input-port i))
              (thread (lambda ()
                        (process) (close-output-port (current-output-port)))))
      (current-output-port o))))

(define (filter-telnet-input)
  (define real-out  (current-output-port))
  (define last-cr?  #f)
  (define eof-ch    (integer->char 4))
  (define escape-ch (integer->char 255))
  (define quit #f)
  (define (process)
    (let ((ch (read-char)))
      (cond
       ((or (eof-object? ch) (eq? ch eof-ch)) (quit))
       ((eq? ch escape-ch)
        (let ((ch (read-char)))
          (unless (eof-object? ch)
            (case (char->integer ch)
              ((244) ; break (eprintf ">>> BREAK!\n")
               ;; (write-char (integer->char 3))
               (quit))
              ((236) ; eof (eprintf ">>> EOF!\n")
               (quit))
              ((237) ; suspend (eprintf ">>> SUSPEND!\n")
               ;; (write-char (integer->char 26))
               (quit))
              ((253) ; DO X -> WON'T X, except for ECHO and SGA
               (set! ch (read-char))
               ;; (eprintf ">>> DO ~s!\n" (char->integer ch))
               (unless (or (eof-object? ch) (memq (char->integer ch) '(1 3)))
                 ;; (eprintf ">>>>>>>>> WONT ~s\n" (char->integer ch))
                 (write-char escape-ch real-out)
                 (write-char (integer->char 252) real-out)
                 (write-char ch real-out)
                 (flush-output real-out)))
              ((251 252 254) ; ignore WILL/WONT/DONT
               ;; (eprintf ">>> ~a ~s!\n"
               ;;          (case (char->integer ch)
               ;;            ((251) "WILL") ((252) "WONT") ((254) "DONT"))
               ;;          (char->integer (read-char)))
               (read-char))
              ((255) ; escaped escape
               (write-char ch))
              (else #f)))))
       ((eq? ch #\newline) (set! last-cr? #f) (write-char ch))
       ((eq? ch #\nul)     (set! last-cr? #f) (write-char #\return))
       (else (when last-cr? (write-char #\return) (set! last-cr? #f))
             (if (eq? ch #\return)
               (set! last-cr? #t)
               (write-char ch))))
      (process)))
  (let-values (((i o) (make-pipe)))
    (begin0 (parameterize ((current-output-port o))
              (thread (lambda ()
                        (let/ec q (set! quit (lambda () (q #f))) (process))
                        (close-output-port o))))
      (current-input-port i))))

(define (filter-telnet)
  (define orig-input    (current-input-port))
  (define orig-output   (current-output-port))
  (define input-thread  (filter-telnet-input))
  (define output-thread (filter-telnet-output))
  (lambda ()
    (flush-output)
    (close-output-port (current-output-port))
    (thread-wait output-thread)
    (close-input-port (current-input-port))
    (thread-wait input-thread)
    (current-input-port orig-input)
    (current-output-port orig-output)))

;;=============================================================================
;; User commands

(define user-commands '())

(define help-tag "HELP")

(define (add-user-command! command help func)
  (set! user-commands
        (append! user-commands (list (list command
                                           (format "  /~a~a" command help)
                                           func)))))

(define (apply-user-command this cmd strarg)
  (log-message "~a: /~a ~a" (this 'get-name) cmd strarg)
  (let ((command (assq cmd user-commands)))
    (if command
      ((caddr command) this strarg)
      (this 'say (format "Unknown command `~a'." cmd)))))

(add-user-command!
 'help ": show this help screen"
 (lambda (this str)
   (cond ((eq? str help-tag) (printf "  Display the list of commands.\n"))
         ((regexp-match "^ */?([^ ]+) *$" str) =>
          (lambda (x)
            (apply-user-command
             this (string->lowcase-symbol (cadr x)) help-tag)))
         (else (for-each (lambda (c) (printf "~a\n" (cadr c)))
                         user-commands)))))

(add-user-command!
 'quit ": back to reality"
 (lambda (this str)
   (cond ((eq? str help-tag) (printf "  Do you need more explanations?\n"))
         (else (printf "Bye.\n") (this 'exit)))))

(add-user-command!
 'emote " <something...>: do it instead of just saying it"
 (lambda (this str)
   (cond ((eq? str help-tag)
          (printf "  Will show text as \"*<yourname> text*\"\n"))
         (else (tell-all "*~a ~a*" (this 'get-name) str)))))

(add-user-command!
 'msg " <someone> <something...>: private message"
 (lambda (this str)
   (cond
    ((eq? str help-tag) (printf "  Send a private to someone.\n"))
    (else (let* ((x    (regexp-match "([a-zA-Z0-9_-]+) *(.*)$" str))
                 (who  (and x (string->lowcase-symbol (cadr x))))
                 (what (and x (caddr x)))
                 (usr  (and x (name->client who))))
            (cond ((not x)          (printf "  Syntax error.\n"))
                  ((not usr)        (printf "  User `~a' not found.\n" who))
                  ((equal? what "") (printf "  Empty message.\n"))
                  ((eq? this usr)   (printf "  Talking to yourself?\n"))
                  (else (usr 'say
                             (format "~a tells you: ~a"
                                     (this 'get-name) what)))))))))

(define (who . except)
  (define clients *clients*)
  (set! except (and (not (null? except)) (car except)))
  (if (null? clients)
    (printf "Nobody on-line.\n")
    (begin
      (printf "  name         idle     from\n")
      (for-each
       (lambda (c)
         (unless (eq? c except)
           (let ((name (c 'get-name)))
             (when name
               (printf "  ~a~a ~a (~a~a)\n"
                       name
                       (substring
                        "            "
                        (min (string-length (symbol->string name)) 12)
                        12)
                       (let* ((t (- (current-seconds) (c 'get-last)))
                              (s (modulo t 60))
                              (t (/ (- t s) 60))
                              (m (modulo t 60))
                              (h (/ (- t m) 60)))
                         (define (pad n)
                           (string-append (if (< n 10) "0" "")
                                          (number->string n)))
                         (string-append (pad h) ":" (pad m) ":" (pad s)))
                       (c 'get-ip)
                       (if (*passwords* 'user-exists? name)
                         ", authenticated" ""))))))
       *clients*))))

(add-user-command!
 'who ": show who's here"
 (lambda (this str)
   (cond ((eq? str help-tag)
          (printf "  Tell you who else is here.\n"))
         ((< (length *clients*) 2) (printf "  You're the only one.\n"))
         (else (who this)))))

;;=============================================================================
;; Client stuff

(define *clients* '())
(define *clients-semaphore* (make-semaphore 1))
(define (with-client-semaphore thunk)
  (dynamic-wind
    (lambda () (semaphore-wait *clients-semaphore*))
    thunk
    (lambda () (semaphore-post *clients-semaphore*))))
(define (name->client name)
  (ormap (lambda (c) (and (eq? name (c 'get-name)) c)) *clients*))
(define (add-client! c)
  (with-client-semaphore (lambda () (set! *clients* (cons c *clients*)))))
(define (del-client! c)
  (with-client-semaphore
   (lambda ()
     (set! *clients* (let loop ((cs *clients*))
                       (cond ((null? cs) '())
                             ((eq? (car cs) c) (cdr cs))
                             (else (cons (car cs) (loop (cdr cs))))))))))
(define (send-all-clients . args)
  (with-client-semaphore
   (lambda () (for-each (lambda (c) (apply c args)) *clients*))))

(define (tell-all str . args)
  (define msg (apply format str args))
  (log-message "~a" msg)
  (apply send-all-clients 'say (split-line-for-screen msg)))

(define (client)

  (define messages-semaphore (make-semaphore 1))
  (define messages-waiting (make-semaphore 0))
  (define messages '())

  (define name #f)
  (define last (current-seconds))
  (define last-beep (current-seconds))
  (define ip
    (let-values (((_ there) (tcp-addresses (current-input-port))))
      (log-message "Connection from ~a." there)
      there))

  (define (exit . n)
    (del-client! this)
    (when name (tell-all "~a left." name))
    (custodian-shutdown-all (current-custodian)))

  (define unfilter-telnet #f)

  (define (send-escape . escapes)
    (for-each (lambda (e) (display "\e[") (display e)) escapes))

  (define inpbufs '())
  (define inpbuf  '())
  (define io-semaphore (make-semaphore 0))
  (define prompt  "")
  (define cprompt "") ; continuation prompt, must be the same length as prompt

  (define (set-prompt! str . args)
    (set! prompt (apply format str args))
    (set! cprompt
          (string-append (make-string (sub1 (string-length prompt)) #\.) " ")))
  (define (display-prompt)
    (display (if (null? inpbufs) prompt cprompt)))

  (define (beginning-of-line)
    (send-escape (format "~aD" (+ (string-length prompt) (length inpbuf)))))

  (define (get-line . args)
    (define outch (and (not (null? args)) (char? (car args))
                       (begin0 (car args) (set! args (cdr args)))))
    (define (delete)
      (unless (null? inpbuf)
        (send-escape "D" "K")
        (set! inpbuf (cdr inpbuf))
        (when (and (null? inpbuf) (not (null? inpbufs)))
          (beginning-of-line)
          (set! inpbuf (car inpbufs))
          (set! inpbufs (cdr inpbufs))
          (display-prompt)
          (display (list->string (reverse inpbuf)))
          (send-escape "K"))
        (flush-output)))
    (define (loop)
      (semaphore-post io-semaphore)
      (let ((ch (read-char)))
        (semaphore-wait io-semaphore)
        (set! last (current-seconds))
        (cond
         ((eof-object? ch) ch)
         ((memq ch '(#\backspace #\rubout)) (delete) (loop))
         ((eq? 21 (char->integer ch)) ; ^U
          (beginning-of-line)
          (set! inpbuf '())
          (set! inpbufs '())
          (display-prompt)
          (send-escape "K")
          (loop))
         ((memq ch '(#\newline #\return))
          (let loop1 ()
            (cond ((null? inpbuf) (loop))
                  ((eq? (car inpbuf) #\space) (delete) (loop1))
                  (else
                   (beginning-of-line)
                   (let ((line
                          (list->string
                           (reverse! (apply append! (cons inpbuf inpbufs))))))
                     (set! inpbuf '())
                     (set! inpbufs '())
                     ;; (eprintf ">>>>>>>>> ~s\n" line)
                     line)))))
         (else (when (char<=? #\space ch #\~)
                 (when (= *screen-width*
                          (+ (string-length prompt) (length inpbuf)))
                   (beginning-of-line)
                   (set! inpbufs (cons inpbuf inpbufs))
                   (set! inpbuf '())
                   (display-prompt)
                   (send-escape "K"))
                 (display (or outch ch))
                 (flush-output)
                 (set! inpbuf (cons ch inpbuf)))
               (loop)))))
    (unless (null? args)
      (apply set-prompt! args))
    (display-prompt)
    (loop))

  (define (say . strs)
    (when name
      (semaphore-wait io-semaphore)
      (when (and (<= *beep-delay* (- (current-seconds) (max last last-beep))))
        (display (integer->char 7))
        (set! last-beep (current-seconds)))
      ;; Use "D" because "E/F" won't work with the Java applet
      (beginning-of-line)
      (for-each (lambda (s) (display s) (send-escape "K") (newline)) strs)
      (display-prompt)
      (display (list->string (reverse inpbuf)))
      (send-escape "K")
      (flush-output)
      (semaphore-post io-semaphore)))

  (define (client-listen)
    (let ((line (get-line)))
      (cond ((eof-object? line) (exit))
            ((regexp-match "^/([^ ]+) *(.*)$" line) =>
             (lambda (x)
               (beginning-of-line)
               (for-each (lambda (line)
                           (display line) (send-escape "K") (newline))
                         (split-line-for-screen line))
               (apply-user-command
                this (string->lowcase-symbol (cadr x)) (caddr x))))
            (else (tell-all "~a: ~a" name line))))
    (client-listen))

  (define (event-handler)
    (semaphore-wait messages-waiting)
    (semaphore-wait messages-semaphore)
    (let ((msg (caar messages)) (args (cdar messages)))
      (set! messages (cdr messages))
      (semaphore-post messages-semaphore)
      (apply (case msg
               ((sync-semaphore) semaphore-post)
               ((say)  say)
               ((exit) exit)
               (else (error 'client-event "Unknown message: ~e" msg)))
             args))
    (event-handler))

  (define this
    (letrec ((client
              (lambda args
                (case (car args)
                  ((get-name) name)
                  ((get-last) last)
                  ((get-ip)   ip)
                  ((sync) (let ((s (make-semaphore 0)))
                            (this 'sync-semaphore s)
                            (semaphore-wait s)))
                  (else (semaphore-wait messages-semaphore)
                        (set! messages (append! messages (list args)))
                        (semaphore-post messages-waiting)
                        (semaphore-post messages-semaphore))))))
      client))

  (define (verify-password usr)
    (if (*passwords* 'user-exists? usr)
      (let loop ((n 3))
        (and (not (zero? n))
             (let ((pswd (get-line #\* "password: ")))
               (newline)
               (cond ((eof-object? pswd) (exit))
                     ((*passwords* 'verify? usr pswd) #t)
                     (else (log-message "~s: bad password, ~s." usr pswd)
                           (printf "Bad password.\n")
                           (sleep 1)
                           (loop (sub1 n)))))))
      'nopass))

  (define (get-name)
    (define n (get-line "name: "))
    (newline)
    (when (eof-object? n) (exit))
    (cond ((regexp-match "^ *USER *" n) (log-message "~s" n) (get-name))
          ((regexp-match "^ *(NICK +)?([a-z][a-z0-9_-]*) *$" n) =>
           (lambda (x)
             (if (< 20 (string-length (caddr x)))
               (begin (printf "Use a shorter name.\n") (get-name))
               (let* ((usr   (string->lowcase-symbol (caddr x)))
                      (pswd? (verify-password usr))
                      (other (name->client usr)))
                 ;; (when (cadr x)
                 ;;   (printf ":lidingo.se.eu.undernet.org 001 elibarzilay :Welcome to the Internet Relay Network, elibarzilay\n"))
                 (cond ((not pswd?) (sleep 1) (get-name))
                       ((not other) usr)
                       ((eq? #t pswd?)
                        (printf "Kicking out old login.\n") (other 'exit) usr)
                       (else (printf "User `~s' exists, try again.\n" usr)
                             (get-name)))))))
          ((regexp-match "^ *#([^ ]+) *(.*)$" n) =>
           (lambda (x)
             (handle-global-command (string->symbol (cadr x)) (caddr x))
             (unfilter-telnet)
             (exit)))
          (else (printf "Use a lower-case string beginning with a letter.\n")
                (get-name))))

  (define (initialize)
    (define (handler e)
      (log-message "Connection ~a(~a) aborts with an error: ~a"
                   name ip (if (exn? e) (exn-message e) e))
      (exit))
    (initial-exception-handler handler)
    (current-exception-handler handler)
    (exit-handler exit)
    (map (lambda (x) (display (integer->char x)))
         '(255 251 3 255 251 1)) ; will supress-go-ahead, will echo
    (flush-output)
    (set! unfilter-telnet (filter-telnet))
    (thread event-handler)
    (let ((n (get-name)))
      (tell-all "~a joined." n)
      (this 'sync)
      (greetings)
      (set! name n))
    (set-prompt! "==> ")
    (add-client! this)
    (client-listen))

  (initialize))

;;=============================================================================
;; Global commands

(define (handle-global-command cmd strarg)
  (log-message "Global-command ~a(~a)." cmd strarg)
  (case cmd
    ((who) (who))
    ((idletime) (let ((c (name->client (string->lowcase-symbol strarg))))
                  (if c
                    (printf "~s\n" (- (current-seconds) (c 'get-last)))
                    (printf "no\n"))))
    (else (printf "Unknown command: `~s'.\n" cmd))))

;;=============================================================================
;; Server loop

(define *listener* #f)

(define (server)
  (close-input-port (current-input-port))
  (set! *listener* (tcp-listen *port* *client-num* #t))
  (log-message "Server ready on port ~a." *port*)
  (let server-loop ()
    (parameterize ((current-custodian (make-custodian)))
      (let-values (((i o) (tcp-accept *listener*)))
        (parameterize ((current-input-port i) (current-output-port o))
          (thread client))))
    (server-loop)))

(server)
;;Local variables:
;;mode: Swindle
;;hide-local-variable-section: t
;;End: