source: project/release/4/irc/irc.scm @ 15663

Last change on this file since 15663 was 15663, checked in by felix winkelmann, 10 years ago

irc improvements (1.8)

File size: 10.5 KB
Line 
1;;;; irc.scm
2;
3; Copyright (c) 2000-2004, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Steinweg 1A
32; 37130 Gleichen, OT Weissenborn
33; Germany
34
35
36(module irc (irc:connect
37             irc:quit irc:nick irc:say irc:join irc:part irc:command irc:listen irc:action
38             irc:connection-in irc:connection-out irc:connection-server irc:connection-nick
39             irc:connection-user irc:connection-real-name irc:connection-port irc:connection
40             irc:connected? irc:connection-password irc:connection? irc:connection-channel
41             irc:message-prefix irc:message-command irc:message-timestamp irc:message-code
42             irc:message-body irc:message-parameters irc:message-index irc:disconnect
43             irc:extended-data? irc:extended-data-tag irc:extended-data-content
44             irc:message? irc:run-message-loop irc:process-message
45             irc:add-message-handler! irc:remove-message-handler!
46             irc:message-sender irc:message-receiver
47             irc:connection-raw-filter-set!
48             irc:wait irc:notice)
49  (import scheme chicken matchable)
50  (use tcp extras srfi-1 regex data-structures)
51
52(define-constant default-port 6667)
53(define-constant default-user "nobody")
54
55(define-record irc:connection
56  index-count                           ; int
57  password                              ; string | #f
58  server                                ; string
59  nick                                  ; string
60  user                                  ; string
61  real-name                             ; string
62  port                                  ; int
63  connected?                            ; bool
64  handlers                              ; (handler | (tag handler) ...)
65  channel                               ; string | #f
66  in                                    ; port
67  out                                   ; port
68  raw-filter)                           ; procedure | #f
69
70(define irc:connected? irc:connection-connected?)
71
72(define (irc:connection #!key password server (nick (gensym)) (user default-user) (real-name user)
73                        (port default-port) )
74  (make-irc:connection
75   0
76   password
77   (or server (error "no server specified"))
78   nick user real-name port
79   #f '() '() #f #f #f) )
80
81(define (send con fstr . args)
82  (let ([e (current-error-port)]
83        [msg (apply sprintf fstr args)] )
84    (unless (irc:connection-connected? con)
85      (error "not connected" con) )
86    (fprintf (irc:connection-out con) "~A\r\n" msg) ) )
87
88(define (irc:connect . args)
89  (let* ([con (and (pair? args) (car args))]
90         [con
91          (if (and con (irc:connection? con))
92              con
93              (apply irc:connection args) ) ] )
94    (parameterize ((tcp-read-timeout #f))
95      (let-values ([(i o)
96                    (tcp-connect (irc:connection-server con)
97                                 (irc:connection-port con) ) ] )
98        (irc:connection-in-set! con i)
99        (irc:connection-out-set! con o)
100        (irc:connection-connected?-set! con #t)
101        (and-let* ([pw (irc:connection-password con)])
102          (send con "PASS :~A" pw) )
103        (send con "USER ~A 0 * :~A" (irc:connection-user con) (irc:connection-real-name con))
104        (and-let* ([nick (irc:connection-nick con)])
105          (send con "NICK ~A" nick) )
106        con) ) ) )
107
108(define (irc:quit con . msg)
109  (send con "QUIT~A" (if (pair? msg) (sprintf " :~A" (car msg)) ""))
110  (close-output-port (irc:connection-out con))
111  (close-input-port (irc:connection-in con))
112  (irc:connection-connected?-set! con #f)
113  (irc:connection-in-set! con #f)
114  (irc:connection-out-set! con #f) )
115
116(define (irc:disconnect con)
117  (close-output-port (irc:connection-out con))
118  (close-input-port (irc:connection-in con))
119  (irc:connection-connected?-set! con #f)
120  (irc:connection-in-set! con #f)
121  (irc:connection-out-set! con #f) )
122
123(define (irc:join con channel)
124  (irc:connection-channel-set! con channel)
125  (send con "JOIN ~A" channel) )
126
127(define (irc:part con channel)
128  (send con "PART ~A" channel) )
129
130(define (irc:nick con nick)
131  (send con "NICK ~A" nick)
132  (irc:connection-nick-set! con nick) )
133
134(define (irc:command con cmd)
135  (send con cmd) )
136
137(define (send-message con msg-format msg dests)
138  (define (mess d ln)
139    (send con msg-format d ln))
140  (for-each (if (null? dests)
141                (cute mess (irc:connection-channel con) <>)
142                (lambda (ln)
143                  (for-each (cut mess <> ln) dests)))
144            (string-split
145             (if (irc:extended-data? msg)
146                 (ext->msg msg)
147                 msg)
148             "\n")))
149
150(define (irc:say con msg . dests)
151  (send-message con "PRIVMSG ~A :~A" msg dests))
152
153(define (irc:notice con msg . dests)
154  (send-message con "NOTICE ~A :~A" msg dests))
155
156(define (irc:listen con)
157  (unless (irc:connection-connected? con)
158    (error 'irc:listen "not connected" con) )
159  (let ([p (irc:connection-in con)])
160    (and (char-ready? p)
161         (parse-reply (read-line p) con) ) ) )
162
163(define-record irc:message
164  code                                  ; int | #f
165  index                                 ; int
166  timestamp                             ; int
167  body                                  ; string
168  prefix                                ; (string ...)
169  command                               ; string | #f
170  parameters)                           ; (string | extended-data ...)
171
172(define-record irc:extended-data
173  tag                                   ; symbol
174  content)                              ; string
175
176(define (ext-data tag content)
177  (sprintf "~A~A ~A~A" (integer->char 1) tag content (integer->char 1)) )
178
179(define (ext->msg ext)
180  (ext-data (irc:extended-data-tag ext) (irc:extended-data-content ext)) )
181
182(define extended-rx
183  (regexp (sprintf "~A(ACTION) (.+)~A" (integer->char 1) (integer->char 1))) )
184
185(define (irc:error msg)
186  (signal
187   (make-composite-condition
188    (make-property-condition 'exn 'message (irc:message-body msg))
189    (make-property-condition 'irc 'code (irc:message-code msg) 'reply msg) ) ) )
190
191(define-syntax rx
192  (syntax-rules ()
193    ((_ re) (force (delay (regexp re))))))
194
195(define (parse-params s)
196  (match (string-search-positions (rx ":(.+)") s)
197    [((start _) . _)
198     (let* ([s2 (substring s (add1 start) (string-length s))]
199            [px (match (string-match extended-rx s2)
200                  [(_ tag s3) (make-irc:extended-data (string->symbol tag) s3)]
201                  [_ s2] ) ] )
202       (append (parse-params (substring s 0 start)) (list px)) ) ]
203    [_ (string-split s)] ) )
204
205(define (parse-reply s con)
206  (when (eof-object? s) (error "eof - IRC connection terminated" con))
207  (let ([cnt (irc:connection-index-count con)]
208        [s ((or (irc:connection-raw-filter con) identity) s)] )
209    (irc:connection-index-count-set! con (add1 cnt))
210    (match (string-match (rx "(:[^ ]+ )?([A-Za-z0-9]+)(.*)") s)
211      [(_ prefix command params)
212       (let* ([prefix (if prefix
213                          (string-split (substring prefix 1 (string-length prefix)) "!@ ")
214                          '() ) ]
215              [params (parse-params params)]
216              [num (string->number command)]
217              [msg (make-irc:message
218                    num cnt
219                    (current-seconds)
220                    s prefix command params) ] )
221         (if (and num (>= 400 num 599))
222             (irc:error msg)
223             msg) ) ]
224      [_ (make-irc:message #f cnt (current-seconds) s '() #f '())] ) ) )
225
226(define (irc:wait con)
227  (unless (irc:connection-connected? con)
228    (error "not connected" con) )
229  (parse-reply (read-line (irc:connection-in con)) con) )
230
231(define (irc:action con msg . dest)
232  (apply irc:say con (sprintf "~AACTION ~A~A" (integer->char 1) msg (integer->char 1)) dest) )
233
234(define (irc:run-message-loop con #!key debug (pong #t) (filter identity))
235  (when (and pong (not (find (lambda (h) (and (pair? h) (eq? 'ping (car h)))) (irc:connection-handlers con))))
236    (irc:add-message-handler!
237     con
238     (lambda (msg)
239       (when debug
240         (print ">>> PING - PONG <<<"))
241       (irc:command con (string-append "PONG :" (car (irc:message-parameters msg)))) )
242     tag: 'ping
243     command: "PING") )
244  (let loop ()
245    (let ([msg (irc:wait con)])
246      (irc:process-message con (filter msg) debug)
247      (loop) ) ) )
248
249(define (irc:process-message con msg #!optional verbose?)
250  (let ([prefix (irc:message-prefix msg)]
251        [command (irc:message-command msg)]
252        [params (irc:message-parameters msg)] )
253    (when verbose?
254      (printf ">>> ~a <<<~%" (irc:message-body msg)) )
255    (any
256     (lambda (h) ((if (procedure? h) h (cdr h)) msg))
257     (irc:connection-handlers con)) ) )
258
259(define (irc:add-message-handler! con proc #!key command sender receiver body code tag)
260  (let ([h (lambda (msg)
261             (let ([prefix (irc:message-prefix msg)]
262                   [cmd (irc:message-command msg)]
263                   [params (irc:message-parameters msg)] )
264               (and (or (not command)
265                        (and cmd
266                             (if (procedure? command)
267                                 (command cmd)
268                                 (string-search command cmd))))
269                    (or (not sender)
270                        (and (pair? prefix)
271                             (if (procedure? prefix)
272                                 (sender (car prefix))
273                                 (string-search sender (car prefix)))))
274                    (or (not receiver)
275                        (and (pair? params)
276                             (if (procedure? receiver)
277                                 (receiver (car params)
278                                 (string-search receiver (car params))))))
279                    (or (not body)
280                        (if (procedure? body)
281                            (body msg)
282                            (string-search body (irc:message-body msg))))
283                    (or (not code) (eq? code (irc:message-code msg)))
284                    (proc msg) ) ) ) ] )
285    (irc:connection-handlers-set!
286     con
287     (append
288      (irc:connection-handlers con)
289      (list (if tag (cons tag h) h)) ) ) ) )
290
291(define (irc:remove-message-handler! con tag)
292  (irc:connection-handlers-set!
293   con
294   (let loop ([hs (irc:connection-handlers con)])
295     (cond [(null? hs) (error "undefined message handler" tag)]
296           [(and (pair? hs) (eq? tag (caar hs))) (cdr hs)]
297           [else (cons (car hs) (loop (cdr hs)))] ) ) ) )
298
299(define (irc:message-receiver msg)
300  (let ([params (irc:message-parameters msg)])
301    (and (pair? params) (car params)) ) )
302
303(define (irc:message-sender msg)
304  (let ([prefix (irc:message-prefix msg)])
305    (and (pair? prefix) (car prefix)) ) )
306
307)
Note: See TracBrowser for help on using the repository browser.