Browse Source

move some code around & relabel it a bit

master
eta 2 years ago
parent
commit
4e09b95071
  1. 30
      irc-message.lisp
  2. 133
      irc.lisp
  3. 56
      ircd.cl
  4. 31
      ircd.lisp
  5. 6
      nea.asd
  6. 5
      paxos.lisp
  7. 5
      test-ircd.lisp
  8. 43
      utils.lisp

30
irc-message.lisp

@ -0,0 +1,30 @@
(defpackage :nea/irc
(:use common-lisp)
(:export :irc-message
:irc-message-source))
(in-package :nea/irc)
(defclass irc-message ()
((tags
:initarg :tags
:initform nil)
(source
:initarg :source
:initform nil)
(command
:initarg :command)
(parameters
:initarg :parameters
:initform nil)))
(defclass irc-message-source ()
((nick
:initarg :nick
:initform nil)
(user
:initarg :user
:initform nil)
(host
:initarg :host)))

133
irc.lisp

@ -1,38 +1,15 @@
; This file maybe does IRC message stuff. Maybe.
(defpackage :nea/irc-parser
(:use :common-lisp)
(:export :irc-message
:irc-message-source
:irc-message-serialize
(:use :common-lisp
:nea/utils
:nea/irc)
(:export :irc-message-serialize
:irc-message-parse))
(in-package :nea/irc-parser)
(defclass irc-message ()
((tags
:initarg :tags
:initform nil)
(source
:initarg :source
:initform nil)
(command
:initarg :command)
(parameters
:initarg :parameters
:initform nil)))
(defclass irc-message-source ()
((nick
:initarg :nick
:initform nil)
(user
:initarg :user
:initform nil)
(host
:initarg :host)))
(defun irc-message-source-serialize (src out)
(defun source-serialize (src out)
(with-slots ((nick nick) (user user) (host host)) src
(cond
((and nick user host) (format out "~A!~A@~A" nick user host))
@ -41,64 +18,36 @@
(host (format out "~A" host))
(t nil))))
(defun split-string-at (str pos &optional (consume-value-at-pos-p nil))
"Splits STR at POS, returning two values. If CONSUME-VALUE-AT-POS-P is truthy, throws away the character at POS."
(declare (type string str) (type fixnum pos))
(cond
((> pos (length str)) (error "Position is outside string."))
((eql pos (length str)) (values str ""))
(t (values (subseq str 0 pos) (subseq str (+ pos (if consume-value-at-pos-p 1 0)))))))
(defun split-string-at-first (str char &optional (consume-value-at-pos-p nil))
"Splits STR at the first instance of CHAR, otherwise behaving like SPLIT-STRING-AT. If no CHAR is found, returns the input string and an empty string."
(declare (type string str) (type character char))
(let ((pos (position char str)))
(if pos
(split-string-at str pos consume-value-at-pos-p)
(values str ""))))
(defun starts-with (thing seq)
"Returns T if SEQ starts with THING."
(if (and seq (> (length seq) 0))
(eql (elt seq 0) thing)
nil))
(defun string-empty-p (str)
"Returns T if str is of length 0 or is NIL, NIL otherwise."
(if str
(eql (length str) 0)
nil))
(defun irc-message-finalize (tags source args)
(defun finalize (tags source args)
(let ((args (reverse args)))
(make-instance 'irc-message :tags tags :source source :command (car args) :parameters (cdr args))))
(defun irc-message-parse-source (src)
(defun parse-source (src)
(multiple-value-bind (nick-user host)
(split-string-at-first src #\@ t)
(if (string-empty-p host)
(make-instance 'irc-message-source :host src)
(make-instance 'source :host src)
(multiple-value-bind (nick user)
(split-string-at-first src #\! t)
(if (string-empty-p user)
(make-instance 'irc-message-source :nick nick-user :host host)
(make-instance 'irc-message-source :nick nick :user user :host host))))))
(make-instance 'source :nick nick-user :host host)
(make-instance 'source :nick nick :user user :host host))))))
(defun irc-message-serialize-source (source out)
(defun serialize-source (source out)
(when source
(write-char #\: out)
(irc-message-source-serialize source out)
(source-serialize source out)
(write-char #\Space out)))
(defun irc-message-serialize-args (args out)
(defun serialize-args (args out)
(format out "~{~A~^ ~} " args))
(defun irc-message-serialize-trailing (trailing out)
(defun serialize-trailing (trailing out)
(when trailing
(write-char #\: out)
(write-sequence trailing out)))
(defun irc-message-serialize-tag-value (value out)
(defun serialize-tag-value (value out)
(loop for char across value
do (let ((special-sequence
(cond
@ -111,17 +60,17 @@
(write-sequence special-sequence out)
(write-char char out)))))
(defun irc-message-serialize-tags (tags out)
(defun serialize-tags (tags out)
(when tags
(write-char #\@ out)
(dolist (tagpair tags)
(irc-message-serialize-tag-value (car tagpair) out)
(serialize-tag-value (car tagpair) out)
(when (cdr tagpair)
(write-char #\= out)
(irc-message-serialize-tag-value (cadr tagpair) out)))
(serialize-tag-value (cadr tagpair) out)))
(write-char #\Space out)))
(defun irc-message-parse-tag-value (accum value)
(defun parse-tag-value (accum value)
(if (string-empty-p value)
accum
(if (and (eql (elt value 0) #\\) (eql (length value) 1))
@ -136,72 +85,72 @@
((eq next-elt #\n) #\linefeed)
(t next-elt))
accum)
(irc-message-parse-tag-value accum (subseq value 2)))
(parse-tag-value accum (subseq value 2)))
(progn
(vector-push-extend (elt value 0) accum)
(irc-message-parse-tag-value accum (subseq value 1)))))))
(parse-tag-value accum (subseq value 1)))))))
(defun irc-message-parse-tag (tag)
(defun parse-tag (tag)
(multiple-value-bind (key value)
(split-string-at-first tag #\= t)
(if (string-empty-p value)
(list key)
(list key (irc-message-parse-tag-value
(list key (parse-tag-value
(make-array (length value)
:element-type 'character
:fill-pointer 0
:adjustable t)
value)))))
(defun irc-message-parse-tags (tags left)
(defun parse-tags (tags left)
(multiple-value-bind (first-tag others)
(split-string-at-first left #\; t)
(let ((parsed-tag (irc-message-parse-tag first-tag)))
(let ((parsed-tag (parse-tag first-tag)))
(if (string-empty-p others)
(cons parsed-tag tags)
(irc-message-parse-tags (cons parsed-tag tags) others)))))
(parse-tags (cons parsed-tag tags) others)))))
(defun irc-message-slurp-args (tags source args trailing msg)
(defun slurp-args (tags source args trailing msg)
(multiple-value-bind (word remaining)
(split-string-at-first msg #\Space t)
(if (string-empty-p remaining)
(irc-message-finalize tags source (if trailing
(finalize tags source (if trailing
(cons trailing (cons word args))
(cons word args)))
(irc-message-slurp-args tags source (cons word args) trailing remaining))))
(slurp-args tags source (cons word args) trailing remaining))))
(defun irc-message-parse-inner (tags source args msg)
(defun parse-inner (tags source args msg)
(if (or (and tags source) source args)
(multiple-value-bind (args-bit trailing-bit)
(split-string-at-first msg #\: t)
(if (string-empty-p trailing-bit)
(irc-message-slurp-args tags source args nil args-bit)
(irc-message-slurp-args tags source args trailing-bit args-bit)))
(slurp-args tags source args nil args-bit)
(slurp-args tags source args trailing-bit args-bit)))
(multiple-value-bind (first-word remaining)
(split-string-at-first msg #\Space t)
(if (string-empty-p remaining)
(irc-message-finalize tags source (cons first-word args))
(finalize tags source (cons first-word args))
(cond
((starts-with #\@ first-word)
(irc-message-parse-inner (irc-message-parse-tags nil (subseq first-word 1)) tags args remaining))
(parse-inner (parse-tags nil (subseq first-word 1)) tags args remaining))
((starts-with #\: first-word)
(irc-message-parse-inner tags (irc-message-parse-source (subseq first-word 1)) args remaining))
(t (irc-message-parse-inner tags source (cons first-word args) remaining)))))))
(parse-inner tags (parse-source (subseq first-word 1)) args remaining))
(t (parse-inner tags source (cons first-word args) remaining)))))))
(defun irc-message-parse (msg)
"Parses the IRC message stored in MSG, and returns an IRC-MESSAGE object."
(irc-message-parse-inner nil nil nil msg))
(parse-inner nil nil nil msg))
(defun irc-message-serialize (src out)
(with-slots ((tags tags) (source source) (command command) (args parameters)) src
(irc-message-serialize-tags tags out)
(irc-message-serialize-source source out)
(serialize-tags tags out)
(serialize-source source out)
(write-sequence command out)
(when (> (length args) 0)
(write-char #\Space out))
; FIXME: using butlast and last seems inefficient
(when (> (length args) 1)
(irc-message-serialize-args (butlast args) out))
(irc-message-serialize-trailing (car (last args)) out)))
(serialize-args (butlast args) out))
(serialize-trailing (car (last args)) out)))

56
ircd.cl

@ -1,56 +0,0 @@
; An IRCd, or something like that.
(defpackage :nea/ircd
(:use :common-lisp
:usocket
:bordeaux-threads
:nea/irc-parser))
(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.")
(defclass irc-client ()
((socket
:initarg socket)
(socket-reader-lock
:initarg socket-reader-lock)
(socket-writer-lock
:initarg socket-writer-lock)))
(defun strip-ws (str)
(string-trim '(#\Space #\Tab #\Return #\Linefeed) str))
(defgeneric irc-client-read-message (client))
(defmethod irc-client-read-message ((client irc-client))
(irc-message-parse (strip-ws (read-line (slot-value client 'socket)))))
(defmethod irc-client-read-message :before ((client irc-client))
(acquire-lock (slot-value client 'socket-reader-lock)))
(defmethod irc-client-read-message :after ((client irc-client))
(release-lock (slot-value client 'socket-reader-lock)))
(defun irc-listen-thread (sock)
(loop do (let* ((input (strip-ws (read-line sock)))
(parsed (irc-message-parse input)))
(describe parsed sock)
(irc-message-serialize parsed sock)
(format sock "~%")
(force-output sock))))
(defun irc-listen (host port)
(let ((master-socket (socket-listen host port
:reuse-address t)))
(loop do (let* ((sock (socket-accept master-socket))
(sock-stream (socket-stream sock)))
(make-thread
(lambda ()
(irc-listen-thread sock-stream)))))))
(defun start-ircd ()
(irc-listen *listen-host* *listen-port*))

31
ircd.lisp

@ -1,12 +1,11 @@
; An IRCd, or something like that.
(asdf:load-system :usocket)
(asdf:load-system :bordeaux-threads)
(defpackage :nea/ircd
(:use :common-lisp
:usocket
:bordeaux-threads
:nea/utils
:nea/irc
:nea/irc-parser))
(in-package :nea/ircd)
@ -23,27 +22,23 @@
:initarg socket-reader-lock)
(socket-writer-lock
:initarg socket-writer-lock)))
(defgeneric read-irc-message (from))
(defgeneric write-irc-message (msg out))
(defun strip-ws (str)
(string-trim '(#\Space #\Tab #\Return #\Linefeed) str))
(defgeneric irc-client-read-message (client))
(defmethod read-irc-message ((st stream))
(irc-message-parse (strip-ws (read-line st))))
(defmethod irc-client-read-message ((client irc-client))
(irc-message-parse (strip-ws (read-line (slot-value client 'socket)))))
(defmethod write-irc-message ((msg irc-message) (st stream))
(irc-message-serialize msg st)
(write-char #\return st)
(write-char #\linefeed st))
(defmethod irc-client-read-message :before ((client irc-client))
(acquire-lock (slot-value client 'socket-reader-lock)))
(defmethod irc-client-read-message :after ((client irc-client))
(release-lock (slot-value client 'socket-reader-lock)))
(defgeneric irc-client-read-message (client))
(defun irc-listen-thread (sock)
(loop do (let* ((input (strip-ws (read-line sock)))
(parsed (irc-message-parse input)))
(loop do (let ((parsed (read-irc-message sock)))
(describe parsed sock)
(irc-message-serialize parsed sock)
(format sock "~%")
(write-irc-message parsed sock)
(force-output sock))))
(defun irc-listen (host port)

6
nea.asd

@ -2,5 +2,7 @@
:depends-on ("usocket" "bordeaux-threads")
:components
((:file "paxos")
(:file "irc")
(:file "ircd" :depends-on ("irc"))))
(:file "utils")
(:file "irc-message")
(:file "irc" :depends-on ("utils" "irc-message"))
(:file "ircd" :depends-on ("irc" "irc-message" "utils"))))

5
paxos.lisp

@ -1,5 +1,10 @@
; Attempt at a Paxos implementation in Common Lisp (!)
(defpackage :nea/paxos
(:use :common-lisp))
(in-package :nea/paxos)
(defvar *outbox* nil
"Name of the outbox to be used for outgoing Paxos messages.")

5
test-ircd.lisp

@ -1,7 +1,4 @@
(ql:quickload :bordeaux-threads)
(ql:quickload :usocket)
(load "irc.cl")
(load "ircd.cl")
(asdf:load-system "nea")
(in-package :nea/ircd)
(sb-thread:release-foreground)
(start-ircd)

43
utils.lisp

@ -0,0 +1,43 @@
; Common utility functions.
(defpackage :nea/utils
(:use common-lisp)
(:export split-string-at
split-string-at-first
starts-with
string-empty-p
strip-ws))
(in-package :nea/utils)
(defun split-string-at (str pos &optional (consume-value-at-pos-p nil))
"Splits STR at POS, returning two values. If CONSUME-VALUE-AT-POS-P is truthy, throws away the character at POS."
(declare (type string str) (type fixnum pos))
(cond
((> pos (length str)) (error "Position is outside string."))
((eql pos (length str)) (values str ""))
(t (values (subseq str 0 pos) (subseq str (+ pos (if consume-value-at-pos-p 1 0)))))))
(defun split-string-at-first (str char &optional (consume-value-at-pos-p nil))
"Splits STR at the first instance of CHAR, otherwise behaving like SPLIT-STRING-AT. If no CHAR is found, returns the input string and an empty string."
(declare (type string str) (type character char))
(let ((pos (position char str)))
(if pos
(split-string-at str pos consume-value-at-pos-p)
(values str ""))))
(defun starts-with (thing seq)
"Returns T if SEQ starts with THING."
(if (and seq (> (length seq) 0))
(eql (elt seq 0) thing)
nil))
(defun string-empty-p (str)
"Returns T if str is of length 0 or is NIL, NIL otherwise."
(if str
(eql (length str) 0)
nil))
(defun strip-ws (str)
"Strips leading and trailing whitespace from STR."
(string-trim '(#\Space #\Tab #\Return #\Linefeed) str))
Loading…
Cancel
Save