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.

398 lines
16 KiB

  1. #lang typed/racket
  2. ;; single room IRC server
  3. (require "private/irc-functions.rkt"
  4. (only-in "private/ws-typed.rkt" WS [ws-close! ws:close-conn] [ws-conn-closed? ws:conn-closed?])
  5. (prefix-in ws: "api.rkt")
  6. (prefix-in movie-night: "chat.rkt"))
  7. (provide (all-defined-out))
  8. ;; global crap
  9. ;; needs to be cleaned out
  10. (define movie-night-ws-url-base (make-parameter "wss://stream.ihatebeinga.live"))
  11. (define (make-ws-url [un : String])
  12. (string-append (movie-night-ws-url-base) "/channels/" un "/ws"))
  13. ;; Main entry point
  14. ;; Returns the main server loop thread (for synchronizing) and
  15. ;; a function for killing the server.
  16. (: serve (->* ()
  17. (#:port Integer #:hostname (U False String))
  18. (Values Thread (-> Void))))
  19. (define (serve #:port [port-no 6667] #:hostname [host #f])
  20. (define serve-cust (make-custodian))
  21. (parameterize ([current-custodian serve-cust])
  22. (define listener (tcp-listen port-no 5 #t host))
  23. (: loop (-> Nothing))
  24. (define (loop)
  25. (accept-and-handle listener)
  26. (loop))
  27. (define t (thread loop))
  28. (values t
  29. (lambda ()
  30. (custodian-shutdown-all serve-cust)))))
  31. ;; Accepting new clients
  32. (: accept-and-handle (-> TCP-Listener Thread))
  33. (define (accept-and-handle listener)
  34. (define cust (make-custodian))
  35. (parameterize ([current-custodian cust])
  36. (define-values (in out) (tcp-accept listener))
  37. ;; once the ports are bound we spawn a new thread
  38. ;; in oreder to allow the main server loop to handler
  39. ;; other connections
  40. (thread
  41. (lambda ()
  42. (define user-conn (accept-irc-connection in out cust))
  43. (thread (lambda () (handle-user-messages user-conn)))))))
  44. ;; When we accept a new IRC connection we need to do several things:
  45. ;; 1. Receive the user nick/user information
  46. ;; 2. Prepare the IO ports
  47. ;; 3. Create a new WebSocket connection through chat.rkt
  48. ;; 4. Set up a ping thread
  49. ;; 5. Send the MOTD to the user
  50. (: accept-irc-connection (-> Input-Port Output-Port Custodian irc-connection))
  51. (define (accept-irc-connection in out cust)
  52. (define nick
  53. (let #{loop : (-> String)} ()
  54. (match (read-from-input-port in)
  55. [(irc-message _ "NICK" params)
  56. (car params)]
  57. [_ (loop)])))
  58. (log-info (format "~a connected" nick))
  59. (define user
  60. (let #{loop : (-> String)} ()
  61. (match (read-from-input-port in)
  62. [(irc-message _ "USER" params)
  63. (car params)]
  64. [_ (loop)])))
  65. (file-stream-buffer-mode out 'line)
  66. (: conn irc-connection)
  67. (define conn (irc-connection in out nick user cust '()))
  68. (welcome-user conn)
  69. (void (thread (lambda () (ping-pong-thread conn))))
  70. conn)
  71. (: ping-pong-thread (-> irc-connection Void))
  72. (define (ping-pong-thread conn)
  73. (sleep 120)
  74. (send-to-client conn (irc-message
  75. ":lolcathost"
  76. "PING"
  77. '("fffffffffffffffffffffff")))
  78. (ping-pong-thread conn))
  79. ;; Callbacks for the MoveNight chat api
  80. (: notify-users (-> irc-connection String (Listof String) Void))
  81. (define (notify-users conn channel users)
  82. (send-to-client conn (irc-message
  83. ":lolcathost"
  84. RPL_NAMEREPLY
  85. (list (irc-connection-nick conn) "@" channel
  86. (format ":~a" (string-join users)))))
  87. (send-to-client conn (irc-message
  88. ":lolcathost"
  89. RPL_ENDOFNAMES
  90. (list (irc-connection-nick conn) channel ":End of /NAMES list."))))
  91. (: on-chat (-> irc-connection String String String Void))
  92. (define (on-chat conn channel from message)
  93. (unless (equal? from (irc-connection-nick conn))
  94. (send-to-client
  95. conn
  96. (irc-message (format "[email protected]" from from)
  97. "PRIVMSG"
  98. (list channel (format ":~a" message))))))
  99. (: on-response (-> irc-connection String String Void))
  100. (define (on-response conn channel message)
  101. (send-to-client
  102. conn
  103. (irc-message "[email protected]"
  104. "NOTICE"
  105. (list channel
  106. (format ":!!! [ ~a ]" message)))))
  107. (: on-nick-collision (-> irc-connection String Void))
  108. (define (on-nick-collision conn channel)
  109. (part-and-remove-channel! conn channel)
  110. (send-to-client
  111. conn
  112. (irc-message "[email protected]"
  113. "NOTICE"
  114. (list (irc-connection-nick conn)
  115. (format ":Sowwy, cannot join ~a because youw nickname is awweady in use :(" channel)))))
  116. (: on-topic (-> irc-connection String String Void))
  117. (define (on-topic conn channel topic)
  118. (send-to-client conn (irc-message
  119. ":lolcathost"
  120. RPL_TOPIC
  121. (list (irc-connection-nick conn)
  122. channel
  123. (string-append ":" topic)))))
  124. (: on-join (-> irc-connection String String Void))
  125. (define (on-join conn channel nick)
  126. (unless (equal? nick (irc-connection-nick conn))
  127. (send-to-client
  128. conn
  129. (irc-message (format "[email protected]" nick nick)
  130. "JOIN"
  131. (list channel)))))
  132. (: on-leave (-> irc-connection String String Void))
  133. (define (on-leave conn channel nick)
  134. (unless (equal? nick (irc-connection-nick conn))
  135. (send-to-client
  136. conn
  137. (irc-message (format "[email protected]" nick nick)
  138. "PART"
  139. (list channel)))))
  140. (: on-name-change (-> irc-connection String String Void))
  141. (define (on-name-change conn old-nick new-nick)
  142. (unless (equal? old-nick (irc-connection-nick conn))
  143. (send-to-client
  144. conn
  145. (irc-message (format "[email protected]" old-nick old-nick)
  146. "NICK"
  147. (list new-nick)))))
  148. ;; The loop for handling commands from the client
  149. ;; return type is Nothing ==> the function does not terminate
  150. ;; NB: we read from the client with the timeout
  151. ;; of 333 > the frequency of PINGs
  152. ;; so the client should respond to the PING within
  153. ;; some number of seconds in order to keep the connection alive
  154. ;; XXX this is a galaxy brain version of making sure that the connection stays alive
  155. ;; ideally this should be rewritten
  156. (: handle-user-messages (-> irc-connection Nothing))
  157. (define (handle-user-messages conn)
  158. (define msg (read-from-client conn #:timeout 333))
  159. (define nick (irc-connection-nick conn))
  160. (define custodian (irc-connection-custodian conn))
  161. (match msg
  162. [(irc-message _ "PING" (list ping))
  163. (send-to-client conn
  164. (irc-message "lolcathost"
  165. "PONG"
  166. (list "lolcathost"
  167. (string-append ":" ping))))]
  168. [(irc-message _ "PONG" (list pong))
  169. (void)]
  170. [(irc-message _ "NICK" (list nick))
  171. (define old-nick (irc-connection-nick conn))
  172. (set-irc-connection-nick! conn nick)
  173. (map (lambda ([p : (Pairof String WS)])
  174. (define channel-name (car p))
  175. (define ws (cdr p))
  176. (unless (ws:conn-closed? ws)
  177. (ws:send-message ws (string-append "/nick " nick))))
  178. (irc-connection-channels conn))
  179. (when (empty? (irc-connection-channels conn))
  180. ;; if the user hasn't joined any channels yet
  181. (on-name-change conn old-nick nick))
  182. (void)]
  183. [(irc-message _ "JOIN" (list chans-string))
  184. (define chans (string-split chans-string ","))
  185. (for ([chan chans]
  186. #:when (not (channel-joined? chan (irc-connection-channels conn))))
  187. ;; yes, let's start it in a new thread to create even more potential race conditions
  188. ;; XXX: this code was written by a dummy
  189. (thread (lambda () (join-new-channel! conn chan))))]
  190. [(irc-message _ "PART" (list chan))
  191. (part-and-remove-channel! conn chan)]
  192. [(irc-message _ "MODE" (cons chan _))
  193. #:when (channel-joined? chan (irc-connection-channels conn))
  194. (send-to-client conn (irc-message
  195. ":lolcathost"
  196. RPL_CHANNELMODEIS
  197. (list nick chan "+OwO")))]
  198. [(irc-message _ "LIST" _)
  199. (send-to-client conn (irc-message
  200. ":lolcathost"
  201. "002"
  202. (list nick " /list not implemented ")))
  203. ]
  204. [(irc-message _ "WHO" (list chan))
  205. #:when (channel-joined? chan (irc-connection-channels conn))
  206. (send-to-client conn (irc-message
  207. ":lolcathost"
  208. RPL_WHOREPLY
  209. (list nick chan
  210. (irc-connection-user conn)
  211. "lolcathost"
  212. "lolcathost"
  213. nick
  214. "H"
  215. ":0")))
  216. (send-to-client conn (irc-message
  217. ":lolcathost"
  218. RPL_ENDOFWHO
  219. (list nick chan ":End of /WHO list.")))]
  220. [(irc-message _ "WHOIS" (list target))
  221. (send-to-client conn (irc-message
  222. ":lolcathost"
  223. RPL_WHOISUSER
  224. (list nick target "neko" "lolcathost" "*" ":This user is a cat")))
  225. (send-to-client conn (irc-message
  226. ":lolcathost"
  227. RPL_WHOISSERVER
  228. (list nick target "lolcathost" ":🐈")))
  229. (send-to-client conn (irc-message
  230. ":lolcathost"
  231. RPL_ENDOFWHOIS
  232. (list nick target ":End of /WHOIS list")))]
  233. [(irc-message _ "PRIVMSG" (list chan msg))
  234. (define ws (lookup-ws-conn (irc-connection-channels conn) chan))
  235. (when ws
  236. (ws:send-message ws msg))]
  237. ;; TODO: imlement STATS again
  238. ;; [(irc-message _ "STATS" '())
  239. ;; (send-ws-message conn "/STATS")]
  240. [(irc-message _ "MOTD" _)
  241. (send-to-client conn (irc-message
  242. ":lolcathost"
  243. RPL_MOTDSTART
  244. (list nick ":- lolcathost Message of the day - ")))
  245. (for ([x cofe])
  246. (send-to-client conn (irc-message
  247. ":lolcathost"
  248. RPL_MOTD
  249. (list nick (string-append ":" x)))))
  250. (send-to-client conn (irc-message
  251. ":lolcathost"
  252. RPL_ENDOFMOTD
  253. (list nick ":End of /MOTD command.")))]
  254. [(or (? eof-object?)
  255. (irc-message _ "QUIT" _))
  256. ;; somehow attach this to a custodian?
  257. (log-warning (format "ircd.rkt: Closing socket for ~a" (irc-connection-nick conn)))
  258. (custodian-shutdown-all custodian)]
  259. [#f ;;; were unable to parse the string correctly, just ignore it
  260. (void)]
  261. [(var msg)
  262. (log-warning (format "ircd.rkt/handle-user-message: unknown message: ~a" msg))])
  263. (handle-user-messages conn))
  264. (: join-new-channel! (-> irc-connection String Void))
  265. (define (join-new-channel! conn channel-name)
  266. (define wsurl (make-ws-url (string-trim channel-name "#" #:right? #f)))
  267. (: ws-c (U WS False))
  268. (define ws-c
  269. (movie-night:make-connection-safe
  270. wsurl
  271. (irc-connection-nick conn)
  272. ;; XXX: it's a good idea NOT to do anything with the websockets in any of those callbacks
  273. ;; because they are executed in a different thread than the main message loop, which already
  274. ;; communicates with websockets
  275. #:on-join (lambda ([n : String]) (on-join conn channel-name n))
  276. #:on-leave (lambda ([n : String]) (on-leave conn channel-name n))
  277. #:on-name-change (lambda ([n1 : String] [n2 : String])
  278. (on-name-change conn n1 n2))
  279. #:on-users (lambda ([l : (Listof String)])
  280. (notify-users conn channel-name l))
  281. #:on-chat (lambda ([from : String] [msg : String])
  282. (on-chat conn channel-name from msg))
  283. #:on-response (lambda ([msg : String]) (on-response conn channel-name msg))
  284. #:on-notify (lambda ([msg : String]) (on-response conn channel-name msg))
  285. #:on-topic (lambda ([topic : String]) (on-topic conn channel-name topic))
  286. #:on-nick-collision (lambda ()
  287. ;; here we voilate that principle
  288. (on-nick-collision conn channel-name))
  289. #:on-close-conn (lambda ()
  290. ;; ok here we do fuck with the ws
  291. (part-and-remove-channel! conn channel-name))))
  292. (if (false? ws-c)
  293. (send-to-client conn (irc-message
  294. ":lolcathost"
  295. ERR_NOSUCHCHANNEL
  296. (list (irc-connection-nick conn) channel-name ":No such channel")))
  297. (begin
  298. ;; XXX: it is very important that we update the irc-connection-channels
  299. ;; before we send the join message via a websocket.
  300. ;; otherwise the websocket response might trigger on-nick-collision /before/ we updated
  301. ;; the list of joined channels
  302. (set-irc-connection-channels!
  303. conn
  304. (add-channel channel-name ws-c (irc-connection-channels conn)))
  305. (ws:send-join ws-c (irc-connection-nick conn) "#00FFAA")
  306. (send-to-client conn (irc-message
  307. (format "[email protected]"
  308. (irc-connection-nick conn)
  309. (irc-connection-user conn))
  310. "JOIN"
  311. (list channel-name)))
  312. (send-to-client conn (irc-message
  313. ":lolcathost"
  314. RPL_TOPIC
  315. (list (irc-connection-nick conn) channel-name ":chatting hard")))
  316. (sleep 1.5) ;; is there a way around going to sleep? :-<
  317. ;; have to do the check here in case part-and-remove-channel! was called
  318. ;; during the sleep or at any other point
  319. ;; The WS connections are monotone in a sense that if it becomes closed it's not going
  320. ;; to become open again
  321. (unless (ws:conn-closed? ws-c) (ws:send-users ws-c)))))
  322. (: part-and-remove-channel! (-> irc-connection String Void))
  323. (define (part-and-remove-channel! conn chan)
  324. (define channels (irc-connection-channels conn))
  325. (define nick (irc-connection-nick conn))
  326. (define ws (lookup-ws-conn channels chan))
  327. (send-to-client conn
  328. (irc-message (format "[email protected]" nick nick)
  329. "PART"
  330. (list chan)))
  331. (set-irc-connection-channels! conn (remove-channel chan channels))
  332. (when ws (ws:close-conn ws)))
  333. ;; Utils
  334. (: welcome-user (-> irc-connection Void))
  335. (define (welcome-user conn)
  336. (define nick (irc-connection-nick conn))
  337. (: notify-nick (-> String Void))
  338. (define (notify-nick msg)
  339. (send-to-client conn
  340. (irc-message "lolcathost" "002" (list nick msg))))
  341. ;; "001" has to be a string, otherwise it's converted to 1
  342. (send-to-client conn (irc-message "lolcathost" "001" (list nick "[OwO]")))
  343. (notify-nick ":-----------------------------------------------------------------------------")
  344. (notify-nick ":If you encounter an error, try reconnecting!")
  345. (notify-nick ":This IRCd does not support many features, like user to user messages or channel lists.")
  346. (notify-nick ":A lot of things are broken, please submit an issues to ")
  347. (notify-nick ": --> <https://notabug.org/epi/movie-night-chat> <--")
  348. (notify-nick ":This pwogwam comes with ABSOWUTEWY NyO WAWWANTY!11oneone")
  349. (notify-nick ":This is fwee softwawe, and you awe wewcome to wedistwibute it")
  350. (notify-nick ":undew cewtain conditions; see the LICENSE file for details UwU :3")
  351. (notify-nick ":-----------------------------------------------------------------------------")
  352. (for ([x cofe])
  353. (notify-nick (string-append ":" x)))
  354. (notify-nick ":Please join #<CHANNEL>, so for epi join #epi")
  355. (notify-nick ":Hope it works")
  356. (notify-nick ":[Apr 2020] /STATS is broken, but there are now multiple chatrooms!"))
  357. (define cofe
  358. '(" ,. ,."
  359. " || ||"
  360. " ,''--''. ON THIS SERVER"
  361. " : (.)(.) : WE DRINK COFE"
  362. " ,' `. "
  363. " : : "
  364. " : : hash tag IHBA gang"
  365. " -ctr- `._m____m_,' "))