File: parse-message.lisp

package info (click to toggle)
cl-irc 1:0.9.2+dfsg1-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 3,124 kB
  • sloc: lisp: 4,495; makefile: 45
file content (237 lines) | stat: -rw-r--r-- 10,048 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
;;;; $Id: parse-message.lisp 241 2013-01-27 15:58:21Z jdanjou $
;;;; $URL: file:///project/cl-irc/svn/tags/0.9.2/parse-message.lisp $

;;;; See the LICENSE file for licensing information.

(in-package :irc)

(defun find-reply-name (reply-number &key (reply-names *reply-names*))
  "Numeric replies in the IRC RFCs have more meaningful names.  Given
a numeric reply (`reply-number') this function will either return the
symbol representing the reply or raise a continuable error
(`no-such-reply') which gives you the opportunity to ignore the
situation."
  (let ((name (assoc reply-number reply-names)))
    (when name
      (cadr name))))

(defun return-source (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
source part of the message.  Returns nil if the source part is not
present."
  (cut-between string #\: '(#\! #\Space) :start start))

(defun return-user (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
user part of the message.  Returns nil if the user part is not
present."
  (cut-between string #\! '(#\@ #\Space) :start start))

(defun return-host (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
host part of the message.  Returns nil if the host part is not
present."
  (cut-between string #\@ '(#\Space) :start start))

(defun return-command (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
command part of the message.  Returns nil if the command part is not
present."
  (if (eql (char string start) #\Space)
      (cut-between string #\Space '(#\Space) :start start)
      (cut-between string nil '(#\Space) :start start :cut-extra nil)))

(defun return-arguments (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
arguments part of the message as a list.  Returns nil if the arguments
part is not present."
  (multiple-value-bind (end-position return-argument)
      (cut-before string " :" '(#\Return) :start start :cut-to-end t)
    (values end-position (tokenize-string return-argument
                                          :delimiters '(#\Space)))))

(defun return-trailing-argument (string &key (start 0))
  "Assuming `string' is a valid IRC message this function returns the
trailing-argument part of the message.  Returns nil if the
trailing-argument part is not present."
  (when (< start (length string))
    (cut-between string #\: '(#\Return) :start start :cut-to-end t)))

(defun combine-arguments-and-trailing (string &key (start 0))
  (multiple-value-bind
      (start return-string)
      (return-arguments string :start start)
    (multiple-value-bind
        (return-index trailing)
        (return-trailing-argument string :start start)
      (values return-index
              (append return-string (when (and trailing (string/= "" trailing))
                                      (list trailing)))))))

(defun parse-raw-message (string &key (start 0))
  "Assuming `string' is a valid IRC message, parse the message and
return the values in the following order:

  - source
  - user
  - host
  - command
  - arguments
  - trailing-argument

Any values not present will be represented as nil."
  (let ((index start)
        (returns nil))
    (dolist (function '(return-source
                        return-user
                        return-host
                        return-command
                        combine-arguments-and-trailing))
      (multiple-value-bind (return-index return-string)
          (funcall function string :start index)
        (setf index return-index)
        (push return-string returns)))
    (apply #'values (reverse returns))))

(defun irc-error-reply-p (string)
  "Returns t if `string' is a string-representation of an IRC error
reply message, nil otherwise."
  (unless (zerop (length string))
    (if (and (every #'digit-char-p string)
             (member (char string 0) '(#\4 #\5)))
        t
        nil)))

(defun numeric-reply-p (string)
  "Returns t if `string' is a string-representation of an IRC number
reply, nil otherwise."
  (every #'digit-char-p string))

(defun ctcp-type-p (string type)
  "Is the `string' actually a representation of the CTCP `type'?"
  (if (string-equal (substring string 1 (min (length string)
                                             (1+ (length (symbol-name type)))))
                    type)
      type
      nil))

(defun dcc-type-p (string type)
  "Is the `string' actually a representation of the DCC `type'?"
  (let* ((args (tokenize-string (string-trim (list +soh+) string)))
         (dcc (string-upcase (first args)))
         (sess-type (string-upcase (second args))))
    (when (string= dcc "DCC")
      (let ((r
             ;; the list below was found on Wikipedia and in kvirc docs
             (second (assoc sess-type '(("CHAT" :dcc-chat-request)
                                        ("SEND" :dcc-send-request)
                                        ("XMIT" :dcc-xmit-request)
                                        ("SCHAT" :dcc-schat-request)
                                        ("SSEND" :dcc-ssend-request)
                                        ("REVERSE" :dcc-reverse-request)
                                        ("RSEND" :dcc-rsend-request)
                                        ("TSEND" :dcc-tsend-request)
                                        ("STSEND" :dcc-stsend-request)
                                        ("TSSEND" :dcc-stsend-request)
                                        ("RESUME" :dcc-resume-request)
                                        ("ACCEPT" :dcc-accept-request)
                                        ;; GET
                                        ;; TGET
                                        ;; STGET
                                        ;; TSGET
                                        ;; RECV
                                        ;; SRECV
                                        ;; TRECV
                                        ;; STRECV
                                        ;; TSRECV
                                        ;; RSEND
                                        ;; SRSEND
                                        ;; TRSEND
                                        ;; STRSEND
                                        ;; TSRSEND
                                        ;; VOICE
                                        ) :test #'string=))))
        (when (eq r type)
          type)))))

(defun ctcp-message-type (string)
  "If `string' is a CTCP message, return the type of the message or
nil if this is a) not a CTCP message or b) a CTCP message we don't
know about."
  (if (or (not (stringp string))
          (zerop (length string))
          (not (eql (char string 0) +soh+)))
      nil
      (case (char string 1)
        (#\A (ctcp-type-p string :action))
        (#\C (ctcp-type-p string :clientinfo))
        (#\D
         (or (dcc-type-p string :dcc-chat-request)
             (dcc-type-p string :dcc-send-request)))
        (#\F (ctcp-type-p string :finger))
        (#\P (ctcp-type-p string :ping))
        (#\S (ctcp-type-p string :source))
        (#\T (ctcp-type-p string :time))
        (#\U (ctcp-type-p string :userinfo))
        (#\V (ctcp-type-p string :version))
        (otherwise nil))))

(defun create-irc-message (string)
  "If `string' is a valid IRC message parse it and return an object of
the correct type with its slots prefilled according to the information
in the message."
  (multiple-value-bind (source user host command arguments)
      (parse-raw-message string)
    (let* ((class 'irc-message)
           (trailing-argument (car (last arguments)))
           (ctcp (ctcp-message-type trailing-argument)))
      (when command
        (cond
          ;;((irc-error-reply-p command)
           ;; Disable for now, as it prevents adding hooks for some useful
           ;; error types
           ;;(progn
           ;;  (setf command (find-reply-name (parse-integer command)))
           ;;  (setf class 'irc-error-reply)))
          ((numeric-reply-p command)
           (let* ((reply-number (parse-integer command))
                  (reply-name (find-reply-name reply-number)))
             (unless reply-name
               (error "Ignore unknown reply."
                      'no-such-reply :reply-number reply-number))
             (setf command reply-name)
             (setf class (find-irc-message-class command))))
          (t
           (setf command (intern (string-upcase command)
                                 (find-package :keyword)))
           (setf class (find-irc-message-class command)))))
      (when ctcp
        (setf class (find-ctcp-message-class ctcp)))
      (let ((instance (make-instance class
                                     :source (or source "")
                                     :user (or user "")
                                     :host (or host "")
                                     :command (if command
                                                  (string command)
                                                  "")
                                     :arguments arguments
                                     :connection nil
                                     :received-time (get-universal-time)
                                     :raw-message-string (or string ""))))
        (when ctcp
          (setf (ctcp-command instance) ctcp))
        instance))))

(defun create-dcc-message (string)
  (let* ((class 'dcc-privmsg-message)
         (ctcp (ctcp-message-type string)))
    (when ctcp
      (setf class (find-dcc-ctcp-message-class ctcp)))
    (let ((instance (make-instance class
                                   :arguments (list string)
                                   :connection nil
                                   :received-time (get-universal-time)
                                   :raw-message-string string)))
      (when ctcp
        (setf (ctcp-command instance) ctcp))
      instance)))