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.

154 lines
6.4 KiB

  1. #lang typed/racket
  2. (provide (all-defined-out))
  3. (require/typed "unheck-html.rkt"
  4. [unheck-html (-> String String)]
  5. [unheck-all-html (-> String String)])
  6. (require typed/net/url
  7. "private/ws-typed.rkt" ;; web sockets
  8. typed/json
  9. "api.rkt")
  10. ;; don't let the websockets timeout by themselves
  11. (ws-idle-timeout +inf.0)
  12. ;; Creates a new connection and spaws threads for handling incoming events
  13. ;; and for sending pings.
  14. ;; Returns an object that can be used with e.g. send-message
  15. (: make-connection
  16. (->* (String ;; Server
  17. String ;; User name
  18. #:on-chat (-> String String Void)
  19. #:on-response (-> String Void)
  20. #:on-users (-> (Listof String) Void)
  21. #:on-notify (-> String Void)
  22. #:on-join (-> String Void)
  23. #:on-leave (-> String Void)
  24. #:on-name-change (-> String String Void)
  25. #:on-close-conn (-> Void)
  26. #:on-topic (-> String Void)
  27. #:on-nick-collision (-> Void)) ()
  28. WS))
  29. (define (make-connection server-addr user-name
  30. #:on-chat on-chat ;;; called with (on-chat from message)
  31. #:on-response on-response ;;; called with (on-response message)
  32. #:on-users on-users ;;; called with (on-users users)
  33. #:on-notify on-notify ;;; called with (on-notify msg)
  34. #:on-join on-join ;;; called with (on-join user)
  35. #:on-leave on-leave ;;; called with (on-leave user)
  36. #:on-name-change on-name-change
  37. ;;; called with (on-name-change old-name new-name)
  38. #:on-close-conn on-close-conn ;;; called with (on-close-conn)
  39. #:on-topic on-topic ;;; called with (on-topic topic)
  40. #:on-nick-collision on-nick-collision
  41. )
  42. (define c (ws-connect (string->url server-addr)))
  43. (define user-color "#00FFAA")
  44. (define evt (ws-recv-evt c))
  45. (: handle-evt (-> Void))
  46. (define (handle-evt)
  47. (let ([v (sync evt)])
  48. (cond
  49. [(eof-object? v)
  50. (log-warning "RIP websocket\n")
  51. (ws-close! c)
  52. (on-close-conn)]
  53. [(string? v)
  54. (let ([js (string->jsexpr v)])
  55. (cond
  56. [(get-chat-message js)
  57. => (lambda (msg)
  58. (match msg
  59. [(chat-message message from color type)
  60. (match type
  61. ['chat (on-chat from (unheck-html message))]
  62. ['response (on-response (unheck-all-html message))]
  63. ['command-error (on-response (unheck-all-html message))]
  64. [_
  65. (log-warning
  66. (format "chat.rkt/handl-evt: cannot handle message type in ~s" msg))])]))]
  67. [(get-users-reply js) => on-users]
  68. [(get-notify js)
  69. => (lambda (note)
  70. (if (or (equal? note "Name already taken")
  71. (regexp-match #rx"Unable to change name:" note))
  72. (on-nick-collision)
  73. (on-notify note)))]
  74. [(get-topic js) => on-topic]
  75. [(get-event-data js)
  76. => (lambda (ed)
  77. (match ed
  78. [(event-data type (? string? data))
  79. (match type
  80. ['join (on-join data)]
  81. ['leave (on-leave data)]
  82. [(or 'name-changed
  83. 'name-change-forced)
  84. (match (string-split data ":")
  85. [(list old-nick new-nick)
  86. (on-name-change old-nick new-nick)]
  87. [_ #f])]
  88. [_
  89. (log-warning
  90. (format "chat.rkt/handl-evt: cannot handle event type in ~s" ed))])]))]
  91. [else
  92. (log-warning
  93. (format "chat.rkt/handle-evt: don't know how to handle ~a" (jsexpr->string js)))]))
  94. (handle-evt)]
  95. [else
  96. (printf "Unknown msg: ~a" v)
  97. (handle-evt)])))
  98. (: do-ping (-> Void))
  99. (define (do-ping)
  100. (sleep 10)
  101. (unless (ws-conn-closed? c)
  102. (send-ping c)
  103. (do-ping)))
  104. (void (thread handle-evt))
  105. (void (thread do-ping))
  106. c)
  107. ;; like make-connection but handles exceptions
  108. (: make-connection-safe
  109. (->* (String ;; Server
  110. String ;; User name
  111. #:on-chat (-> String String Void)
  112. #:on-response (-> String Void)
  113. #:on-users (-> (Listof String) Void)
  114. #:on-notify (-> String Void)
  115. #:on-join (-> String Void)
  116. #:on-leave (-> String Void)
  117. #:on-name-change (-> String String Void)
  118. #:on-close-conn (-> Void)
  119. #:on-topic (-> String Void)
  120. #:on-nick-collision (-> Void)) ()
  121. (U WS False)))
  122. (define (make-connection-safe
  123. server-addr user-name
  124. #:on-chat on-chat ;;; called with (on-chat from message)
  125. #:on-response on-response ;;; called with (on-response message)
  126. #:on-users on-users ;;; called with (on-users users)
  127. #:on-notify on-notify ;;; called with (on-notify msg)
  128. #:on-join on-join ;;; called with (on-join user)
  129. #:on-leave on-leave ;;; called with (on-leave user)
  130. #:on-name-change on-name-change
  131. ;;; called with (on-name-change old-name new-name)
  132. #:on-close-conn on-close-conn ;;; called with (on-close-conn)
  133. #:on-topic on-topic ;;; called with (on-topic topic)
  134. #:on-nick-collision on-nick-collision)
  135. (with-handlers ([(lambda (_) #t)
  136. (lambda (e)
  137. (log-warning "make-connection exception: ~a" e)
  138. #f)])
  139. (make-connection server-addr user-name #:on-chat on-chat
  140. #:on-response on-response
  141. #:on-users on-users
  142. #:on-notify on-notify
  143. #:on-join on-join
  144. #:on-leave on-leave
  145. #:on-name-change on-name-change
  146. #:on-close-conn on-close-conn
  147. #:on-topic on-topic
  148. #:on-nick-collision on-nick-collision)))