parse-message.lisp 1 ;;;; $Id: parse-message.lisp 241 2013-01-27 15:58:21Z jdanjou $
2 ;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/parse-message.lisp $
3
4 ;;;; See the LICENSE file for licensing information.
5
6 (in-package :irc)
7
8 (defun find-reply-name (reply-number &key (reply-names *reply-names*))
9 "Numeric replies in the IRC RFCs have more meaningful names. Given
10 a numeric reply (`reply-number') this function will either return the
11 symbol representing the reply or raise a continuable error
12 (`no-such-reply') which gives you the opportunity to ignore the
13 situation."
14 (let ((name (assoc reply-number reply-names)))
15 (when name
16 (cadr name))))
17
18 (defun return-source (string &key (start 0))
19 "Assuming `string' is a valid IRC message this function returns the
20 source part of the message. Returns nil if the source part is not
21 present."
22 (cut-between string #\: '(#\! #\Space) :start start))
23
24 (defun return-user (string &key (start 0))
25 "Assuming `string' is a valid IRC message this function returns the
26 user part of the message. Returns nil if the user part is not
27 present."
28 (cut-between string #\! '(#\@ #\Space) :start start))
29
30 (defun return-host (string &key (start 0))
31 "Assuming `string' is a valid IRC message this function returns the
32 host part of the message. Returns nil if the host part is not
33 present."
34 (cut-between string #\@ '(#\Space) :start start))
35
36 (defun return-command (string &key (start 0))
37 "Assuming `string' is a valid IRC message this function returns the
38 command part of the message. Returns nil if the command part is not
39 present."
40 (if (eql (char string start) #\Space)
41 (cut-between string #\Space '(#\Space) :start start)
42 (cut-between string nil '(#\Space) :start start :cut-extra nil)))
43
44 (defun return-arguments (string &key (start 0))
45 "Assuming `string' is a valid IRC message this function returns the
46 arguments part of the message as a list. Returns nil if the arguments
47 part is not present."
48 (multiple-value-bind (end-position return-argument)
49 (cut-before string " :" '(#\Return) :start start :cut-to-end t)
50 (values end-position (tokenize-string return-argument
51 :delimiters '(#\Space)))))
52
53 (defun return-trailing-argument (string &key (start 0))
54 "Assuming `string' is a valid IRC message this function returns the
55 trailing-argument part of the message. Returns nil if the
56 trailing-argument part is not present."
57 (when (< start (length string))
58 (cut-between string #\: '(#\Return) :start start :cut-to-end t)))
59
60 (defun combine-arguments-and-trailing (string &key (start 0))
61 (multiple-value-bind
62 (start return-string)
63 (return-arguments string :start start)
64 (multiple-value-bind
65 (return-index trailing)
66 (return-trailing-argument string :start start)
67 (values return-index
68 (append return-string (when (and trailing (string/= "" trailing))
69 (list trailing)))))))
70
71 (defun parse-raw-message (string &key (start 0))
72 "Assuming `string' is a valid IRC message, parse the message and
73 return the values in the following order:
74
75 - source
76 - user
77 - host
78 - command
79 - arguments
80 - trailing-argument
81
82 Any values not present will be represented as nil."
83 (let ((index start)
84 (returns nil))
85 (dolist (function '(return-source
86 return-user
87 return-host
88 return-command
89 combine-arguments-and-trailing))
90 (multiple-value-bind (return-index return-string)
91 (funcall function string :start index)
92 (setf index return-index)
93 (push return-string returns)))
94 (apply #'values (reverse returns))))
95
96 (defun irc-error-reply-p (string)
97 "Returns t if `string' is a string-representation of an IRC error
98 reply message, nil otherwise."
99 (unless (zerop (length string))
100 (if (and (every #'digit-char-p string)
101 (member (char string 0) '(#\4 #\5)))
102 t
103 nil)))
104
105 (defun numeric-reply-p (string)
106 "Returns t if `string' is a string-representation of an IRC number
107 reply, nil otherwise."
108 (every #'digit-char-p string))
109
110 (defun ctcp-type-p (string type)
111 "Is the `string' actually a representation of the CTCP `type'?"
112 (if (string-equal (substring string 1 (min (length string)
113 (1+ (length (symbol-name type)))))
114 type)
115 type
116 nil))
117
118 (defun dcc-type-p (string type)
119 "Is the `string' actually a representation of the DCC `type'?"
120 (let* ((args (tokenize-string (string-trim (list +soh+) string)))
121 (dcc (string-upcase (first args)))
122 (sess-type (string-upcase (second args))))
123 (when (string= dcc "DCC")
124 (let ((r
125 ;; the list below was found on Wikipedia and in kvirc docs
126 (second (assoc sess-type '(("CHAT" :dcc-chat-request)
127 ("SEND" :dcc-send-request)
128 ("XMIT" :dcc-xmit-request)
129 ("SCHAT" :dcc-schat-request)
130 ("SSEND" :dcc-ssend-request)
131 ("REVERSE" :dcc-reverse-request)
132 ("RSEND" :dcc-rsend-request)
133 ("TSEND" :dcc-tsend-request)
134 ("STSEND" :dcc-stsend-request)
135 ("TSSEND" :dcc-stsend-request)
136 ("RESUME" :dcc-resume-request)
137 ("ACCEPT" :dcc-accept-request)
138 ;; GET
139 ;; TGET
140 ;; STGET
141 ;; TSGET
142 ;; RECV
143 ;; SRECV
144 ;; TRECV
145 ;; STRECV
146 ;; TSRECV
147 ;; RSEND
148 ;; SRSEND
149 ;; TRSEND
150 ;; STRSEND
151 ;; TSRSEND
152 ;; VOICE
153 ) :test #'string=))))
154 (when (eq r type)
155 type)))))
156
157 (defun ctcp-message-type (string)
158 "If `string' is a CTCP message, return the type of the message or
159 nil if this is a) not a CTCP message or b) a CTCP message we don't
160 know about."
161 (if (or (not (stringp string))
162 (zerop (length string))
163 (not (eql (char string 0) +soh+)))
164 nil
165 (case (char string 1)
166 (#\A (ctcp-type-p string :action))
167 (#\C (ctcp-type-p string :clientinfo))
168 (#\D
169 (or (dcc-type-p string :dcc-chat-request)
170 (dcc-type-p string :dcc-send-request)))
171 (#\F (ctcp-type-p string :finger))
172 (#\P (ctcp-type-p string :ping))
173 (#\S (ctcp-type-p string :source))
174 (#\T (ctcp-type-p string :time))
175 (#\U (ctcp-type-p string :userinfo))
176 (#\V (ctcp-type-p string :version))
177 (otherwise nil))))
178
179 (defun create-irc-message (string)
180 "If `string' is a valid IRC message parse it and return an object of
181 the correct type with its slots prefilled according to the information
182 in the message."
183 (multiple-value-bind (source user host command arguments)
184 (parse-raw-message string)
185 (let* ((class 'irc-message)
186 (trailing-argument (car (last arguments)))
187 (ctcp (ctcp-message-type trailing-argument)))
188 (when command
189 (cond
190 ;;((irc-error-reply-p command)
191 ;; Disable for now, as it prevents adding hooks for some useful
192 ;; error types
193 ;;(progn
194 ;; (setf command (find-reply-name (parse-integer command)))
195 ;; (setf class 'irc-error-reply)))
196 ((numeric-reply-p command)
197 (let* ((reply-number (parse-integer command))
198 (reply-name (find-reply-name reply-number)))
199 (unless reply-name
200 (error "Ignore unknown reply."
201 'no-such-reply :reply-number reply-number))
202 (setf command reply-name)
203 (setf class (find-irc-message-class command))))
204 (t
205 (setf command (intern (string-upcase command)
206 (find-package :keyword)))
207 (setf class (find-irc-message-class command)))))
208 (when ctcp
209 (setf class (find-ctcp-message-class ctcp)))
210 (let ((instance (make-instance class
211 :source (or source "")
212 :user (or user "")
213 :host (or host "")
214 :command (if command
215 (string command)
216 "")
217 :arguments arguments
218 :connection nil
219 :received-time (get-universal-time)
220 :raw-message-string (or string ""))))
221 (when ctcp
222 (setf (ctcp-command instance) ctcp))
223 instance))))
224
225 (defun create-dcc-message (string)
226 (let* ((class 'dcc-privmsg-message)
227 (ctcp (ctcp-message-type string)))
228 (when ctcp
229 (setf class (find-dcc-ctcp-message-class ctcp)))
230 (let ((instance (make-instance class
231 :arguments (list string)
232 :connection nil
233 :received-time (get-universal-time)
234 :raw-message-string string)))
235 (when ctcp
236 (setf (ctcp-command instance) ctcp))
237 instance)))