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.
 

189 lines
6.7 KiB

; This file maybe does IRC message stuff. Maybe.
(in-package :nea/irc)
; *** Parsing
(defun finalize (tags source args)
(let ((args (reverse args)))
(make-irc-message (car args) :tags tags :source source :params (cdr args))))
(defun parse-source (src)
(multiple-value-bind (nick-user host)
(split-string-at-first src #\@ t)
(if (string-empty-p host)
(make-irc-message-source src)
(multiple-value-bind (nick user)
(split-string-at-first nick-user #\! t)
(if (string-empty-p user)
(make-irc-message-source host :nick nick-user)
(make-irc-message-source host :nick nick :user user))))))
(defun parse-tag-value (accum value)
(if (string-empty-p value)
accum
(if (and (eql (elt value 0) #\\) (eql (length value) 1))
accum
(if (starts-with #\\ value)
(let ((next-elt (elt value 1)))
(format t "~s~%" next-elt)
(vector-push-extend (cond
((eq next-elt #\:) #\;)
((eq next-elt #\s) #\Space)
((eq next-elt #\r) #\return)
((eq next-elt #\n) #\linefeed)
(t next-elt))
accum)
(parse-tag-value accum (subseq value 2)))
(progn
(vector-push-extend (elt value 0) accum)
(parse-tag-value accum (subseq value 1)))))))
(defun parse-tag (tag)
(multiple-value-bind (key value)
(split-string-at-first tag #\= t)
(if (string-empty-p value)
(cons key nil)
(cons key (parse-tag-value
(make-array (length value)
:element-type 'character
:fill-pointer 0
:adjustable t)
value)))))
(defun parse-tags (tags left)
(multiple-value-bind (first-tag others)
(split-string-at-first left #\; t)
(let ((parsed-tag (parse-tag first-tag)))
(if (string-empty-p others)
(cons parsed-tag tags)
(parse-tags (cons parsed-tag tags) others)))))
(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)
(finalize tags source (if trailing
(cons trailing (cons word args))
(cons word args)))
(slurp-args tags source (cons word args) trailing remaining))))
(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 t)
;; The : has to have a space before it to be a valid trailing bit.
;; The first `if' checks whether it's something else; if it is, we continue as if we never did the split.
(if (and (not (string-empty-p args-bit))
(not (equal (elt args-bit (1- (length args-bit))) #\Space)))
(slurp-args tags source args nil msg)
(if (string-empty-p trailing-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)
(finalize tags source (cons first-word args))
(cond
((starts-with #\@ first-word)
(parse-inner (parse-tags nil (subseq first-word 1)) tags args remaining))
((starts-with #\: first-word)
(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."
(parse-inner nil nil nil msg))
; *** Serializing
(defun serialize-irc-message-source (src &optional out)
(with-slots ((nick nick) (user user) (host host)) src
(cond
((and nick user host) (format out "~A!~A@~A" nick user host))
((and nick host) (format out "~A@~A" nick host))
((and user host) (format out "~A@~A" user host))
(host (format out "~A" host))
(t nil))))
(defun serialize-source (source out)
(when source
(write-char #\: out)
(serialize-irc-message-source source out)
(write-char #\Space out)))
(defun serialize-args (args out)
(format out "~{~A~^ ~} " args))
(defun serialize-trailing (trailing out)
(when trailing
(write-char #\: out)
(write-sequence trailing out)))
(defun serialize-tag-value (value out)
(loop for char across value
do (let ((special-sequence
(cond
((eq char #\Space) "\\s")
((eq char #\;) "\\:")
((eq char #\return) "\\r")
((eq char #\linefeed) "\\n")
(t nil))))
(if special-sequence
(write-sequence special-sequence out)
(write-char char out)))))
(defun serialize-tags (tags out)
(when tags
(dolist (tagpair tags)
(serialize-tag-value (car tagpair) out)
(when (cdr tagpair)
(write-char #\= out)
(serialize-tag-value (cdr tagpair) out)))))
(defgeneric irc-message-serialize-end (src out))
(defmethod irc-message-serialize-end ((src irc-message) out)
(with-slots ((args parameters)) src
; FIXME: using butlast and last seems inefficient
(when (> (length args) 1)
(serialize-args (butlast args) out))
(serialize-trailing (car (last args)) out)))
(defmethod irc-message-serialize-end ((src irc-message-notrailing) out)
(with-slots ((args parameters)) src
(assert (<= (length args) 1) () "Invalid number of arguments for a NOTRAILING IRC message class.")
(serialize-args args out)))
(defun serialize-tags-to-string (tags)
"Serializes TAGS (an alist of message tags) to a string, returning this string."
(let ((out (make-string-output-stream)))
(serialize-tags tags out)
(get-output-stream-string out)))
(defun irc-message-serialize (src out)
(with-slots ((tags tags) (source source) (command command) (args parameters)) src
(when tags
(write-char #\@ out)
(serialize-tags tags out)
(write-char #\Space out))
(serialize-source source out)
(write-sequence command out)
(when (> (length args) 0)
(write-char #\Space out))
(irc-message-serialize-end src out)))
; Stream ops
(defgeneric read-irc-message (from))
(defgeneric write-irc-message (msg out))
(defmethod read-irc-message ((st stream))
(irc-message-parse (strip-ws (read-line st))))
(defmethod write-irc-message ((msg irc-message) (st stream))
(irc-message-serialize msg st)
(write-char #\return st)
(write-char #\linefeed st))