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.
 

122 lines
5.1 KiB

;; Handling client registration.
(in-package :nea/ircd)
(defgeneric handle-registration-message (client msg))
(defun get-capabilities ()
(join-by-spaces *v3-capabilities*))
;; Fallback
(defmethod handle-registration-message ((c unregistered-irc-client) (msg irc-message))
(raise-user-error 'err-notregistered))
;; Basic IRC protocol registration stuff
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-nick))
;; If they're using SASL, this gets overwritten with the account name later on.
(symbol-macrolet ((nick (reginfo-nick (client-reginfo c))))
(unless (and nick (equal nick (client-username c))) ; disallow changes from the correct value
(setf (reginfo-nick (client-reginfo c)) (first (message-parameters msg))))))
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-user))
(with-accessors
((params message-parameters)) msg
(setf (reginfo-username (client-reginfo c)) (first params))
(setf (reginfo-realname (client-reginfo c)) (elt params 3))))
;; Old-school auth
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-pass))
(setf (reginfo-supplied-password (client-reginfo c)) (first (message-parameters msg))))
;; SASL PLAIN
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-authenticate))
(with-accessors ((sasl-state reginfo-sasl-state)) (client-reginfo c)
(with-accessors ((params message-parameters)) msg
(handler-case
(if sasl-state ; We only support SASL PLAIN for now
(let ((payload (parse-sasl-payload (first params))))
(unless (eql (length payload) 3)
(error "Invalid SASL PLAIN payload length ~A" (length payload)))
(unless (authenticate-client c (make-basic-authentication-data (second payload) (third payload)))
(error "Authentication was unsuccessful"))
(server-to-user
c
(make-irc-message (find-numeric 'rpl-saslsuccess)
:params '("SASL authentication successful"))))
(if (equal (first params) "PLAIN")
(progn
(setf sasl-state t)
(write-irc-message
(make-irc-message "AUTHENTICATE" :params '("+"))
c))
(server-to-user
c
(make-irc-message (find-numeric 'rpl-saslmechs)
:params '("PLAIN" "are available SASL mechanisms")))))
(error (e)
(format t "SASL negotiation error: ~A~%" e)
(raise-user-error 'err-saslfail))))))
; IRCv3 Capability Negotiation
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-cap-ls))
(push 'cap (reginfo-capabs (client-reginfo c)))
(server-to-user
c
(make-irc-message "CAP" :params (list "LS" (get-capabilities)))))
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-cap-req))
(let ((requested-capabs (uiop:split-string (elt (message-parameters msg) 1) :separator " "))
(accepted-capabs) (rejected-capabs))
(dolist (capab requested-capabs)
(if (member capab *v3-capabilities* :test #'equal)
(push capab accepted-capabs)
(push capab rejected-capabs)))
(dolist (capab accepted-capabs)
(push (intern (string-upcase capab) :keyword) (reginfo-capabs (client-reginfo c))))
(when accepted-capabs
(server-to-user
c
(make-irc-message "CAP" :params (list "ACK" (join-by-spaces accepted-capabs)))))
(when rejected-capabs
(server-to-user
c
(make-irc-message "CAP" :params (list "NAK" (join-by-spaces rejected-capabs)))))))
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-cap-end))
(push 'end (reginfo-capabs (client-reginfo c))))
(defparameter *client-registration-wall-o-text*
(mapcar
(lambda (args) (apply #'make-irc-message args))
(list
'("001" :params ("Welcome to the somewhat hacky NEA IRC server!"))
'("002" :params ("This server is only barely standards-compliant."))
'("003" :params ("Who cares when this server was created?"))
(list "004" :params (list *server-name* "0.0.0" "i" "nt"))
'("005" :params ("AWAYLEN=200" "CASEMAPPING=ascii" "NETWORK=nea-ircd" "NICKLEN=100" "PREFIX=(qaohv)~&@%+"))
'("375" :params ("- Message of the day -"))
'("372" :params ("- Good luck!"))
'("376" :params ("End of /MOTD command.")))))
(defun client-can-register (client)
"Tests whether CLIENT has enough information to register."
(with-accessors
((nick reginfo-nick) (realname reginfo-realname) (capabs reginfo-capabs)
(supplied-password reginfo-supplied-password)) (client-reginfo client)
(with-accessors
((username client-username)) client
(and nick realname
(or (not username) (equal nick username))
(or
(not capabs)
(eql (car capabs) 'end))))))
(defun client-supports-capability-p (client capab)
"Tests whether CLIENT supports the CAPAB capability."
(find capab (reginfo-capabs (client-reginfo client))))