Browse Source

Fix style globally

master
eta 2 years ago
parent
commit
8076ef614c
  1. 58
      irc-messages.lisp
  2. 38
      irc.lisp
  3. 28
      ircd-errors.lisp
  4. 114
      ircd-registration.lisp
  5. 104
      ircd-types.lisp
  6. 110
      ircd.lisp
  7. 2
      packages.lisp
  8. 12
      paxos.lisp
  9. 8
      sasl.lisp

58
irc-messages.lisp

@ -1,10 +1,10 @@
; Shortcut functions for common IRC message types.
;; Shortcut functions for common IRC message types.
(in-package :nea/irc)
(defparameter *numeric-regex* (create-scanner "[0-9]+"))
; Slightly stolen from protocol.lisp in cl-irc...
;; Slightly stolen from protocol.lisp in cl-irc...
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun define-irc-message-class (name)
(let ((cname (intern (concatenate 'string "MSG-" (symbol-name name))))
@ -20,7 +20,7 @@
(define-irc-message-classes (:cap-ls :cap-req :cap-ack :cap-nak :cap-end
:nick :quit :user :error :numeric
:authenticate :privmsg :ping :pong))
:authenticate :privmsg :ping :pong))
(defclass msg-authenticate (irc-message-notrailing) ())
@ -31,29 +31,29 @@
(defun irc-message-find-class (msg)
(with-accessors
((cmd message-command) (params message-parameters)) msg
((cmd message-command) (params message-parameters)) msg
(find-class
(cond
((and (equal cmd "CAP") (equal (car params) "LS")) 'msg-cap-ls)
((and (equal cmd "CAP") (equal (car params) "END")) 'msg-cap-end)
((and (equal cmd "CAP") (equal (car params) "REQ") (eql (length params) 2)) 'msg-cap-req)
((and (equal cmd "CAP") (equal (car params) "ACK") (eql (length params) 2)) 'msg-cap-ack)
((and (equal cmd "CAP") (equal (car params) "NAK") (eql (length params) 2)) 'msg-cap-nak)
((equal cmd "CAP") (error 'invalid-arguments :command "CAP"))
((and (equal cmd "NICK") (eql (length params) 1)) 'msg-nick)
((equal cmd "NICK") (error 'invalid-arguments :command "NICK"))
((and (equal cmd "PRIVMSG") (eql (length params) 2)) 'msg-privmsg)
((equal cmd "PRIVMSG") (error 'invalid-arguments :command "PRIVMSG"))
((equal cmd "QUIT") 'msg-quit)
((and (equal cmd "USER") (eql (length params) 4)) 'msg-user)
((equal cmd "USER") (error 'invalid-arguments :command "USER"))
((and (equal cmd "AUTHENTICATE") (eql (length params) 1)) 'msg-authenticate)
((equal cmd "AUTHENTICATE") (error 'invalid-arguments :command "AUTHENTICATE"))
((equal cmd "ERROR") 'msg-error)
((equal cmd "PING") 'msg-ping)
((equal cmd "PONG") 'msg-pong)
((scan *numeric-regex* cmd) 'msg-numeric)
(t (error 'invalid-command-name :command cmd))))))
(cond
((and (equal cmd "CAP") (equal (car params) "LS")) 'msg-cap-ls)
((and (equal cmd "CAP") (equal (car params) "END")) 'msg-cap-end)
((and (equal cmd "CAP") (equal (car params) "REQ") (eql (length params) 2)) 'msg-cap-req)
((and (equal cmd "CAP") (equal (car params) "ACK") (eql (length params) 2)) 'msg-cap-ack)
((and (equal cmd "CAP") (equal (car params) "NAK") (eql (length params) 2)) 'msg-cap-nak)
((equal cmd "CAP") (error 'invalid-arguments :command "CAP"))
((and (equal cmd "NICK") (eql (length params) 1)) 'msg-nick)
((equal cmd "NICK") (error 'invalid-arguments :command "NICK"))
((and (equal cmd "PRIVMSG") (eql (length params) 2)) 'msg-privmsg)
((equal cmd "PRIVMSG") (error 'invalid-arguments :command "PRIVMSG"))
((equal cmd "QUIT") 'msg-quit)
((and (equal cmd "USER") (eql (length params) 4)) 'msg-user)
((equal cmd "USER") (error 'invalid-arguments :command "USER"))
((and (equal cmd "AUTHENTICATE") (eql (length params) 1)) 'msg-authenticate)
((equal cmd "AUTHENTICATE") (error 'invalid-arguments :command "AUTHENTICATE"))
((equal cmd "ERROR") 'msg-error)
((equal cmd "PING") 'msg-ping)
((equal cmd "PONG") 'msg-pong)
((scan *numeric-regex* cmd) 'msg-numeric)
(t (error 'invalid-command-name :command cmd))))))
(defun irc-message-ascend (msg)
(let ((new-class (restart-case
@ -68,11 +68,11 @@
(defun make-irc-message (command &key tags source params (lax nil))
"Makes a new IRC-MESSAGE instance."
(let ((msg (make-instance 'irc-message
:command (string-upcase command)
:tags tags :source source :parameters params)))
:command (string-upcase command)
:tags tags :source source :parameters params)))
(if lax
msg
(irc-message-ascend msg))))
msg
(irc-message-ascend msg))))
(defun parse-as-generic (c)
(declare (ignore c))

38
irc.lisp

@ -2,33 +2,33 @@
(defclass irc-message ()
((tags
:initarg :tags
:initform nil
:accessor message-tags)
:initarg :tags
:initform nil
:accessor message-tags)
(source
:initarg :source
:initform nil
:accessor message-source)
:initarg :source
:initform nil
:accessor message-source)
(command
:initarg :command
:accessor message-command)
:initarg :command
:accessor message-command)
(parameters
:initarg :parameters
:initform nil
:accessor message-parameters)))
:initarg :parameters
:initform nil
:accessor message-parameters)))
(defclass irc-message-source ()
((nick
:initarg :nick
:initform nil
:accessor message-source-nick)
:initarg :nick
:initform nil
:accessor message-source-nick)
(user
:initarg :user
:initform nil
:accessor message-source-user)
:initarg :user
:initform nil
:accessor message-source-user)
(host
:initarg :host
:accessor message-source-host)))
:initarg :host
:accessor message-source-host)))
(defclass irc-message-notrailing (irc-message) ())

28
ircd-errors.lisp

@ -2,23 +2,23 @@
(define-condition irc-user-error (error)
((numeric
:initarg :numeric
:reader irc-user-error-numeric)
:initarg :numeric
:reader irc-user-error-numeric)
(args
:initarg :args
:reader irc-user-error-args
:initform nil)
:initarg :args
:reader irc-user-error-args
:initform nil)
(text
:initarg :text
:initform nil
:reader irc-user-error-text))
:initarg :text
:initform nil
:reader irc-user-error-text))
(:report
(lambda (c s)
(format s "~A"
(or
(irc-user-error-text c)
(find-numeric-text (irc-user-error-numeric c))
"Unknown error")))))
(lambda (c s)
(format s "~A"
(or
(irc-user-error-text c)
(find-numeric-text (irc-user-error-numeric c))
"Unknown error")))))
(defun raise-user-error (numeric &rest args)

114
ircd-registration.lisp

@ -1,4 +1,4 @@
; Handling client registration.
;; Handling client registration.
(in-package :nea/ircd)
@ -7,101 +7,101 @@
(defun get-capabilities ()
(join-by-spaces *capabilities*))
; Fallback
;; Fallback
(defmethod handle-registration-message ((c unregistered-irc-client) (msg irc-message))
(raise-user-error 'err-notregistered))
; Basic IRC protocol registration stuff
;; Basic IRC protocol registration stuff
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-nick))
(claim-nickname c (first (message-parameters msg))))
(defmethod handle-registration-message ((c unregistered-irc-client) (msg msg-user))
(with-accessors
((params message-parameters)) msg
; FIXME: validation?
(setf (reginfo-username (client-reginfo c)) (first params))
(setf (reginfo-realname (client-reginfo c)) (elt params 3))))
((params message-parameters)) msg
;; FIXME: validation?
(setf (reginfo-username (client-reginfo c)) (first params))
(setf (reginfo-realname (client-reginfo c)) (elt params 3))))
; SASL PLAIN
;; 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)))
(authenticate-client c (make-basic-authentication-data (second payload) (third payload)))
(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
(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)))
(authenticate-client c (make-basic-authentication-data (second payload) (third payload)))
(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)))))
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 *capabilities* :test #'equal)
(push capab accepted-capabs)
(push capab rejected-capabs)))
(push capab accepted-capabs)
(push capab rejected-capabs)))
(dolist (capab accepted-capabs)
(push (intern capab) (reginfo-capabs (client-reginfo c))))
(when accepted-capabs
(server-to-user
c
(make-irc-message "CAP" :params (list "ACK" (join-by-spaces accepted-capabs)))))
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)))))))
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.")))))
(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) (username reginfo-username)
(realname reginfo-username) (capabs reginfo-capabs)) (client-reginfo client)
(and nick username realname
(or
(not capabs)
(eql (car capabs) 'end)))))
((nick reginfo-nick) (username reginfo-username)
(realname reginfo-username) (capabs reginfo-capabs)) (client-reginfo client)
(and nick username realname
(or
(not capabs)
(eql (car capabs) 'end)))))

104
ircd-types.lisp

@ -27,79 +27,79 @@
(defun find-numeric (name)
(if-nil
(cadr (assoc name *irc-numerics*))
(error "Numeric ~A is not in *IRC-NUMERICS*" name)))
(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)))
(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)
:accessor authdata-username
:initarg :username)
(password
:accessor authdata-password
:initarg :password)))
:accessor authdata-password
:initarg :password)))
(defun make-basic-authentication-data (user pass)
(make-instance 'basic-authentication-data
:username user
:password pass))
:username user
:password pass))
(defclass reginfo ()
((nick
:initform nil
:accessor reginfo-nick)
:initform nil
:accessor reginfo-nick)
(username
:initform nil
:accessor reginfo-username)
:initform nil
:accessor reginfo-username)
(realname
:initform nil
:accessor reginfo-realname)
:initform nil
:accessor reginfo-realname)
(capabilities-negotiated
:initform nil
:accessor reginfo-capabs)
:initform nil
:accessor reginfo-capabs)
(sasl-state
:initform nil
:accessor reginfo-sasl-state)))
:initform nil
:accessor reginfo-sasl-state)))
(defun make-reginfo ()
(make-instance 'reginfo))
(defclass irc-client ()
((uid
:initarg :uid
:reader client-uid)
:initarg :uid
:reader client-uid)
(socket
:initarg :socket)
:initarg :socket)
(address
:initarg :address)
:initarg :address)
(socket-reader-lock
:initarg :socket-reader-lock)
:initarg :socket-reader-lock)
(socket-writer-lock
:initarg :socket-writer-lock)
:initarg :socket-writer-lock)
(reginfo
:initarg :reginfo
:initform (make-reginfo)
:accessor client-reginfo)
:initarg :reginfo
:initform (make-reginfo)
:accessor client-reginfo)
(account
:initarg :account
:initform nil
:accessor client-account)))
:initarg :account
:initform nil
:accessor client-account)))
(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
((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
((wl socket-writer-lock) (sock socket)) c
(with-lock-held (wl) (write-irc-message msg (socket-stream sock)))))
(defgeneric server-to-user (client msg))
@ -108,25 +108,25 @@
(defmethod authenticate-client :after ((client irc-client) ad)
(server-to-user
client
(make-irc-message
(find-numeric 'rpl-loggedin)
:params (list (reginfo-nick (client-reginfo client)) (make-client-source client) (client-account client) "You are now logged in"))))
client
(make-irc-message
(find-numeric 'rpl-loggedin)
:params (list (reginfo-nick (client-reginfo client)) (make-client-source client) (client-account client) "You are now logged in"))))
(defun server-message (client msg)
(write-irc-message
(with-irc-source
msg
(make-irc-message-source *server-name*))
client))
(with-irc-source
msg
(make-irc-message-source *server-name*))
client))
(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)))
((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))
@ -136,10 +136,10 @@
(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))))
:tags tags
:source s
:params new-params
:lax t))))
(defmethod server-to-user ((client unregistered-irc-client) (msg irc-message))
@ -157,7 +157,7 @@
(defun make-irc-client (sock)
(let ((rl (make-lock)) (wl (make-lock)))
(make-instance 'unregistered-irc-client
:uid (make-client-uid)
:uid (make-client-uid)
:socket sock
:address (get-peer-address sock)
:socket-reader-lock rl

110
ircd.lisp

@ -1,4 +1,4 @@
; An IRCd, or something like that.
;; An IRCd, or something like that.
(in-package :nea/ircd)
@ -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 @@
(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 @@
(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 @@
(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 @@
(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)

2
packages.lisp

@ -11,7 +11,7 @@
string-empty-p
strip-ws
join-by-spaces
if-nil))
if-nil))
(defpackage :nea/irc
(:nicknames irc i)

12
paxos.lisp

@ -1,4 +1,4 @@
; Attempt at a Paxos implementation in Common Lisp (!)
;; Attempt at a Paxos implementation in Common Lisp (!)
(in-package :nea/paxos)
@ -51,11 +51,11 @@
(defun paxos-proposer-find-value (orig-id orig-value responses)
"Given a set of responses to a Prepare message, figure out what value we should try and propose."
(let ((ret (list orig-id orig-value)))
; For each response...
;; For each response...
(loop for item in responses
; ...if it's a "propose this instead", and the ID is higher than the current ID...
;; ...if it's a "propose this instead", and the ID is higher than the current ID...
do (when (and (eq (car item) 'instead) (> (cadr item) (car ret)))
; ...then use that one
;; ...then use that one
(setf ret (cdr item))))
ret))
@ -82,11 +82,11 @@
((eq tag 'promise) (push '(empty) responses))
((eq tag 'promise-instead) (push (cons 'instead (cdr args)) responses))
(t '())))
; did I receive Promise messages from a quorum of Acceptors?
;; did I receive Promise messages from a quorum of Acceptors?
(cons 'cont
(if (>= (length responses) *n-quorum*)
(let ((id-and-value (paxos-proposer-find-value id value responses)))
; Propose this new value.
;; Propose this new value.
(paxos-send (cons 'propose id-and-value))
(lambda (m) (paxos-proposer-proposing-step id 0 m))
)

8
sasl.lisp

@ -2,12 +2,12 @@
(defun parse-sasl-payload-inner (accum rest)
(multiple-value-bind (part rest)
(split-string-at-first rest #\Nul t)
(split-string-at-first rest #\Nul t)
(if (string-empty-p rest)
(reverse (cons part accum))
(parse-sasl-payload-inner (cons part accum) rest))))
(reverse (cons part accum))
(parse-sasl-payload-inner (cons part accum) rest))))
(defun parse-sasl-payload (payload)
(let ((decoded-payload
(babel:octets-to-string (qbase64:decode-string payload) :encoding :utf-8)))
(babel:octets-to-string (qbase64:decode-string payload) :encoding :utf-8)))
(parse-sasl-payload-inner nil decoded-payload)))
Loading…
Cancel
Save