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

  1. ; This file maybe does IRC message stuff. Maybe.
  2. (in-package :nea/irc)
  3. ; *** Parsing
  4. (defun finalize (tags source args)
  5. (let ((args (reverse args)))
  6. (make-irc-message (car args) :tags tags :source source :params (cdr args))))
  7. (defun parse-source (src)
  8. (multiple-value-bind (nick-user host)
  9. (split-string-at-first src #\@ t)
  10. (if (string-empty-p host)
  11. (make-irc-message-source src)
  12. (multiple-value-bind (nick user)
  13. (split-string-at-first nick-user #\! t)
  14. (if (string-empty-p user)
  15. (make-irc-message-source host :nick nick-user)
  16. (make-irc-message-source host :nick nick :user user))))))
  17. (defun parse-tag-value (accum value)
  18. (if (string-empty-p value)
  19. accum
  20. (if (and (eql (elt value 0) #\\) (eql (length value) 1))
  21. accum
  22. (if (starts-with #\\ value)
  23. (let ((next-elt (elt value 1)))
  24. (format t "~s~%" next-elt)
  25. (vector-push-extend (cond
  26. ((eq next-elt #\:) #\;)
  27. ((eq next-elt #\s) #\Space)
  28. ((eq next-elt #\r) #\return)
  29. ((eq next-elt #\n) #\linefeed)
  30. (t next-elt))
  31. accum)
  32. (parse-tag-value accum (subseq value 2)))
  33. (progn
  34. (vector-push-extend (elt value 0) accum)
  35. (parse-tag-value accum (subseq value 1)))))))
  36. (defun parse-tag (tag)
  37. (multiple-value-bind (key value)
  38. (split-string-at-first tag #\= t)
  39. (if (string-empty-p value)
  40. (cons key nil)
  41. (cons key (parse-tag-value
  42. (make-array (length value)
  43. :element-type 'character
  44. :fill-pointer 0
  45. :adjustable t)
  46. value)))))
  47. (defun parse-tags (tags left)
  48. (multiple-value-bind (first-tag others)
  49. (split-string-at-first left #\; t)
  50. (let ((parsed-tag (parse-tag first-tag)))
  51. (if (string-empty-p others)
  52. (cons parsed-tag tags)
  53. (parse-tags (cons parsed-tag tags) others)))))
  54. (defun slurp-args (tags source args trailing msg)
  55. (multiple-value-bind (word remaining)
  56. (split-string-at-first msg #\Space t)
  57. (if (string-empty-p remaining)
  58. (finalize tags source (if trailing
  59. (cons trailing (cons word args))
  60. (cons word args)))
  61. (slurp-args tags source (cons word args) trailing remaining))))
  62. (defun parse-inner (tags source args msg)
  63. (if (or (and tags source) source args)
  64. (multiple-value-bind (args-bit trailing-bit)
  65. (split-string-at-first msg #\: t t)
  66. ;; The : has to have a space before it to be a valid trailing bit.
  67. ;; The first `if' checks whether it's something else; if it is, we continue as if we never did the split.
  68. (if (and (not (string-empty-p args-bit))
  69. (not (equal (elt args-bit (1- (length args-bit))) #\Space)))
  70. (slurp-args tags source args nil msg)
  71. (if (string-empty-p trailing-bit)
  72. (slurp-args tags source args nil args-bit)
  73. (slurp-args tags source args trailing-bit args-bit))))
  74. (multiple-value-bind (first-word remaining)
  75. (split-string-at-first msg #\Space t)
  76. (if (string-empty-p remaining)
  77. (finalize tags source (cons first-word args))
  78. (cond
  79. ((starts-with #\@ first-word)
  80. (parse-inner (parse-tags nil (subseq first-word 1)) tags args remaining))
  81. ((starts-with #\: first-word)
  82. (parse-inner tags (parse-source (subseq first-word 1)) args remaining))
  83. (t (parse-inner tags source (cons first-word args) remaining)))))))
  84. (defun irc-message-parse (msg)
  85. "Parses the IRC message stored in MSG, and returns an IRC-MESSAGE object."
  86. (parse-inner nil nil nil msg))
  87. ; *** Serializing
  88. (defun serialize-irc-message-source (src &optional out)
  89. (with-slots ((nick nick) (user user) (host host)) src
  90. (cond
  91. ((and nick user host) (format out "~A!~A@~A" nick user host))
  92. ((and nick host) (format out "~A@~A" nick host))
  93. ((and user host) (format out "~A@~A" user host))
  94. (host (format out "~A" host))
  95. (t nil))))
  96. (defun serialize-source (source out)
  97. (when source
  98. (write-char #\: out)
  99. (serialize-irc-message-source source out)
  100. (write-char #\Space out)))
  101. (defun serialize-args (args out)
  102. (format out "~{~A~^ ~} " args))
  103. (defun serialize-trailing (trailing out)
  104. (when trailing
  105. (write-char #\: out)
  106. (write-sequence trailing out)))
  107. (defun serialize-tag-value (value out)
  108. (loop for char across value
  109. do (let ((special-sequence
  110. (cond
  111. ((eq char #\Space) "\\s")
  112. ((eq char #\;) "\\:")
  113. ((eq char #\return) "\\r")
  114. ((eq char #\linefeed) "\\n")
  115. (t nil))))
  116. (if special-sequence
  117. (write-sequence special-sequence out)
  118. (write-char char out)))))
  119. (defun serialize-tags (tags out)
  120. (when tags
  121. (dolist (tagpair tags)
  122. (serialize-tag-value (car tagpair) out)
  123. (when (cdr tagpair)
  124. (write-char #\= out)
  125. (serialize-tag-value (cdr tagpair) out)))))
  126. (defgeneric irc-message-serialize-end (src out))
  127. (defmethod irc-message-serialize-end ((src irc-message) out)
  128. (with-slots ((args parameters)) src
  129. ; FIXME: using butlast and last seems inefficient
  130. (when (> (length args) 1)
  131. (serialize-args (butlast args) out))
  132. (serialize-trailing (car (last args)) out)))
  133. (defmethod irc-message-serialize-end ((src irc-message-notrailing) out)
  134. (with-slots ((args parameters)) src
  135. (assert (<= (length args) 1) () "Invalid number of arguments for a NOTRAILING IRC message class.")
  136. (serialize-args args out)))
  137. (defun serialize-tags-to-string (tags)
  138. "Serializes TAGS (an alist of message tags) to a string, returning this string."
  139. (let ((out (make-string-output-stream)))
  140. (serialize-tags tags out)
  141. (get-output-stream-string out)))
  142. (defun irc-message-serialize (src out)
  143. (with-slots ((tags tags) (source source) (command command) (args parameters)) src
  144. (when tags
  145. (write-char #\@ out)
  146. (serialize-tags tags out)
  147. (write-char #\Space out))
  148. (serialize-source source out)
  149. (write-sequence command out)
  150. (when (> (length args) 0)
  151. (write-char #\Space out))
  152. (irc-message-serialize-end src out)))
  153. ; Stream ops
  154. (defgeneric read-irc-message (from))
  155. (defgeneric write-irc-message (msg out))
  156. (defmethod read-irc-message ((st stream))
  157. (irc-message-parse (strip-ws (read-line st))))
  158. (defmethod write-irc-message ((msg irc-message) (st stream))
  159. (irc-message-serialize msg st)
  160. (write-char #\return st)
  161. (write-char #\linefeed st))