movie-night-chat/ircd.rkt

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


(define movie-night-ws-url (make-parameter "wss://stream.ihatebeinga.live/ws"))

(: users (Listof String))
(define users '())

(define channel "#chats")

;; 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 cust)))))))
  
;; 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)

  ;; TODO:
  ;; Defining ws-c and conn simulateneously like that is asking for trouble
  ;; inb4 a race condition
  (: ws-c WS)
  (define ws-c
    (movie-night:make-connection
       (movie-night-ws-url)
       nick
       #:on-join (lambda ([n : String]) (on-join conn n))
       #:on-leave (lambda ([n : String]) (on-leave conn n))
       #:on-name-change (lambda ([n1 : String] [n2 : String])
                          (on-name-change conn n1 n2))
       #:on-users (lambda ([l : (Listof String)])
                    (set! users l) (notify-users conn))
       #:on-chat (lambda ([from : String] [msg : String])
                   (on-chat conn from msg))
       #:on-response (lambda ([msg : String]) (on-response conn msg))
       #:on-notify (lambda ([msg : String]) (on-response conn msg))
       #:on-topic (lambda ([topic : String]) (on-topic conn topic))
       #:on-close-conn (lambda () (custodian-shutdown-all cust))))
  (: conn irc-connection)
  (define conn (irc-connection in out nick user ws-c))
  ;;(set-irc-connection-ws-conn! conn ws-c)
  (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 Void))
(define (notify-users conn)
  (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 Void))
(define (on-chat conn 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 Void))
(define (on-response conn message)
  (send-to-client
   conn
   (irc-message "OwO!SERVER@lolcathost"
                "NOTICE"
                (list channel
                      (format ":!!! [ ~a ]" message)))))

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

(: on-join (-> irc-connection String Void))
(define (on-join conn 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 Void))
(define (on-leave conn 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
(: handle-user-messages (-> irc-connection Custodian Nothing))
(define (handle-user-messages conn custodian)
  (define nick (irc-connection-nick conn))
  (define msg (read-from-client conn #:timeout 333))
  (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 (equal? chan channel)
     (define c (irc-connection-ws-conn conn))
     (ws:send-join 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)))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_TOPIC
                           (list nick channel ":chatting hard")))

     (sleep 1.5) ;; is there a way around going to sleep? :-<
     (ws:send-users c)]
    [(irc-message _ "MODE" (cons chan _))
     #:when (equal? chan channel)
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_CHANNELMODEIS
                           (list nick channel "+OwO")))]
    [(irc-message _ "LIST" _)
     (send-to-client conn (irc-message
                           ":lolcathost"
                           "002"
                           (list nick " /list not implemented ")))
     ]
    [(irc-message _ "WHO" (list chan))
     #:when (equal? chan channel)
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_WHOREPLY
                           (list nick channel
                                 (irc-connection-user conn)
                                 "lolcathost"
                                 "lolcathost"
                                 nick
                                 "H"
                                 ":0")))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_ENDOFWHO
                           (list nick channel ":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))
     #:when (equal? chan channel)
     (send-ws-message conn msg)]
    [(irc-message _ "STATS" '())
     (send-ws-message conn "/STATS")]
    [(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
     (void)]
    [(var msg)
     (log-warning (format "ircd.rkt/handle-user-message: unknown message: ~a" msg))])
  (handle-user-messages conn custodian))


;; Utils
(: send-ws-message (-> irc-connection String Void))
(define (send-ws-message conn msg)
  (ws:send-message (irc-connection-ws-conn conn) msg))

(: 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 ":[Mar 2020] NEW! /STATS command & timeouts for broken connections")
  (notify-nick ":[Mar 2020] bug fixes (erc support), displaying correct topic")
  (notify-nick ":[Feb 2020] support for HexChat, JOIN & PARTs, html encoding of symbols")
  (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 ":Welcome nyaa")
  (notify-nick (format ":Please join the channel ~a nyaa" channel)))

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