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.
 

204 lines
6.7 KiB

(in-package :nea/ircd)
(defparameter *listen-host* #(127 0 0 1)
"Host to listen for connections on.")
(defparameter *listen-port* 9999
"Port to listen for connections on.")
(defparameter *server-name* "nea-ircd"
"IRCd server name.")
(defparameter *v3-capabilities* '("server-time" "sasl" "message-tags")
"IRCv3 capabilities supported by this IRCd.")
(defparameter *irc-numerics*
'((err-notregistered "451" "You have not registered")
(err-needmoreparams "461" "Invalid number of parameters for command")
(err-unknowncommand "421" "Unknown or unimplemented command")
(err-nicknameinuse "433" "Nickname in use")
(err-erroneousnickname "432" "Erroneous nickname")
(err-nosuchnick "401" "No such nick")
(rpl-loggedin "900")
(rpl-loggedout "901")
(rpl-namreply "353")
(rpl-notopic "331")
(rpl-topic "332")
(rpl-endofnames "366")
(err-nosuchchannel "403")
(err-cannotsendtochan "404")
(rpl-channelmodeis "324")
(err-chanoprivsneeded "482" "You don't have sufficient permissions to do that.")
(err-usernotinchannel "441" "They aren't in that channel")
(err-unknownmode "472" "is unknown mode char to me")
(err-notonchannel "442" "You're not in that channel")
(err-nicklocked "902")
(rpl-saslsuccess "903")
(err-saslfail "904" "SASL authentication failed")
(err-saslaborted "906" "SASL authentication aborted")
(err-saslalready "907")
(rpl-saslmechs "908"))
"Map of IRC human-readable numeric names to numerics.")
(defparameter *username-regex* (create-scanner "[A-Za-z][A-Za-z0-9\[\]\|\{\}]*")
"Regex all valid usernames must match against.")
(defparameter *channel-regex* (create-scanner "#[A-Za-z][A-Za-z0-9\.\-\_]*")
"Regex all valid channel names must match against.")
(defun find-numeric (name)
(if-nil
(cadr (assoc name *irc-numerics*))
(error "Numeric ~A is not in *IRC-NUMERICS*" name)))
(defun find-numeric-text (name)
(if-nil
(caddr (assoc name *irc-numerics*))
(error "Numeric ~A is not in *IRC-NUMERICS*, or has no text" name)))
(defclass basic-authentication-data ()
((username
:accessor authdata-username
:initarg :username)
(password
:accessor authdata-password
:initarg :password)))
(defun make-basic-authentication-data (user pass)
(make-instance 'basic-authentication-data
:username user
:password pass))
(defclass reginfo ()
((nick
:initform nil
:accessor reginfo-nick)
(username
:initform nil
:accessor reginfo-username)
(realname
:initform nil
:accessor reginfo-realname)
(capabilities-negotiated
:initform nil
:accessor reginfo-capabs)
(sasl-state
:initform nil
:accessor reginfo-sasl-state)
(supplied-password
:initform nil
:accessor reginfo-supplied-password)))
(defun make-reginfo ()
(make-instance 'reginfo))
(defclass irc-client ()
((socket
:initarg :socket)
(address
:initarg :address)
(socket-reader-lock
:initarg :socket-reader-lock)
(socket-writer-lock
:initarg :socket-writer-lock)
(reginfo
:initarg :reginfo
:initform (make-reginfo)
:accessor client-reginfo)
(username
:initarg :username
:initform nil
:accessor client-username)
(userid
:initarg :userid
:initform nil
:accessor client-userid)
(deviceid
:initarg :deviceid
:initform nil
:accessor client-deviceid)
(has-quit
:initform nil
:accessor client-has-quit)))
(defclass unregistered-irc-client (irc-client) ())
(defclass registered-irc-client (irc-client) ())
(defmethod read-irc-message ((c irc-client))
(with-slots
((rl socket-reader-lock) (sock socket)) c
(with-lock-held (rl) (read-irc-message (socket-stream sock)))))
(defmethod write-irc-message ((msg irc-message) (c irc-client))
(with-slots
((wl socket-writer-lock) (sock socket)) c
(with-lock-held (wl) (write-irc-message msg (socket-stream sock)))))
(defun server-message (client msg)
(write-irc-message
(with-irc-source
msg
(make-irc-message-source *server-name*))
client))
(defgeneric server-to-user (client msg))
(defgeneric authenticate-client (client authentication-data)
(:documentation "Authenticate a client with the provided information.
Returns the new username, user ID, and device ID (as multiple values) if successful, and NIL if not."))
(defmethod authenticate-client (client ad)
(format t "Client authentication fallback hit~%")
nil)
(defmethod authenticate-client :around ((client irc-client) ad)
(multiple-value-bind (username uid devid) (call-next-method)
(when username
(assert (and uid devid) () "AUTHENTICATE-CLIENT didn't return a uid or devid")
(format t "Client authenticated as ~A (#~A, device #~A)~%" username uid devid)
(setf (client-username client) username)
(setf (client-userid client) uid)
(setf (client-deviceid client) devid)
(symbol-macrolet ((nick (reginfo-nick (client-reginfo client))))
(unless (eql nick username)
(setf nick username)
(server-message client (make-irc-message "NICK"
:params `(,username)))))
(server-to-user
client
(make-irc-message
(find-numeric 'rpl-loggedin)
:params (list (serialize-irc-message-source (make-client-source client)) username "You are now logged in"))))))
(defun make-client-source (client)
(with-accessors
((n reginfo-nick) (u reginfo-username)) (client-reginfo client)
(make-irc-message-source
*server-name*
:nick n
:user u)))
(defmethod server-to-user ((client irc-client) (msg irc-message))
(server-message client msg))
(defun cons-onto-params (thing msg)
"Cons THING with MSG's parameter list (i.e. prepending it to the list)"
(with-accessors ((p message-parameters) (c message-command) (tags message-tags) (s message-source)) msg
(let ((new-params (cons thing p)))
(make-irc-message c
:tags tags
:source s
:params new-params
:lax t))))
(defmethod server-to-user ((client unregistered-irc-client) (msg irc-message))
(call-next-method client (cons-onto-params "*" msg)))
(defmethod server-to-user ((client registered-irc-client) (msg irc-message))
(call-next-method client (cons-onto-params (reginfo-nick (client-reginfo client)) msg)))
(defun make-irc-client (sock)
(let ((rl (make-lock)) (wl (make-lock)))
(make-instance 'unregistered-irc-client
:socket sock
:address (get-peer-address sock)
:socket-reader-lock rl
:socket-writer-lock wl)))
(define-condition client-fatal-error ()
((reason :initarg :reason
:reader client-fatal-error-reason)))