movie-night-chat/ircd.rkt

#lang typed/racket
;; single room IRC server
(require "private/irc-functions.rkt"
         (only-in "private/ws-typed.rkt" WS [ws-close! ws:close-conn] [ws-conn-closed? ws:conn-closed?])
         (prefix-in ws: "api.rkt")
         (prefix-in movie-night: "chat.rkt"))
(provide (all-defined-out))

;; global crap
;; needs to be cleaned out
(define movie-night-ws-url-base (make-parameter "wss://stream.ihatebeinga.live"))

(define (make-ws-url [un : String])
  (string-append (movie-night-ws-url-base) "/channels/" un "/ws"))

;; Main entry point
;; Returns the main server loop thread (for synchronizing) and
;; a function for killing the server.
(: serve (->* ()
              (#:port Integer #:hostname (U False String))
              (Values Thread (-> Void))))
(define (serve #:port [port-no 6667] #:hostname [host #f])
  (define serve-cust (make-custodian))
  (parameterize ([current-custodian serve-cust])
    (define listener (tcp-listen port-no 5 #t host))
    (: loop (-> Nothing))
    (define (loop)
      (accept-and-handle listener)
      (loop))
    (define t (thread loop))
    (values t
            (lambda ()
              (custodian-shutdown-all serve-cust)))))

;; Accepting new clients
(: accept-and-handle (-> TCP-Listener Thread))
(define (accept-and-handle listener)
  (define cust (make-custodian))
  (parameterize ([current-custodian cust])
    (define-values (in out) (tcp-accept listener))
    ;; once the ports are bound we spawn a new thread
    ;; in oreder to allow the main server loop to handler
    ;; other connections
    (thread
     (lambda ()
       (define user-conn (accept-irc-connection in out cust))
       (thread (lambda () (handle-user-messages user-conn)))))))
  
;; When we accept a new IRC connection we need to do several things:
;; 1. Receive the user nick/user information
;; 2. Prepare the IO ports
;; 3. Create a new WebSocket connection through chat.rkt
;; 4. Set up a ping thread
;; 5. Send the MOTD to the user
(: accept-irc-connection (-> Input-Port Output-Port Custodian irc-connection))
(define (accept-irc-connection in out cust)
  (define nick
    (let #{loop : (-> String)} ()
      (match (read-from-input-port in)
        [(irc-message _ "NICK" params)
         (car params)]
        [_ (loop)])))

  (log-info (format "~a connected" nick))

  (define user
    (let #{loop : (-> String)} ()
      (match (read-from-input-port in)
        [(irc-message _ "USER" params)
         (car params)]
        [_ (loop)])))

  (file-stream-buffer-mode out 'line)

  (: conn irc-connection)
  (define conn (irc-connection in out nick user cust '()))

  (welcome-user conn)
  (void (thread (lambda () (ping-pong-thread conn))))
  conn)


(: ping-pong-thread (-> irc-connection Void))
(define (ping-pong-thread conn)
  (sleep 120)
  (send-to-client conn (irc-message
                        ":lolcathost"
                        "PING"
                        '("fffffffffffffffffffffff")))
  (ping-pong-thread conn))

;; Callbacks for the MoveNight chat api

(: notify-users (-> irc-connection String (Listof String) Void))
(define (notify-users conn channel users)
  (send-to-client conn (irc-message
                        ":lolcathost"
                        RPL_NAMEREPLY
                        (list (irc-connection-nick conn) "@" channel
                              (format ":~a" (string-join users)))))
  (send-to-client conn (irc-message
                        ":lolcathost"
                        RPL_ENDOFNAMES
                        (list (irc-connection-nick conn) channel ":End of /NAMES list."))))

(: on-chat (-> irc-connection String String String Void))
(define (on-chat conn channel from message)
  (unless (equal? from (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message (format "~a!~a@lolcathost" from from)
                  "PRIVMSG"
                  (list channel (format ":~a" message))))))

(: on-response (-> irc-connection String String Void))
(define (on-response conn channel message)
  (send-to-client
   conn
   (irc-message "OwO!SERVER@lolcathost"
                "NOTICE"
                (list channel
                      (format ":!!! [ ~a ]" message)))))

(: on-nick-collision (-> irc-connection String Void))
(define (on-nick-collision conn channel)
  (part-and-remove-channel! conn channel)
  (send-to-client
   conn
   (irc-message "OwO!SERVER@lolcathost"
                "NOTICE"
                (list (irc-connection-nick conn)
                      (format ":Sowwy, cannot join ~a because youw nickname is awweady in use :(" channel)))))

(: on-topic (-> irc-connection String String Void))
(define (on-topic conn channel topic)
  (send-to-client conn (irc-message
                        ":lolcathost"
                        RPL_TOPIC
                        (list (irc-connection-nick conn)
                              channel
                              (string-append ":" topic)))))

(: on-join (-> irc-connection String String Void))
(define (on-join conn channel nick)
  (unless (equal? nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message (format "~a!~a@lolcathost" nick nick)
                  "JOIN"
                  (list channel)))))

(: on-leave (-> irc-connection String String Void))
(define (on-leave conn channel nick)
  (unless (equal? nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message (format "~a!~a@lolcathost" nick nick)
                  "PART"
                  (list channel)))))

(: on-name-change (-> irc-connection String String Void))
(define (on-name-change conn old-nick new-nick)
  (unless (equal? old-nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message (format "~a!~a@lolcathost" old-nick old-nick)
                  "NICK"
                  (list new-nick)))))

;; The loop for handling commands from the client

;; return type is Nothing ==> the function does not terminate
;; NB: we read from the client with the timeout
;;     of 333 > the frequency of PINGs
;;     so the client should respond to the PING within
;;     some number of seconds in order to keep the connection alive
;; XXX this is a galaxy brain version of making sure that the connection stays alive
;; ideally this should be rewritten
(: handle-user-messages (-> irc-connection Nothing))
(define (handle-user-messages conn)
  (define msg (read-from-client conn #:timeout 333))
  (define nick (irc-connection-nick conn))
  (define custodian (irc-connection-custodian conn))
  (match msg
    [(irc-message _ "PING" (list ping))
     (send-to-client conn
                     (irc-message "lolcathost"
                                  "PONG"
                                  (list "lolcathost"
                                        (string-append ":" ping))))]
    [(irc-message _ "PONG" (list pong))
     (void)]
    [(irc-message _ "NICK" params)
     ;; TODO: propagate this info along the WS
     (set-irc-connection-nick! conn (car params))]
    [(irc-message _ "JOIN" (list chan))
     #:when (not (channel-joined? chan (irc-connection-channels conn)))
     (join-new-channel! conn chan)]
    [(irc-message _ "PART" (list chan))
     (part-and-remove-channel! conn chan)]
    [(irc-message _ "MODE" (cons chan _))
     #:when (channel-joined? chan (irc-connection-channels conn))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_CHANNELMODEIS
                           (list nick chan "+OwO")))]
    [(irc-message _ "LIST" _)
     (send-to-client conn (irc-message
                           ":lolcathost"
                           "002"
                           (list nick " /list not implemented ")))
     ]
    [(irc-message _ "WHO" (list chan))
     #:when (channel-joined? chan (irc-connection-channels conn))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_WHOREPLY
                           (list nick chan
                                 (irc-connection-user conn)
                                 "lolcathost"
                                 "lolcathost"
                                 nick
                                 "H"
                                 ":0")))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_ENDOFWHO
                           (list nick chan ":End of /WHO list.")))]
    [(irc-message _ "WHOIS" (list target))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_WHOISUSER
                           (list nick target "neko" "lolcathost" "*" ":This user is a cat")))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_WHOISSERVER
                           (list nick target "lolcathost" ":🐈")))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_ENDOFWHOIS
                           (list nick target ":End of /WHOIS list")))]
    [(irc-message _ "PRIVMSG" (list chan msg))
     (define ws (lookup-ws-conn (irc-connection-channels conn) chan))
     (when ws
       (ws:send-message ws msg))]
    ;; TODO: imlement STATS again
    ;; [(irc-message _ "STATS" '())
    ;;  (send-ws-message conn "/STATS")]
    [(irc-message _ "MOTD" _)
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_MOTDSTART
                           (list nick ":- lolcathost Message of the day - ")))
     (for ([x cofe])
       (send-to-client conn (irc-message
                             ":lolcathost"
                             RPL_MOTD
                             (list nick (string-append ":" x)))))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_ENDOFMOTD
                           (list nick ":End of /MOTD command.")))]
    [(or (? eof-object?)
         (irc-message _ "QUIT" _))
     ;; somehow attach this to a custodian?
     (log-warning (format "ircd.rkt: Closing socket for ~a" (irc-connection-nick conn)))
     (custodian-shutdown-all custodian)]
    [#f ;;; were unable to parse the string correctly, just ignore it
     (void)]
    [(var msg)
     (log-warning (format "ircd.rkt/handle-user-message: unknown message: ~a" msg))])
  (log-warning (format "XXX: channels: ~a" (irc-connection-channels conn)))
  (handle-user-messages conn))

