Movie Night chat IRCd
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

145 lines
4.2 KiB

  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. (define-predicate names-list? (Listof String))
  38. (: get-users-reply (-> JSExpr (U False (Listof String))))
  39. (define (get-users-reply js)
  40. (match js
  41. [(hash-table ('Type DTHidden)
  42. ('Data (hash-table ('Type CdUsers)
  43. ('Data (? names-list? users)))))
  44. users]
  45. [_ #f]))
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. (define-type Event-Type (U 'join 'leave 'kick 'ban 'server-message
  48. 'name-changed 'name-change-forced 'unknown))
  49. (struct event-data ([type : Event-Type]
  50. [payload : Any])
  51. #:transparent)
  52. ;; bad code
  53. (: convert-event-data-type (-> Integer Event-Type))
  54. (define (convert-event-data-type t)
  55. (cond
  56. [(= t EvJoin) 'join]
  57. [(= t EvLeave) 'leave]
  58. [(= t EvKick) 'kick]
  59. [(= t EvBan) 'ban]
  60. [(= t EvServerMessage) 'server-message]
  61. [(= t EvNameChange) 'name-changed]
  62. [(= t EvNameChangeForced) 'name-change-forced]
  63. [else 'unknown]))
  64. (: get-event-data (-> JSExpr (U False event-data)))
  65. (define (get-event-data js)
  66. (match js
  67. [(hash-table ('Type DTEvent)
  68. ('Data (hash-table ('Event (? exact-integer? ev))
  69. ('User user))))
  70. (event-data (convert-event-data-type ev) user)]
  71. [_ #f]))
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73. (: get-topic (-> JSExpr (U False String)))
  74. (define (get-topic js)
  75. (match js
  76. [(hash-table ('Type DTCommand)
  77. ('Data (hash-table ('Command 0)
  78. ('Arguments (cons (? string? topic) _)))))
  79. topic]
  80. [_ #f]))
  81. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82. (: get-notify (-> JSExpr (U False String)))
  83. (define (get-notify js)
  84. (match js
  85. [(hash-table ('Type DTHidden)
  86. ('Data (hash-table ('Type CdNotify)
  87. ('Data (? string? dat)))))
  88. dat]
  89. [_ #f]))
  90. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  91. (define-type Message-Type (U 'chat 'action 'server 'error
  92. 'notice 'response 'command-error 'unknown))
  93. (struct chat-message
  94. ([message : String]
  95. [from : String]
  96. [color : String]
  97. [type : Message-Type])
  98. #:transparent)
  99. ;; XXX: this code is bad
  100. (: convert-type (-> Integer Message-Type))
  101. (define (convert-type t)
  102. (cond
  103. [(= t MsgChat) 'chat]
  104. [(= t MsgAction) 'action]
  105. [(= t MsgServer) 'server]
  106. [(= t MsgError) 'error]
  107. [(= t MsgNotice) 'notice]
  108. [(= t MsgCommandResponse) 'response]
  109. [(= t MsgCommandError) 'command-error]
  110. [else 'unknown]))
  111. (: get-chat-message (-> JSExpr (U False chat-message)))
  112. (define (get-chat-message js)
  113. (match js
  114. [(hash-table ('Type DTChat)
  115. ('Data (hash-table ('Message (? string? message))
  116. ('From (? string? from))
  117. ('Color (? string? color))
  118. ('Type (? exact-integer? ty)))))
  119. (chat-message message from color (convert-type ty))]
  120. [_ #f]))