|
|
|
@ -1,4 +1,4 @@
@@ -1,4 +1,4 @@
|
|
|
|
|
; An IRCd, or something like that. |
|
|
|
|
;; An IRCd, or something like that. |
|
|
|
|
|
|
|
|
|
(in-package :nea/ircd) |
|
|
|
|
|
|
|
|
@ -17,37 +17,37 @@
@@ -17,37 +17,37 @@
|
|
|
|
|
|
|
|
|
|
(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)))))) |
|
|
|
|
client |
|
|
|
|
(make-irc-message (find-numeric (irc-user-error-numeric err)) |
|
|
|
|
:params (append (irc-user-error-args err) (list (format nil "~A" err)))))) |
|
|
|
|
|
|
|
|
|
(defmethod claim-nickname ((client irc-client) (nick string)) |
|
|
|
|
(if (scan *nickname-regex* nick) |
|
|
|
|
(with-lock-held |
|
|
|
|
(*nicknames-lock*) |
|
|
|
|
(let ((nickuid (gethash nick *nicknames*))) |
|
|
|
|
(if nickuid |
|
|
|
|
(raise-user-error 'err-nicknameinuse nick) |
|
|
|
|
(progn |
|
|
|
|
(remhash (reginfo-nick (client-reginfo client)) *nicknames*) |
|
|
|
|
(setf (gethash nick *nicknames*) (slot-value client 'uid)) |
|
|
|
|
(setf (reginfo-nick (client-reginfo client)) nick) |
|
|
|
|
(unless (typep client (find-class 'unregistered-irc-client)) |
|
|
|
|
(write-irc-message |
|
|
|
|
(with-irc-source |
|
|
|
|
(make-irc-message "NICK" :params (list nick)) |
|
|
|
|
(make-client-source client)) |
|
|
|
|
client)) |
|
|
|
|
t)))) |
|
|
|
|
(raise-user-error 'err-erroneousnickname nick))) |
|
|
|
|
(with-lock-held |
|
|
|
|
(*nicknames-lock*) |
|
|
|
|
(let ((nickuid (gethash nick *nicknames*))) |
|
|
|
|
(if nickuid |
|
|
|
|
(raise-user-error 'err-nicknameinuse nick) |
|
|
|
|
(progn |
|
|
|
|
(remhash (reginfo-nick (client-reginfo client)) *nicknames*) |
|
|
|
|
(setf (gethash nick *nicknames*) (slot-value client 'uid)) |
|
|
|
|
(setf (reginfo-nick (client-reginfo client)) nick) |
|
|
|
|
(unless (typep client (find-class 'unregistered-irc-client)) |
|
|
|
|
(write-irc-message |
|
|
|
|
(with-irc-source |
|
|
|
|
(make-irc-message "NICK" :params (list nick)) |
|
|
|
|
(make-client-source client)) |
|
|
|
|
client)) |
|
|
|
|
t)))) |
|
|
|
|
(raise-user-error 'err-erroneousnickname nick))) |
|
|
|
|
|
|
|
|
|
(defun graduate-client (c) |
|
|
|
|
(format t "Client at ~A registered~%" (slot-value c 'address)) |
|
|
|
|
(change-class c 'registered-irc-client) |
|
|
|
|
(setf (gethash (client-uid c) *clients*) c) |
|
|
|
|
(mapcar |
|
|
|
|
(lambda (msg) (server-to-user c msg)) |
|
|
|
|
*client-registration-wall-o-text*)) |
|
|
|
|
(lambda (msg) (server-to-user c msg)) |
|
|
|
|
*client-registration-wall-o-text*)) |
|
|
|
|
|
|
|
|
|
(defmethod handle-irc-user-error :after ((c irc-client) o) |
|
|
|
|
(force-output (socket-stream (slot-value c 'socket)))) |
|
|
|
@ -58,11 +58,11 @@
@@ -58,11 +58,11 @@
|
|
|
|
|
(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))) |
|
|
|
|
(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)) |
|
|
|
|
(with-lock-held (*clients-lock*) (remhash (client-uid c) *clients*))) |
|
|
|
|
(let ((nick (reginfo-nick (client-reginfo c)))) |
|
|
|
@ -76,7 +76,7 @@
@@ -76,7 +76,7 @@
|
|
|
|
|
|
|
|
|
|
(defun find-client-by-nick (nick) |
|
|
|
|
(let* ((client-uid (gethash nick *nicknames*)) |
|
|
|
|
(client (gethash client-uid *clients*))) |
|
|
|
|
(client (gethash client-uid *clients*))) |
|
|
|
|
(cond |
|
|
|
|
((not client-uid) (raise-user-error 'err-nosuchnick nick)) |
|
|
|
|
((not client) (error "Nickname table contains dead client")) |
|
|
|
@ -86,24 +86,24 @@
@@ -86,24 +86,24 @@
|
|
|
|
|
(with-accessors ((params message-parameters)) msg |
|
|
|
|
(with-lock-held (*clients-lock*) |
|
|
|
|
(with-lock-held (*nicknames-lock*) |
|
|
|
|
(let ((target (find-client-by-nick (first params)))) |
|
|
|
|
(write-irc-message |
|
|
|
|
(with-irc-source |
|
|
|
|
(make-irc-message "PRIVMSG" :params params) |
|
|
|
|
(make-client-source c)) |
|
|
|
|
target) |
|
|
|
|
(force-output (socket-stream (slot-value target 'socket)))))))) |
|
|
|
|
(let ((target (find-client-by-nick (first params)))) |
|
|
|
|
(write-irc-message |
|
|
|
|
(with-irc-source |
|
|
|
|
(make-irc-message "PRIVMSG" :params params) |
|
|
|
|
(make-client-source c)) |
|
|
|
|
target) |
|
|
|
|
(force-output (socket-stream (slot-value target 'socket)))))))) |
|
|
|
|
|
|
|
|
|
(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)))) |
|
|
|
|
(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)))) |
|
|
|
|
(make-irc-message "PONG" :params (message-parameters msg)))) |
|
|
|
|
|
|
|
|
|
(defmethod handle-irc-message ((c unregistered-irc-client) (msg irc-message)) |
|
|
|
|
(handle-registration-message c msg) |
|
|
|
@ -113,27 +113,27 @@
@@ -113,27 +113,27 @@
|
|
|
|
|
(defun irc-client-thread (client) |
|
|
|
|
(format t "New client, address ~A~%" (slot-value client 'address)) |
|
|
|
|
(handler-case |
|
|
|
|
(loop do |
|
|
|
|
(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") |
|
|
|
|
(handle-quit client "Client Quit") |
|
|
|
|
(return)) |
|
|
|
|
(handle-irc-message client message)) |
|
|
|
|
(end-of-file () (handle-quit client "End of file")) |
|
|
|
|
(irc-user-error (e) (handle-irc-user-error client e)))))) |
|
|
|
|
(loop do |
|
|
|
|
(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") |
|
|
|
|
(handle-quit client "Client Quit") |
|
|
|
|
(return)) |
|
|
|
|
(handle-irc-message client message)) |
|
|
|
|
(end-of-file () (handle-quit client "End of file")) |
|
|
|
|
(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))) |
|
|
|
|
:reuse-address t))) |
|
|
|
|
(loop do (let* ((sock (socket-accept master-socket)) |
|
|
|
|
(client (make-irc-client sock))) |
|
|
|
|
(make-thread |
|
|
|
|
(lambda () |
|
|
|
|
(irc-client-thread client))))))) |
|
|
|
|
(client (make-irc-client sock))) |
|
|
|
|
(make-thread |
|
|
|
|
(lambda () |
|
|
|
|
(irc-client-thread client))))))) |
|
|
|
|
|
|
|
|
|
(defun start-ircd (&optional (host *listen-host*) (port *listen-port*)) |
|
|
|
|
(format t "Starting server on ~A, port ~A...~%" host port) |
|
|
|
|