# non-blocking chat server
#
# server: picolisp$ (chat 4444)
# clients: $ telnet localhost 4444

(load "nb.l")

(off *H) # handlers

(class +Handler)
# s [w]

(dm T (S)
   (=: s S)
   (=: w (new))
   (push '*H (cons S This)) )

(dm rm> ()
   (prinl "q " (: s))
   (task (: s))
   (close (: s))
   (setq *H (delq (assoc (: s) *H) *H)) )

(dm wr> (Who Msg)
   (fifo (: w) (cons Who Msg)) )
   
(setq *N 1024 *B (need *N)) # read buffer

(dm cb> ()
   (block (: s) NIL)
   (let N (in (: s) (rdx *B *N))
      (prinl "r " (: s) " " N)
      (cond
         ((gt0 N) (for H *H (wr> (cdr H) S (head N *B))))
         ((= N (eagain)))
         (T (rm> This)) ) )
   (for H *H (fl> (cdr H))) )

(dm fl> ()
   (use X
      (while
         (and (setq X (cadr (val (: w)))) # peek head
              (let (S (cdr X)
                    M (length S)
                    N (out (: s) (wrx S M)))
                 (prinl "w " (: s) " " N "/" M)
                 (when (gt0 N)
                    (if (<= M N)
                       (fifo (: w))
                       (set (cdr (val (: w))) (tail (- M N) S)) ) ) ) ) ) ) )

(de chat (Port)
   (task (port Port)
      (when (accept @)
         (task @
            This (new '(+Handler) @)
            (cb> This) ) ) ) )