(: join-new-channel! (-> irc-connection String Void))
(define (join-new-channel! conn channel-name)
  (define wsurl (make-ws-url (string-trim channel-name "#" #:right? #f)))
  (: ws-c WS)
  (define ws-c
    (movie-night:make-connection
     wsurl
     (irc-connection-nick conn)
     ;; XXX: it's a good idea NOT to do anything with the websockets in any of those callbacks
     ;; because they are executed in a different thread than the main message loop, which already
     ;; communicates with websockets
     #:on-join (lambda ([n : String]) (on-join conn channel-name n))
     #:on-leave (lambda ([n : String]) (on-leave conn channel-name n))
     #:on-name-change (lambda ([n1 : String] [n2 : String])
                        (on-name-change conn n1 n2))
     #:on-users (lambda ([l : (Listof String)])
                  (notify-users conn channel-name l))
     #:on-chat (lambda ([from : String] [msg : String])
                 (on-chat conn channel-name from msg))
     #:on-response (lambda ([msg : String]) (on-response conn channel-name msg))
     #:on-notify (lambda ([msg : String]) (on-response conn channel-name msg))
     #:on-topic (lambda ([topic : String]) (on-topic conn channel-name topic))
     #:on-nick-collision (lambda () (on-nick-collision conn channel-name))
     #:on-close-conn (lambda ()
                       ;; ok here we do fuck with the ws
                       (part-and-remove-channel! conn channel-name))))

  ;; XXX: it is very important that we update the irc-connection-channels
  ;; before we send the join message via a websocket.
  ;; otherwise the websocket response might trigger on-nick-collision /before/ we updated
  ;; the list of joined channels
  (set-irc-connection-channels!
   conn
   (add-channel channel-name ws-c (irc-connection-channels conn)))

  (ws:send-join ws-c (irc-connection-nick conn) "#00FFAA")
  
  (send-to-client conn (irc-message
                        (format "~a!~a@lolcathost"
                                (irc-connection-nick conn)
                                (irc-connection-user conn))
                        "JOIN"
                        (list channel-name)))
  (send-to-client conn (irc-message
                        ":lolcathost"
                        RPL_TOPIC
                        (list (irc-connection-nick conn) channel-name ":chatting hard")))
  
  (sleep 1.5) ;; is there a way around going to sleep? :-<
  ;; have to do the check here in case part-and-remove-channel! was called
  ;; during the sleep or at any other point
  ;; The WS connections are monotone in a sense that if it becomes closed it's not going
  ;; to become open again
  (unless (ws:conn-closed? ws-c) (ws:send-users ws-c)))

