nea-2019/ircd.lisp

;; An IRCd, or something like that.

(in-package :nea/ircd)

(defvar *clients* (make-hash-table)
  "A table of clients, indexed by their account IDs.")
(defvar *clients-lock* (make-lock))
(defvar *message-delivery-thread* nil
  "Current thread handle for the message delivery thread.")

(defun add-client (client)
  "Add CLIENT to *CLIENTS*."
  (check-type client registered-irc-client)
  (assert (client-userid client) () "Client has no user id")
  (with-lock-held (*clients-lock*)
    (symbol-macrolet ((entry (gethash (client-userid client) *clients*)))
      (setf entry (acons (client-deviceid client) client entry)))))

(defun remove-client (client)
  "Remove the CLIENT from *CLIENTS*."
  (with-lock-held (*clients-lock*)
    (symbol-macrolet ((entry (gethash (client-userid client) *clients*)))
      (flet ((remove-test (client-cons) (eq client (cdr client-cons))))
        (when entry
          (setf entry (remove-if #'remove-test entry)))))))

(defgeneric handle-irc-message (client msg))
(defgeneric handle-irc-user-error (client condit))
(defgeneric handle-quit (client reason))

(defmethod authenticate-client ((client irc-client) (ad basic-authentication-data))
  (with-accessors ((username authdata-username) (password-str authdata-password)) ad
    (destructuring-bind (password &optional device-name)
        (uiop:split-string password-str
                           :max 2
                           :separator ":")
      (let ((uid (check-user-credentials username password)))
        (when uid
          (let ((devid (get-user-device uid (or device-name "default"))))
            (values username uid devid)))))))

(defmethod handle-irc-user-error ((client irc-client) (err irc-user-error))
  (server-to-user
   client
   (make-irc-message (find-numeric (irc-user-error-numeric err))
                     :params (append (irc-user-error-args err) (list (format nil "~A" err))))))

(defun chunk-list (size list)
  "Splits LIST into sublists of maximum length SIZE.
Stolen from https://stackoverflow.com/questions/59043375/lisp-chunking-a-vector"
  (loop
    for front = list then next
    for next = (nthcdr size front)
    collect (ldiff front next)
    while next))

(defun format-names (names)
  "Using NAMES (an alist of usernames to roles, returned by GET-GROUPCHAT-NAMES), return a list of lists of strings, with the strings being usernames with the appropriate prefixes (@/+) added."
  (loop
    for chunk in (chunk-list 5 names)
    collect (loop
              for (username . role) in chunk
              collect (concatenate 'string
                                   (case role
                                     (:operator "@")
                                     (:voiced-user "+")
                                     (t ""))
                                   username))))

(defun send-groupchat-part (gcid client body)
  "Sends the reply to a PART command for the groupchat with ID GCID to CLIENT."
  (let ((dirname (get-groupchat-name gcid)))
    (write-irc-message
     (with-irc-source
         (make-irc-message
          "PART"
          :params (if body
                    `(,dirname ,body)
                    `(,dirname)))
       (make-client-source client))
     client)))

(defun send-topic (gcid client)
  "Sends the reply to a TOPIC command (i.e. either RPL_TOPIC or RPL_NOTOPIC) for the groupchat with ID GCID to CLIENT."
  (let ((dirname (get-groupchat-name gcid))
        (subject (get-groupchat-subject gcid)))
    (server-to-user
     client
     (if (and subject (not (u:string-empty-p subject)))
         (make-irc-message (find-numeric 'rpl-topic)
                           :params `(,dirname ,subject))
         (make-irc-message (find-numeric 'rpl-notopic)
                           :params `(,dirname "No topic is set"))))))

(defun send-names (gcid client)
  "Sends the reply to a NAMES command (i.e. RPL_NAMREPLY etc.) for the groupchat with ID GCID to CLIENT."
  (let ((dirname (get-groupchat-name gcid))
        (names (get-groupchat-names gcid)))
    (loop
      for names-batch in (format-names names)
      do (server-to-user
          client
          (make-irc-message
           (find-numeric 'rpl-namreply)
           :params `("=" ,dirname ,@names-batch)))
      finally (server-to-user
               client
               (make-irc-message
                (find-numeric 'rpl-endofnames)
                :params `(,dirname "End of /NAMES list."))))))

(defun send-groupchat-join (gcid client)
  "Sends the reply to a JOIN command (i.e. JOIN, RPL_NAMREPLY, RPL_TOPIC, etc.) for the groupchat with ID GCID to CLIENT."
  (let ((dirname (get-groupchat-name gcid)))
    (write-irc-message
     (with-irc-source
         (make-irc-message
          "JOIN"
          :params `(,dirname))
       (make-client-source client)
       )
     client)
    (send-topic gcid client)
    (send-names gcid client)))

(defun send-client-groupchats (client)
  "Lets CLIENT, a newly registered client, know what groupchats they're in, by sending JOIN responses for each of those groupchats."
  (loop
    for gc in (get-groupchats-for-user (client-userid client))
    do (send-groupchat-join gc client)))

(defun graduate-client (c)
  (symbol-macrolet ((supplied-pw (reginfo-supplied-password (client-reginfo c))))
    (when (and supplied-pw (not (client-userid c)))
      (unless (authenticate-client c (make-basic-authentication-data (reginfo-nick (client-reginfo c)) supplied-pw))
        (error 'client-fatal-error
               :reason "Password authentication failed"))))
  (unless (client-userid c)
    (error 'client-fatal-error
           :reason "You must authenticate (via SASL or PASS) to use this server"))
  (format t "Client at ~A registered~%" (slot-value c 'address))
  (change-class c 'registered-irc-client)
  (add-client c)
  (mapcar (lambda (msg) (server-to-user c msg)) *client-registration-wall-o-text*)
  (send-client-groupchats c)
  (notify-new-messages))

(defun flush-client (c)
  (force-output (socket-stream (slot-value c 'socket))))

(defmethod handle-irc-user-error :after ((c irc-client) o)
  (force-output (socket-stream (slot-value c 'socket))))

(defmethod handle-irc-message :after ((c irc-client) msg)
  (force-output (socket-stream (slot-value c 'socket))))

(defmethod handle-quit :after ((c irc-client) reason)
  (format t "Client at ~A quit: ~A~%" (slot-value c 'address) reason)
  (ignore-errors
   (server-message
    c
    (make-irc-message "ERROR"
                      :params (cons (or reason "Closing link after QUIT") nil)))
   (socket-close (slot-value c 'socket)))
  (when (typep c (find-class 'registered-irc-client))
    (remove-client c))
  (setf (client-has-quit c) t))

(defmethod handle-quit ((c irc-client) reason) ())

(defmethod handle-irc-message ((c registered-irc-client) (msg irc-message))
  (raise-user-error-with-text 'err-unknowncommand "Command not implemented yet" (message-command msg)))

(defmethod handle-irc-message ((c unregistered-irc-client) (msg msg-pong)) ())
(defmethod handle-irc-message ((c registered-irc-client) (msg msg-pong)) ())

(defmethod handle-irc-message ((c unregistered-irc-client) (msg msg-ping))
  (server-to-user c
                  (make-irc-message "PONG" :params (message-parameters msg))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-ping))
  (server-to-user c
                  (make-irc-message "PONG" :params (message-parameters msg))))

(defmethod handle-irc-message ((c unregistered-irc-client) (msg irc-message))
  (handle-registration-message c msg)
  (when (client-can-register c)
    (graduate-client c)))

(defun filter-client-tags (tags)
  "Filters TAGS, a set of IRCv3 tags, to contain only tags prefixed with + (which are client-only)."
  (flet ((is-client-only (tag)
           (starts-with #\+ (car tag))))
    (remove-if (complement #'is-client-only) tags)))

(defun privmsg-or-notice-inner (c msg is-notice)
  (with-accessors ((params message-parameters)) msg
    (let ((target (first params))
          (tags (filter-client-tags (message-tags msg))))
      (if (scan *channel-regex* target)
          (let ((gcid (get-groupchat-by-directory-name (subseq target 1))))
            (unless gcid
              (raise-user-error-with-text 'err-nosuchchannel "Channel does not exist"))
            (unless (groupchat-member-p gcid (client-userid c))
              (raise-user-error-with-text 'err-cannotsendtochan "You're not in that groupchat"))
            (unless (check-groupchat-capability gcid (client-userid c) :send-message)
              (raise-user-error-with-text 'err-cannotsendtochan "You can't speak in that groupchat"))
            (insert-db-message (client-userid c) tags (car (last params))
                               :gcid-to gcid
                               :is-notice is-notice))
          (progn
            (let ((target (query-user-target target)))
              (unless target
                (raise-user-error 'err-nosuchnick))
              (insert-db-message (client-userid c) tags (car (last params))
                                 :uid-to target
                                 :is-notice is-notice))))
      (notify-new-messages))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-privmsg))
  (privmsg-or-notice-inner c msg nil))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-notice))
  (privmsg-or-notice-inner c msg t))

(defun get-or-make-groupchat-target (name)
  "Takes NAME, a groupchat target (e.g. #CHANNELNAME), and returns a groupchat ID for that target, creating a new groupchat if one doesn't exist. Throws an error if the target is invalid."
  (unless (scan *channel-regex* name)
    (raise-user-error-with-text 'err-nosuchchannel "Channel name is invalid"))
  (get-or-make-groupchat-by-directory-name (subseq name 1)))

(defun get-groupchat-target (name)
  "Takes NAME, a groupchat target (e.g. #CHANNELNAME), and returns a groupchat ID for that target. Throws an error if the target is invalid, or the groupchat doesn't exist."
  (unless (scan *channel-regex* name)
    (raise-user-error-with-text 'err-nosuchchannel "Channel name is invalid"))
  (let ((gcid (get-groupchat-by-directory-name (subseq name 1))))
    (unless gcid
      (raise-user-error-with-text 'err-nosuchchannel "Channel does not exist"))
    gcid))

(defun check-groupchat-member (gcid uid)
  "Checks that the user with ID UID is in the groupchat with ID GCID, and raises the ERR_NOTONCHANNEL usre error if not."
  (unless (groupchat-member-p gcid uid)
    (raise-user-error 'err-notonchannel)))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-join))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      (multiple-value-bind (gcid newly-created-p)
          (get-or-make-groupchat-target (first params))
        (pomo:with-logical-transaction ()
          (when (groupchat-member-p gcid uid)
            ;; Do nothing
            (return-from handle-irc-message))
          (insert-groupchat-membership gcid uid
                                       (if newly-created-p :operator :user))
          (insert-db-join-message uid gcid)
          (send-groupchat-join gcid c)
          (notify-new-messages))))))


(defmethod handle-irc-message ((c registered-irc-client) (msg msg-part))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      (pomo:with-logical-transaction ()
        (let ((gcid (get-groupchat-target (first params)))
              (body (when (> (length params) 1) (car (last params)))))
          (insert-db-part-message uid gcid body)
          (delete-groupchat-membership gcid uid)
          (send-groupchat-part gcid c body)
          (notify-new-messages))))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-mode-query))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      (let ((gcid (get-groupchat-target (first params))))
        (check-groupchat-member gcid uid)
        (server-to-user c
                        (make-irc-message
                         (find-numeric 'rpl-channelmodeis)
                         :params `(,(first params) "+nt")))))))

(defun decode-mode-op (op)
  "Decodes a mode operation (e.g. +o/+v) for a user to a symbol representing a role. Returns this symbol, and another value indicating whether this mode is to be added (T) or not (NIL).
If the operation is unrecognized (or too complex for this basic implementation), throws a user error."
  (unless (and (eql (length op) 2)
               (find (elt op 0) '(#\+ #\-))
               (find (elt op 1) '(#\o #\v)))
    (raise-user-error 'err-unknownmode op))
  (values
   (ecase (elt op 1)
     (#\o :operator)
     (#\v :voiced-user))
   (equal (elt op 0) #\+)))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-mode-set))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      ;; This just supports commands of the form
      ;;   MODE #channel +o/-o/+v/-v USER
      ;; for now.
      (unless (eql (length params) 3)
        (raise-user-error 'err-needmoreparams))
      (pomo:with-logical-transaction ()
        (multiple-value-bind (role added-p)
            (decode-mode-op (second params))
          (let ((gcid (get-groupchat-target (first params)))
                (target (query-user-target (third params)))
                ;; It's hard to map the semantics of -o/-v exactly.
                ;; Here, we just interpret removing a role as setting
                ;; your role back to :USER.
                (new-role (if added-p role :user)))
            (unless target
              (raise-user-error 'err-nosuchnick))
            (check-groupchat-member gcid uid)
            (unless (groupchat-member-p gcid target)
              (raise-user-error 'err-usernotinchannel))
            (unless (check-groupchat-capability gcid uid :change-roles)
              (raise-user-error 'err-chanoprivsneeded (get-groupchat-name gcid)))
            (update-groupchat-membership gcid target new-role)
            (insert-db-mode-message uid gcid (second params) target)
            (notify-new-messages)))))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-topic-query))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      (let ((gcid (get-groupchat-target (first params))))
        (check-groupchat-member gcid uid)
        (send-topic gcid c)))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-topic-set))
  (with-accessors ((params message-parameters)) msg
    (with-accessors ((uid client-userid)) c
      (pomo:with-logical-transaction ()
        (let ((gcid (get-groupchat-target (first params)))
              (new-topic (car (last params))))
          (check-groupchat-member gcid uid)
          (unless (check-groupchat-capability gcid uid :change-subject)
            (raise-user-error 'err-chanoprivsneeded (get-groupchat-name gcid)))
          (update-groupchat-subject gcid new-topic)
          (insert-db-topic-message uid gcid new-topic)
          (notify-new-messages))))))

(defmethod handle-irc-message ((c registered-irc-client) (msg msg-names))
  (with-accessors ((params message-parameters)) msroles
    (with-accessors ((uid client-userid)) c
      (let ((gcid (get-groupchat-target (first params))))
        (check-groupchat-member gcid uid)
        (send-names gcid c)))))

(defun irc-client-thread (client)
  (format t "New client, address ~A~%" (slot-value client 'address))
  (handler-case
      (loop do
        (macrolet ((client-quit (reason)
                     `(progn (handle-quit client ,reason) (return))))
          (handler-case
              (let ((message
                      (handler-case (read-irc-message client)
                        (invalid-arguments (c) (raise-user-error 'err-needmoreparams (attempted-command-name c)))
                        (invalid-command-name (c) (raise-user-error 'err-unknowncommand (attempted-command-name c))))))
                (when (equal (message-command message) "QUIT")
                  (client-quit "Client Quit"))
                (handle-irc-message client message))
            (client-fatal-error (e) (client-quit (client-fatal-error-reason e)))
            (end-of-file () (client-quit "End of file"))
            (stream-error (e) (client-quit (format nil "Stream error: ~A" e)))
            (irc-user-error (e) (handle-irc-user-error client e)))))))

(defun irc-listen (host port)
  (let ((master-socket (socket-listen host port
                                      :reuse-address t)))
    (unwind-protect
         (loop do (let* ((sock (socket-accept master-socket))
                         (client (make-irc-client sock)))
                    (make-thread
                     (lambda ()
                       (pomo:with-connection *default-database-args*
                         (unwind-protect
                              (irc-client-thread client)
                           (unless (client-has-quit client)
                             (handle-quit client "Thread terminated unexpectedly"))))))
                    :name "ircd client thread"))
      (ignore-errors (socket-close master-socket)))))

(defmacro for-each-client ((uid devid client) &body body)
  "Runs BODY forms, binding UID, DEVID and CLIENT to the user ID, device ID, and client object of each client in *CLIENTS*."
  (let ((alist (gensym)))
  `(with-lock-held (*clients-lock*)
    (loop
      for ,uid being the hash-keys of *clients*
        using (hash-value ,alist)
      do (loop
           for (,devid . ,client) in ,alist
           do (progn ,@body))))))

(defun deliver-message-to-client (message client)
  "Delivers MESSAGE (a message from the database) to CLIENT."
  (when (db-message-should-send-to message client)
    (write-irc-message
     (make-irc-message
      (db-message-command message)
      :tags (db-message-tags message client)
      :source (db-message-source message)
      :params (db-message-parameters message client))
     client)))

(defun message-delivery-thread ()
  "Thread entry point for the message delivery thread.
This thread waits for new messages to be added to the database (via PostgreSQL LISTEN).
When they arrive, it delivers them to connected clients."
  (pomo:execute "LISTEN \"ircd-messages\";")
  (loop
    (format t "Delivering new messages...~%")
    (pomo:with-transaction ()
      (for-each-client (uid devid client)
        (let* ((messages (pomo:query
                          (:order-by
                           (:select 'm.* :distinct
                                    :from (:as 'messages 'm) (:as 'local_user_devices 'lud)
                                    :left-join (:as 'groupchat_memberships 'gcm) :on (:= 'gcm.user_id '$1)
                                    :where (:and
                                            (:= 'lud.id '$2)
                                            (:< 'lud.highest_seq 'm.seq)
                                            (:or
                                             (:= 'm.user_to '$1)
                                             (:and
                                              (:= 'gcm.user_id '$1)
                                              (:= 'gcm.groupchat_uuid 'm.groupchat_to)))))
                           'seq)
                         uid devid (:dao db-message)))
               (system-messages (pomo:query
                                 (:order-by
                                  (:select 'm.* :distinct
                                           :from (:as 'system_messages 'm) (:as 'local_user_devices 'lud)
                                           :left-join (:as 'groupchat_memberships 'gcm) :on (:= 'gcm.user_id '$1)
                                           :where (:and
                                                   (:= 'lud.id '$2)
                                                   (:< 'lud.highest_seq 'm.seq)
                                                   (:or
                                                    (:= 'm.target_user_ref '$1)
                                                    (:and
                                                     (:= 'gcm.user_id '$1)
                                                     (:= 'gcm.groupchat_uuid 'm.groupchat_ref)))))
                                  'seq)
                                uid devid (:dao db-system-message)))
               (both-messages (nconc messages (mapcar #'parse-db-system-message system-messages)))
               (seq (loop
                      for msg in both-messages
                      do (deliver-message-to-client msg client)
                      maximizing (dbm-seq msg) into seq
                      finally (return seq))))
          (unless (null both-messages)
            (flush-client client)
            (format t "Delivered ~A message(s) to #~A/#~A.~%"
                    (length both-messages) (client-userid client) (client-deviceid client))
            (pomo:execute (:update 'local_user_devices
                           :set 'highest_seq '$1
                           :where (:= 'id '$2))
                          seq devid)))))
    (cl-postgres:wait-for-notification pomo:*database*)))

(defun start-message-delivery-thread ()
  "Starts the message delivery thread."
  (format t "Starting message delivery thread...~%")
  (when *message-delivery-thread*
    (format t "(Destroying old thread!)~%")
    (ignore-errors (destroy-thread *message-delivery-thread*)))
  (setf *message-delivery-thread*
        (make-thread (lambda ()
                       (pomo:with-connection *default-database-args*
                         (message-delivery-thread)))
                     :name "ircd message delivery thread")))

(defun start-ircd (&optional (host *listen-host*) (port *listen-port*))
  (format t "Starting server on ~A, port ~A...~%" host port)
  (start-message-delivery-thread)
  (irc-listen host port))

(defmacro setf-not-nil (place value)
  "Sets PLACE to VALUE (using SETF), but only if VALUE isn't NIL."
  (let ((val-sym (gensym)))
    `(let ((,val-sym ,value))
       (when ,val-sym
         (setf ,place ,val-sym)))))

(defun handle-toplevel-error (e)
  (format *error-output* "fatal: ~A~%" e)
  (format *error-output* "backtrace:~%")
  (trivial-backtrace:print-backtrace e
                                     :output *error-output*)
  (opts:exit 1))

(defun print-help-text ()
  (opts:describe
   :prefix "NEA IRCd project"
   :usage-of "nea-ircd")
  (opts:exit 2))

(defun handle-interrupt ()
  (format t "Quitting after user interrupt.~%")
  (opts:exit 0))

(defun main-inner (argv)
  (let ((opts (opts:get-opts argv)))
    (when (getf opts :help)
      (print-help-text))
    (setf *listen-host* (getf opts :listen-host))
    (setf-not-nil *listen-port* (getf opts :listen-port))
    (setf-not-nil *server-name* (getf opts :server-name))
    (setf-not-nil (first *default-database-args*) (getf opts :db-database))
    (setf-not-nil (second *default-database-args*) (getf opts :db-username))
    (setf-not-nil (third *default-database-args*) (getf opts :db-password))
    (setf-not-nil (fourth *default-database-args*) (getf opts :db-host))
    (setf-not-nil (sixth *default-database-args*) (getf opts :db-port))
    (format t "Running NEA IRCd with server name '~A'.~%" *server-name*)
    (format t "Connecting to database using: ~A~%" *default-database-args*)
    (initialize-database)
    (let ((new-username (getf opts :new-username))
          (new-password (getf opts :new-password)))
      (when new-username
        (unless new-password
          (format *error-output* "fatal: supply a new password with --new-password!~%")
          (opts:exit 2))
        (format t "Creating new user...")
        (register-user new-username new-password "nowhere@example.invalid")
        (format t "done.~%")
        (opts:exit 3)))
    (start-ircd)))

(defun main ()
  (let ((argv (opts:argv)))
    (handler-case
        (main-inner argv)
      (sb-sys:interactive-interrupt ()
        (handle-interrupt))
      (usocket:unknown-error (e)
        (if (typep (usocket::usocket-real-error e) 'sb-sys:interactive-interrupt)
            (handle-interrupt)
            (handle-toplevel-error e)))
      (opts::troublesome-option (e)
        (progn
          (when (or (member "-h" argv :test #'equal)
                    (member "--help" argv :test #'equal))
            (print-help-text))
          (format *error-output* "fatal: ~A~%" e)
          (format *error-output* "hint: try the --help argument for usage instructions~%")
          (opts:exit 2)))
      (error (e)
        (handle-toplevel-error e)))))