Name: Anonymous 2011-02-16 17:39
telnet 98.255.132.66 9099
Come join the fun!
Come join the fun!
#lang racket
(require racket/tcp
(only-in srfi/43 vector-for-each))
(define clients (make-vector 255 #f)) ; fixed length vector because I'm evil.
(define listener (tcp-listen 9999))
(define users (make-parameter 0))
(struct client (id in out))
(define (broadcast message ignore-id)
(vector-for-each
(λ (cl)
(unless (= ignore-id (client-id cl))
(fprintf (client-out cl) "~a~n" message)))
clients))
(define (add-client! in out)
(with-handlers ((exn:fail:contract? (λ x (fprintf out "*** Exception: monadic pointer stack overflow~n")
(close-output-port out) '|monadic pointer stack overflow|)))
(let loop ((i 0))
(if (vector-ref clients i) (loop (add1 i))
(let ((cl (client i in out)))
(users (add1 users))
(vector-set! clients i cl) cl)))))
(define (delete-client! cl)
(close-output-port (client-out cl))
(users (sub1 users))
(vector-set! clients (client-id cl) #f))
(let loop ()
(let ((client (call-with-values (lambda () (tcp-accept listener)) add-client!)))
(unless (eq? client '|monadic pointer stack overflow|)
(fprintf (client-out client) "Hello!\r\nYou have successfully joined to the conversation,\r\n\
please remember to be respectful and polite by sageing your posts.\r\nThere are ~a people connected.\r\n" users)
(broadcast "Someone joined.\r\n" (client-id client))
(thread
(lambda ()
(let loop ((x (read-line (client-in client))))
(cond ((or (eof-object? x)
(string-ci=? (substring x 0 5) "/quit"))
(broadcast "Someone quitted. :(((((\r\n" (client-id))
(delete-client! client))
((string-ci=? (substring x 0 6) "/users")
(fprintf (client-out client) "There are ~a people connected.\r\n" users))
(else
(broadcast x (client-id client))
(loop (read-line (client-in client))))))))))
(loop))