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.
550 lines
24 KiB
550 lines
24 KiB
;; 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)))))
|
|
|