api.rkt 4.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146
  1. #lang typed/racket
  2. (provide send-ping send-message send-join send-users
  3. (struct-out chat-message)
  4. get-chat-message
  5. get-notify
  6. (struct-out event-data)
  7. get-topic
  8. get-event-data
  9. get-users-reply)
  10. (require "private/ws-typed.rkt" ;; web sockets
  11. typed/json
  12. "macros.rkt"
  13. )
  14. (: send-jsexpr (-> WS JSExpr Void))
  15. (define (send-jsexpr c js)
  16. (when (ws-conn-closed? c)
  17. (error "trying to send-jsexpr to a closed connection"
  18. (ws-conn-close-status c)
  19. (ws-conn-close-reason c)))
  20. (ws-send! c (jsexpr->string js)))
  21. (: send-ping (-> WS Void))
  22. (define (send-ping conn)
  23. (send-jsexpr conn (hasheq 'Type CdPing 'Message "")))
  24. (: send-message (-> WS String Void))
  25. (define (send-message conn msg)
  26. (send-jsexpr conn (hasheq 'Type CdMessage 'Message msg)))
  27. (: send-join (-> WS String String Void))
  28. (define (send-join conn name color)
  29. (define jd
  30. (jsexpr->string (hasheq 'Name name 'Color color)))
  31. (send-jsexpr conn (hasheq 'Type CdJoin 'Message jd)))
  32. (: send-users (-> WS Void))
  33. (define (send-users conn)
  34. (send-jsexpr conn (hasheq 'Type CdUsers 'Message "")))
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ;; is it a reply to the /users command?
  37. (: get-users-reply (-> JSExpr (U False (Listof String))))
  38. (define (get-users-reply js)
  39. (match js
  40. [(hash-table ('Type DTHidden)
  41. ('Data (hash-table ('Type CdUsers)
  42. ('Data (list users ...)))))
  43. ;; TODO: here I would like to match on
  44. ;; (list (? string? users) ...) but that
  45. ;; doesn't seem to work
  46. (filter string? users)]
  47. [_ #f]))
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49. (define-type Event-Type (U 'join 'leave 'kick 'ban 'server-message
  50. 'name-changed 'name-change-forced 'unknown))
  51. (struct event-data ([type : Event-Type]
  52. [payload : Any])
  53. #:transparent)
  54. ;; bad code
  55. (: convert-event-data-type (-> Integer Event-Type))
  56. (define (convert-event-data-type t)
  57. (cond
  58. [(= t EvJoin) 'join]
  59. [(= t EvLeave) 'leave]
  60. [(= t EvKick) 'kick]
  61. [(= t EvBan) 'ban]
  62. [(= t EvServerMessage) 'server-message]
  63. [(= t EvNameChange) 'name-changed]
  64. [(= t EvNameChangeForced) 'name-change-forced]
  65. [else 'unknown]))
  66. (: get-event-data (-> JSExpr (U False event-data)))
  67. (define (get-event-data js)
  68. (match js
  69. [(hash-table ('Type DTEvent)
  70. ('Data (hash-table ('Event (? exact-integer? ev))
  71. ('User user))))
  72. (event-data (convert-event-data-type ev) user)]
  73. [_ #f]))
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75. (: get-topic (-> JSExpr (U False String)))
  76. (define (get-topic js)
  77. (match js
  78. [(hash-table ('Type DTCommand)
  79. ('Data (hash-table ('Command 0)
  80. ('Arguments (cons (? string? topic) _)))))
  81. topic]
  82. [_ #f]))
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. (: get-notify (-> JSExpr (U False String)))
  85. (define (get-notify js)
  86. (match js
  87. [(hash-table ('Type DTHidden)
  88. ('Data (hash-table ('Type CdNotify)
  89. ('Data (? string? dat)))))
  90. dat]
  91. [_ #f]))
  92. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93. (define-type Message-Type (U 'chat 'action 'server 'error
  94. 'notice 'response 'command-error 'unknown))
  95. (struct chat-message
  96. ([message : String]
  97. [from : String]
  98. [color : String]
  99. [type : Message-Type])
  100. #:transparent)
  101. ;; XXX: this code is bad
  102. (: convert-type (-> Integer Message-Type))
  103. (define (convert-type t)
  104. (cond
  105. [(= t MsgChat) 'chat]
  106. [(= t MsgAction) 'action]
  107. [(= t MsgServer) 'server]
  108. [(= t MsgError) 'error]
  109. [(= t MsgNotice) 'notice]
  110. [(= t MsgCommandResponse) 'response]
  111. [(= t MsgCommandError) 'command-error]
  112. [else 'unknown]))
  113. (: get-chat-message (-> JSExpr (U False chat-message)))
  114. (define (get-chat-message js)
  115. (match js
  116. [(hash-table ('Type DTChat)
  117. ('Data (hash-table ('Message (? string? message))
  118. ('From (? string? from))
  119. ('Color (? string? color))
  120. ('Type (? exact-integer? ty)))))
  121. (chat-message message from color (convert-type ty))]
  122. [_ #f]))