movie-night-chat/chat.rkt

#lang typed/racket
(provide (all-defined-out))
(require/typed "unheck-html.rkt"
  [unheck-html (-> String String)]
  [unheck-all-html (-> String String)])
(require typed/net/url
         "private/ws-typed.rkt" ;; web sockets
         typed/json
         "api.rkt")

;; don't let the websockets timeout by themselves
(ws-idle-timeout +inf.0)

;; Creates a new connection and spaws threads for handling incoming events
;; and for sending pings.
;; Returns an object that can be used with e.g. send-message
(: make-connection
   (->* (String           ;; Server
         String           ;; User name
         #:on-chat        (-> String String Void)
         #:on-response    (-> String Void)
         #:on-users       (-> (Listof String) Void)
         #:on-notify      (-> String Void)
         #:on-join        (-> String Void)
         #:on-leave       (-> String Void)
         #:on-name-change (-> String String Void)
         #:on-close-conn  (-> Void)
         #:on-topic       (-> String Void)
         #:on-nick-collision (-> Void)) ()
        WS))
(define (make-connection server-addr user-name
                         #:on-chat on-chat         ;;;  called with (on-chat from message)
                         #:on-response on-response ;;;  called with (on-response message)
                         #:on-users on-users       ;;;  called with (on-users users)
                         #:on-notify on-notify     ;;;  called with (on-notify msg)
                         #:on-join on-join         ;;;  called with (on-join user)
                         #:on-leave on-leave       ;;;  called with (on-leave user)
                         #:on-name-change on-name-change
                         ;;; called with (on-name-change old-name new-name)
                         #:on-close-conn on-close-conn ;;; called with  (on-close-conn)
                         #:on-topic on-topic       ;;; called with (on-topic topic)
                         #:on-nick-collision on-nick-collision
                         )
  (define c (ws-connect (string->url server-addr)))
  (define user-color "#00FFAA")
  (define evt (ws-recv-evt c))
  (: handle-evt (-> Void))
  (define (handle-evt)
    (let ([v (sync evt)])
      (cond
        [(eof-object? v)
         (log-warning "RIP websocket\n")
         (ws-close! c)
         (on-close-conn)]
        [(string? v)
         (let ([js (string->jsexpr v)])
           (cond
             [(get-chat-message js)
              => (lambda (msg)
                   (match msg
                     [(chat-message message from color type)
                      (match type
                        ['chat (on-chat from (unheck-html message))]
                        ['response (on-response (unheck-all-html message))]
                        ['command-error (on-response (unheck-all-html message))]
                        [_
                         (log-warning
                          (format "chat.rkt/handl-evt: cannot handle message type in ~s" msg))])]))]
             [(get-users-reply js) => on-users]
             [(get-notify js)
              => (lambda (note)
                   (if (equal? note "Name already taken")
                       (on-nick-collision)
                       (on-notify note)))]
             [(get-topic js) => on-topic]
             [(get-event-data js)
              => (lambda (ed)
                   (match ed
                     [(event-data type (? string? data))
                      (match type
                        ['join (on-join data)]
                        ['leave (on-leave data)]
                        [(or 'name-changed
                             'name-change-forced)
                         (match (string-split data ":")
                           [(list old-nick new-nick)
                            (on-name-change old-nick new-nick)]
                           [_ #f])]
                        [_
                         (log-warning
                          (format "chat.rkt/handl-evt: cannot handle event type in ~s" ed))])]))]
             [else
              (log-warning
               (format "chat.rkt/handle-evt: don't know how to handle ~a" (jsexpr->string js)))]))
         (handle-evt)]
        [else
         (printf "Unknown msg: ~a" v)
         (handle-evt)])))
  (: do-ping (-> Void))
  (define (do-ping)
    (sleep 10)
    (unless (ws-conn-closed? c)
      (send-ping c)
      (do-ping)))

  (void (thread handle-evt))
  (void (thread do-ping))

  c)