Browse Source

typing api.rkt

master
Epi Morphism 3 months ago
parent
commit
77a128e6a1
3 changed files with 106 additions and 95 deletions
  1. +75
    -61
      api.rkt
  2. +30
    -33
      chat.rkt
  3. +1
    -1
      macros.rkt

+ 75
- 61
api.rkt View File

@@ -1,18 +1,19 @@
#lang racket
#lang typed/racket
(provide send-ping send-message send-join send-users
(struct-out chat-message)
is-chat-message? get-chat-message
is-notify? get-notify
get-chat-message
get-notify
(struct-out event-data)
is-topic? get-topic
is-event? get-event-data
is-users-reply? get-users-reply)
get-topic
get-event-data
get-users-reply)

(require net/rfc6455 ;; web sockets
json
(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"
@@ -20,46 +21,50 @@
(ws-conn-close-reason c)))
(ws-send! c (jsexpr->string js)))

(define/contract (send-ping conn)
(-> ws-conn? void?)
(: send-ping (-> WS Void))
(define (send-ping conn)
(send-jsexpr conn (hasheq 'Type CdPing 'Message "")))

(define/contract (send-message conn msg)
(-> ws-conn? string? void?)
(: send-message (-> WS String Void))
(define (send-message conn msg)
(send-jsexpr conn (hasheq 'Type CdMessage 'Message msg)))

(define/contract (send-join conn name color)
(-> ws-conn? string? string? void?)
(: 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)))

(define/contract (send-users conn)
(-> ws-conn? any)
(: send-users (-> WS Void))
(define (send-users conn)
(send-jsexpr conn (hasheq 'Type CdUsers 'Message "")))

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

;; is it a reply to the /users command?
(define/contract (is-users-reply? js)
(-> jsexpr? boolean?)
(and (= DTHidden (hash-ref js 'Type -1))
(= CdUsers (hash-ref (hash-ref js 'Data) 'Type -1))))

(define/contract (get-users-reply js)
(-> is-users-reply? (listof string?))
(hash-ref (hash-ref js 'Data) 'Data))
(: 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 (list users ...)))))
;; TODO: here I would like to match on
;; (list (? string? users) ...) but that
;; doesn't seem to work
(filter string? users)]
[_ #f]))

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

(struct event-data (type payload) #:transparent)

(define/contract (is-event? js)
(-> jsexpr? boolean?)
(= DTEvent (hash-ref js 'Type -1)))

(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]
@@ -71,46 +76,52 @@
[(= t EvNameChangeForced) 'name-change-forced]
[else 'unknown]))

(define/contract (get-event-data js)
(-> is-event? event-data?)
(define data (hash-ref js 'Data))
(event-data (convert-event-data-type (hash-ref data 'Event))
(hash-ref data 'User "")))
(: 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]))

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

(define/contract (is-topic? js)
(-> jsexpr? boolean?)
(and (= DTCommand (hash-ref js 'Type -1))
(= 0 (hash-ref (hash-ref js 'Data) 'Command -1))))
(define/contract (get-topic js)
(-> is-topic? string?)
(car (hash-ref (hash-ref js 'Data) 'Arguments '(""))))
(: 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]))


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

(define/contract (is-notify? js)
(-> jsexpr? boolean?)
(and (= DTHidden (hash-ref js 'Type -1))
(= CdNotify (hash-ref (hash-ref js 'Data) 'Type -1))))
(define/contract (get-notify js)
(-> is-notify? string?)
(hash-ref (hash-ref js 'Data) 'Data))
(: 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 from color type)
([message : String]
[from : String]
[color : String]
[type : Message-Type])
#:transparent)

(define/contract (is-chat-message? js)
(-> jsexpr? boolean?)
(= DTChat (hash-ref js 'Type 0)))

;; XXX: this code is bad
(: convert-type (-> Integer Message-Type))
(define (convert-type t)
(cond
[(= t MsgChat) 'chat]
@@ -122,10 +133,13 @@
[(= t MsgCommandError) 'command-error]
[else 'unknown]))

(define/contract (get-chat-message js)
(-> jsexpr? chat-message?)
(define data (hash-ref js 'Data))
(chat-message (hash-ref data 'Message)
(hash-ref data 'From)
(hash-ref data 'Color)
(convert-type (hash-ref data 'Type))))
(: 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]))

+ 30
- 33
chat.rkt View File

@@ -6,6 +6,7 @@
"api.rkt"
"unheck-html.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
@@ -36,39 +37,35 @@
[(string? v)
(let ([js (string->jsexpr v)])
(cond
[(is-chat-message? js)
(define msg (get-chat-message js))
(match msg
[(chat-message message from color type)
(match type
['chat (on-chat from (unheck-html message))]
['response (on-response (unheck-html message))]
[_
(log-warning
(format "chat.rkt/handl-evt: cannot handle message type in ~s" msg))])])]
[(is-users-reply? js)
(on-users (get-users-reply js))]
[(is-notify? js)
(log-info (format "MovieNight notification: ~a" js))
(on-notify (get-notify js))]
[(is-topic? js)
(on-topic (get-topic js))]
[(is-event? js)
(define ed (get-event-data js))
(match ed
[(event-data type 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))])])]
[(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-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) => on-notify]
[(get-topic js) => on-topic]
[(get-event-data js)
=> (lambda (ed)
(match ed
[(event-data type 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)))]))


+ 1
- 1
macros.rkt View File

@@ -1,4 +1,4 @@
#lang racket
#lang typed/racket
(provide (all-defined-out))
(require (for-syntax syntax/parse racket/list)
syntax/parse/define)


Loading…
Cancel
Save