movie-night-chat/api.rkt

#lang typed/racket
(provide send-ping send-message send-join send-users
         (struct-out chat-message)
         get-chat-message
         get-notify
         (struct-out event-data)
         get-topic
         get-event-data
         get-users-reply)

(require "private/ws-typed.rkt" ;; web sockets
         typed/json
         "macros.rkt"
         )

(: send-jsexpr (-> WS JSExpr Void))
(define (send-jsexpr c js)
  (when (ws-conn-closed? c)
    (error "trying to send-jsexpr to a closed connection"
           (ws-conn-close-status c)
           (ws-conn-close-reason c)))
  (ws-send! c (jsexpr->string js)))

(: send-ping (-> WS Void))
(define (send-ping conn)
  (send-jsexpr conn (hasheq 'Type CdPing 'Message "")))

(: send-message (-> WS String Void))
(define (send-message conn msg)
  (send-jsexpr conn (hasheq 'Type CdMessage 'Message msg)))

(: send-join (-> WS String String Void))
(define (send-join conn name color)
  (define jd
    (jsexpr->string (hasheq 'Name name 'Color color)))
  (send-jsexpr conn (hasheq 'Type CdJoin 'Message jd)))

(: send-users (-> WS Void))
(define (send-users conn)
  (send-jsexpr conn (hasheq 'Type CdUsers 'Message "")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; is it a reply to the /users command?

(define-predicate names-list? (Listof String))

(: get-users-reply (-> JSExpr (U False (Listof String))))
(define (get-users-reply js)
  (match js
    [(hash-table ('Type DTHidden)
                 ('Data (hash-table ('Type CdUsers)
                                    ('Data (? names-list? users)))))
     users]
    [_ #f]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-type Event-Type (U 'join 'leave 'kick 'ban 'server-message
                           'name-changed 'name-change-forced 'unknown))
(struct event-data ([type : Event-Type]
                    [payload : Any])
  #:transparent)

;; bad code
(: convert-event-data-type (-> Integer Event-Type))
(define (convert-event-data-type t)
  (cond
    [(= t EvJoin) 'join]
    [(= t EvLeave) 'leave]
    [(= t EvKick) 'kick]
    [(= t EvBan) 'ban]
    [(= t EvServerMessage) 'server-message]
    [(= t EvNameChange) 'name-changed]
    [(= t EvNameChangeForced) 'name-change-forced]
    [else 'unknown]))

(: get-event-data (-> JSExpr (U False event-data)))
(define (get-event-data js)
  (match js
    [(hash-table ('Type DTEvent)
                 ('Data (hash-table ('Event (? exact-integer? ev))
                                    ('User user))))
     (event-data (convert-event-data-type ev) user)]
    [_ #f]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(: get-topic (-> JSExpr (U False String)))
(define (get-topic js)
  (match js
    [(hash-table ('Type DTCommand)
                 ('Data (hash-table ('Command 0)
                                    ('Arguments (cons (? string? topic) _)))))
     topic]
    [_ #f]))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(: get-notify (-> JSExpr (U False String)))
(define (get-notify js)
  (match js
    [(hash-table ('Type DTHidden)
                 ('Data (hash-table ('Type CdNotify)
                                    ('Data (? string? dat)))))
     dat]
    [_ #f]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-type Message-Type (U 'chat 'action 'server 'error
                             'notice 'response 'command-error 'unknown))
(struct chat-message
  ([message : String]
   [from : String]
   [color : String]
   [type : Message-Type])
  #:transparent)


;; XXX: this code is bad
(: convert-type (-> Integer Message-Type))
(define (convert-type t)
  (cond
    [(= t MsgChat) 'chat]
    [(= t MsgAction) 'action]
    [(= t MsgServer) 'server]
    [(= t MsgError) 'error]
    [(= t MsgNotice) 'notice]
    [(= t MsgCommandResponse) 'response]
    [(= t MsgCommandError) 'command-error]
    [else 'unknown]))

(: get-chat-message (-> JSExpr (U False chat-message)))
(define (get-chat-message js)
  (match js
    [(hash-table ('Type DTChat)
                 ('Data (hash-table ('Message (? string? message))
                                    ('From    (? string? from))
                                    ('Color   (? string? color))
                                    ('Type    (? exact-integer? ty)))))
     (chat-message message from color (convert-type ty))]
    [_ #f]))