(: part-and-remove-channel! (-> irc-connection String Void))
(define (part-and-remove-channel! conn chan)
  (define channels (irc-connection-channels conn))
  (define nick (irc-connection-nick conn))
  (define ws (lookup-ws-conn channels chan))

  (send-to-client conn
                  (irc-message (format "~a!~a@lolcathost" nick nick)
                               "PART"
                               (list chan)))
  (set-irc-connection-channels! conn (remove-channel chan channels))
  (when ws (ws:close-conn ws)))
  
;; Utils
(: welcome-user (-> irc-connection Void))
(define (welcome-user conn)
  (define nick (irc-connection-nick conn))
  (: notify-nick (-> String Void))
  (define (notify-nick msg)
    (send-to-client conn
                    (irc-message "lolcathost" "002" (list nick msg))))
  ;; "001" has to be a string, otherwise it's converted to 1
  (send-to-client conn (irc-message "lolcathost" "001" (list nick "[OwO]")))
  (notify-nick ":-----------------------------------------------------------------------------")
  (notify-nick ":If you encounter an error, try reconnecting!")
  (notify-nick ":This IRCd does not support many features, like user to user messages or channel lists.")
  (notify-nick ":A lot of things are broken, please submit an issues to  ")
  (notify-nick ": -->  <https://notabug.org/epi/movie-night-chat>  <--")
  (notify-nick ":This pwogwam comes with ABSOWUTEWY NyO WAWWANTY!11oneone")
  (notify-nick ":This is fwee softwawe, and you awe wewcome to wedistwibute it")
  (notify-nick ":undew cewtain conditions; see the LICENSE file for details UwU :3")
  (notify-nick ":-----------------------------------------------------------------------------")
  (for ([x cofe])
    (notify-nick (string-append ":" x)))
  (notify-nick ":Please join #<CHANNEL>, so for epi join #epi")
  (notify-nick ":Hope it works")
  (notify-nick ":[Apr 2020] /STATS is broken, but there are now multiple chatrooms!"))

(define cofe
  '("            ,.  ,."
    "            ||  ||"
    "           ,''--''.                  ON THIS SERVER"
    "          : (.)(.) :                    WE DRINK COFE"
    "         ,'        `. "
    "         :          : "
    "         :          :              hash tag IHBA gang"
    "   -ctr- `._m____m_,' "))