movie-night-chat/ircd.rkt

#lang racket
;; single room IRC server
(require "private/irc-functions.rkt"
         (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"))
(define users '())
(define channel "#chats")

;; Main entry point
;; Returns the main server loop thread (for synchronizing) and
;; a function for killing the server.
(define (serve #:port port-no #:hostname host)
  (define serve-cust (make-custodian))
  (parameterize ([current-custodian serve-cust])
    (define listener (tcp-listen port-no 5 #t host))
    (define (loop)
      (accept-and-handle listener)
      (loop))
    (define t (thread loop))
    (values t
            (lambda ()
              (custodian-shutdown-all serve-cust)))))

;; Accepting new clients
(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))
       (thread (lambda ()
          (handle-user-messages user-conn cust)))))))
  

(define/contract (accept-irc-connection in out)
  (-> input-port? output-port? irc-connection?)
  (define fake-conn (irc-connection in out #f #f #f))

  (define nick
    (let loop ()
      (match (read-from-client fake-conn)
        [(irc-message _ "NICK" params)
         (car params)]
        [_ (loop)])))

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

  (define user
    (let loop ()
      (match (read-from-client fake-conn)
        [(irc-message _ "USER" params)
         (car params)]
        [_ (loop)])))

  (file-stream-buffer-mode out 'line)
  (define conn (irc-connection in out nick user #f))
  (define ws-c
    (movie-night:make-connection
       (movie-night-ws-url)
       nick
       #:on-join (lambda (n) (on-join conn n))
       #:on-leave (lambda (n) (on-leave conn n))
       #:on-name-change (lambda (n1 n2) (on-name-change conn n1 n2))
       #:on-users (lambda (l) (set! users l))
       #:on-chat (lambda (from msg) (on-chat conn from msg))
       #:on-response (lambda (msg) (on-response conn msg))
       #:on-notify (lambda (msg) (on-response conn msg))))
  (set-irc-connection-ws-conn! conn ws-c)
  (welcome-user conn)
  conn)

;; Callbacks for the MoveNight chat api

(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))))))
(define (on-response conn message)
  (send-to-client
   conn
   (irc-message "OwO!SERVER@lolcathost"
                "PRIVMSG"
                (list (irc-connection-nick conn)
                      (format ":!!! [ ~a ]" message)))))

(define (on-join conn nick)
  (unless (equal? nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message nick
                  "JOIN"
                  (list channel)))))

(define (on-leave conn nick)
  (unless (equal? nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message nick
                  "PART"
                  (list channel)))))

(define (on-name-change conn old-nick new-nick)
  (unless (equal? old-nick (irc-connection-nick conn))
    (send-to-client
     conn
     (irc-message old-nick
                  "NICK"
                  (list new-nick)))))

;; The loop for handling commands from the client
(define (handle-user-messages conn custodian)
  (define nick (irc-connection-nick conn))
  (match (read-from-client conn)
    [(irc-message _ "PING" params)
     (send-to-client conn (irc-message #f "PONG" params))]
    [(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)
     (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")))
     ;; TODO: proper user list
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_NAMEREPLY
                           (list nick "@" channel
                                 (format ":~a" nick))))
     (send-to-client conn (irc-message
                           ":lolcathost"
                           RPL_ENDOFNAMES
                           (list nick channel ":End of /NAMES list.")))]
    [(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 _ "PRIVMSG" (list chan msg))
     #:when (equal? chan channel)
     (send-ws-message conn msg)]
    [(or #f
         (? eof-object?)
         (irc-message _ "QUIT" _))
     ;; TODO remove from the user list
     ;; somehow attach this to a custodian?
     (custodian-shutdown-all custodian)]
    [(var msg)
     (log-warning (format "handle-user-message: unknown message: ~a" msg))])
  (handle-user-messages conn custodian))


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

(define (welcome-user conn)
  (define nick (irc-connection-nick conn))
  (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 ":[Feb 2020] NEW! features: support for HexChat, JOINs & PARTs.")
  (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_,' "))