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

Last change on this file since 16431 was 16431, checked in by felix winkelmann, 11 years ago

sends server PING, allows to specify logfile

File size: 11.1 KB
Line 
1;;;; irc.scm
2;
3; Copyright (c) 2000-2009, 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:connection-log-traffic
41             irc:connected? irc:connection-password irc:connection? irc:connection-channel
42             irc:message-prefix irc:message-command irc:message-timestamp irc:message-code
43             irc:message-body irc:message-parameters irc:message-index irc:disconnect
44             irc:extended-data? irc:extended-data-tag irc:extended-data-content
45             irc:message? irc:run-message-loop irc:process-message
46             irc:add-message-handler! irc:remove-message-handler!
47             irc:message-sender irc:message-receiver
48             irc:connection-raw-filter-set!
49             irc:wait irc:notice)
50  (import scheme chicken matchable)
51  (use tcp extras srfi-1 regex data-structures posix)
52
53(define-constant default-port 6667)
54(define-constant default-user "nobody")
55(define-constant default-server-ping-timeout 3600000) ; 1 hour
56
57(define-record irc:connection
58  index-count                           ; int
59  password                              ; string | #f
60  server                                ; string
61  nick                                  ; string
62  user                                  ; string
63  real-name                             ; string
64  port                                  ; int
65  ping-timeout                          ; ms
66  log-traffic                           ; port | #f
67  connected?                            ; bool
68  handlers                              ; (handler | (tag handler) ...)
69  channel                               ; string | #f
70  in                                    ; port
71  out                                   ; port
72  raw-filter)                           ; procedure | #f
73
74(define irc:connected? irc:connection-connected?)
75
76(define (irc:connection #!key password server (nick (gensym)) (user default-user) (real-name user)
77                        (port default-port) (ping-timeout default-server-ping-timeout)
78                        log-traffic)
79  (make-irc:connection
80   0
81   password
82   (or server (error "no server specified"))
83   nick user real-name port ping-timeout log-traffic
84   #f '() '() #f #f #f) )
85
86(define (send con fstr . args)
87  (let ((msg (apply sprintf fstr args)))
88    (unless (irc:connection-connected? con)
89      (error "not connected" con) )
90    (fprintf (irc:connection-out con) "~A\r\n" msg) 
91    (and-let* ((log (irc:connection-log-traffic con)))
92      (fprintf log "~a > ~a~%~!" (seconds->string (current-seconds)) msg) ) ) )
93
94(define (irc:connect . args)
95  (let* ([con (and (pair? args) (car args))]
96         [con
97          (if (and con (irc:connection? con))
98              con
99              (apply irc:connection args) ) ] )
100    (parameterize ((tcp-read-timeout (irc:connection-ping-timeout con)))
101      (let-values ([(i o)
102                    (tcp-connect (irc:connection-server con)
103                                 (irc:connection-port con) ) ] )
104        (irc:connection-in-set! con i)
105        (irc:connection-out-set! con o)
106        (irc:connection-connected?-set! con #t)
107        (and-let* ([pw (irc:connection-password con)])
108          (send con "PASS :~A" pw) )
109        (send con "USER ~A 0 * :~A" (irc:connection-user con) (irc:connection-real-name con))
110        (and-let* ([nick (irc:connection-nick con)])
111          (send con "NICK ~A" nick) )
112        con) ) ) )
113
114(define (irc:quit con . msg)
115  (send con "QUIT~A" (if (pair? msg) (sprintf " :~A" (car msg)) ""))
116  (close-output-port (irc:connection-out con))
117  (close-input-port (irc:connection-in con))
118  (irc:connection-connected?-set! con #f)
119  (irc:connection-in-set! con #f)
120  (irc:connection-out-set! con #f) )
121
122(define (irc:disconnect con)
123  (close-output-port (irc:connection-out con))
124  (close-input-port (irc:connection-in con))
125  (irc:connection-connected?-set! con #f)
126  (irc:connection-in-set! con #f)
127  (irc:connection-out-set! con #f) )
128
129(define (irc:join con channel)
130  (irc:connection-channel-set! con channel)
131  (send con "JOIN ~A" channel) )
132
133(define (irc:part con channel)
134  (send con "PART ~A" channel) )
135
136(define (irc:nick con nick)
137  (send con "NICK ~A" nick)
138  (irc:connection-nick-set! con nick) )
139
140(define (irc:command con cmd)
141  (send con cmd) )
142
143(define (send-message con msg-format msg dests)
144  (define (mess d ln)
145    (send con msg-format d ln))
146  (for-each (if (null? dests)
147                (cute mess (irc:connection-channel con) <>)
148                (lambda (ln)
149                  (for-each (cut mess <> ln) dests)))
150            (string-split
151             (if (irc:extended-data? msg)
152                 (ext->msg msg)
153                 msg)
154             "\n")))
155
156(define (irc:say con msg . dests)
157  (send-message con "PRIVMSG ~A :~A" msg dests))
158
159(define (irc:notice con msg . dests)
160  (send-message con "NOTICE ~A :~A" msg dests))
161
162(define (irc:listen con)
163  (unless (irc:connection-connected? con)
164    (error 'irc:listen "not connected" con) )
165  (let ([p (irc:connection-in con)])
166    (and (char-ready? p)
167         (parse-reply (read-input con) con) ) ) )
168
169(define (read-input con)
170  (let ((input (read-line (irc:connection-in con))))
171    (and-let* ((log (irc:connection-log-traffic con)))
172      (fprintf log "~a < ~a~%~!" (seconds->string (current-seconds)) input) )
173    input))
174
175(define-record irc:message
176  code                                  ; int | #f
177  index                                 ; int
178  timestamp                             ; int
179  body                                  ; string
180  prefix                                ; (string ...)
181  command                               ; string | #f
182  parameters)                           ; (string | extended-data ...)
183
184(define-record irc:extended-data
185  tag                                   ; symbol
186  content)                              ; string
187
188(define (ext-data tag content)
189  (sprintf "~A~A ~A~A" (integer->char 1) tag content (integer->char 1)) )
190
191(define (ext->msg ext)
192  (ext-data (irc:extended-data-tag ext) (irc:extended-data-content ext)) )
193
194(define extended-rx
195  (regexp (sprintf "~A(ACTION) (.+)~A" (integer->char 1) (integer->char 1))) )
196
197(define (irc:error msg)
198  (signal
199   (make-composite-condition
200    (make-property-condition 'exn 'message (irc:message-body msg))
201    (make-property-condition 'irc 'code (irc:message-code msg) 'reply msg) ) ) )
202
203(define-syntax rx
204  (syntax-rules ()
205    ((_ re) (force (delay (regexp re))))))
206
207(define (parse-params s)
208  (match (string-search-positions (rx ":(.+)") s)
209    [((start _) . _)
210     (let* ([s2 (substring s (add1 start) (string-length s))]
211            [px (match (string-match extended-rx s2)
212                  [(_ tag s3) (make-irc:extended-data (string->symbol tag) s3)]
213                  [_ s2] ) ] )
214       (append (parse-params (substring s 0 start)) (list px)) ) ]
215    [_ (string-split s)] ) )
216
217(define (parse-reply s con)
218  (when (eof-object? s) (error "eof - IRC connection terminated" con))
219  (let ([cnt (irc:connection-index-count con)]
220        [s ((or (irc:connection-raw-filter con) identity) s)] )
221    (irc:connection-index-count-set! con (add1 cnt))
222    (match (string-match (rx "(:[^ ]+ )?([A-Za-z0-9]+)(.*)") s)
223      [(_ prefix command params)
224       (let* ([prefix (if prefix
225                          (string-split (substring prefix 1 (string-length prefix)) "!@ ")
226                          '() ) ]
227              [params (parse-params params)]
228              [num (string->number command)]
229              [msg (make-irc:message
230                    num cnt
231                    (current-seconds)
232                    s prefix command params) ] )
233         (if (and num (>= 400 num 599))
234             (irc:error msg)
235             msg) ) ]
236      [_ (make-irc:message #f cnt (current-seconds) s '() #f '())] ) ) )
237
238(define (irc:wait con)
239  (unless (irc:connection-connected? con)
240    (error "not connected" con) )
241  (parse-reply
242   (let loop ()
243     (or (condition-case (read-input con)
244           (ex (exn net timeout)
245               (send con "PING ~a" (irc:connection-server con))
246               #f) )
247         (loop)))
248   con))
249
250(define (irc:action con msg . dest)
251  (apply irc:say con (sprintf "~AACTION ~A~A" (integer->char 1) msg (integer->char 1)) dest) )
252
253(define (irc:run-message-loop con #!key debug (pong #t) (filter identity))
254  (when (and pong (not (find (lambda (h) (and (pair? h) (eq? 'ping (car h)))) (irc:connection-handlers con))))
255    (irc:add-message-handler!
256     con
257     (lambda (msg)
258       (irc:command con (string-append "PONG :" (car (irc:message-parameters msg)))) )
259     tag: 'ping
260     command: "PING") )
261  (let loop ()
262    (let ([msg (irc:wait con)])
263      (irc:process-message con (filter msg) debug)
264      (loop) ) ) )
265
266(define (irc:process-message con msg #!optional verbose?)
267  (let ([prefix (irc:message-prefix msg)]
268        [command (irc:message-command msg)]
269        [params (irc:message-parameters msg)] )
270    (any
271     (lambda (h) ((if (procedure? h) h (cdr h)) msg))
272     (irc:connection-handlers con)) ) )
273
274(define (irc:add-message-handler! con proc #!key command sender receiver body code tag)
275  (let ([h (lambda (msg)
276             (let ([prefix (irc:message-prefix msg)]
277                   [cmd (irc:message-command msg)]
278                   [params (irc:message-parameters msg)] )
279               (and (or (not command)
280                        (and cmd
281                             (if (procedure? command)
282                                 (command cmd)
283                                 (string-search command cmd))))
284                    (or (not sender)
285                        (and (pair? prefix)
286                             (if (procedure? prefix)
287                                 (sender (car prefix))
288                                 (string-search sender (car prefix)))))
289                    (or (not receiver)
290                        (and (pair? params)
291                             (if (procedure? receiver)
292                                 (receiver (car params)
293                                 (string-search receiver (car params))))))
294                    (or (not body)
295                        (if (procedure? body)
296                            (body msg)
297                            (string-search body (irc:message-body msg))))
298                    (or (not code) (eq? code (irc:message-code msg)))
299                    (proc msg) ) ) ) ] )
300    (irc:connection-handlers-set!
301     con
302     (append
303      (irc:connection-handlers con)
304      (list (if tag (cons tag h) h)) ) ) ) )
305
306(define (irc:remove-message-handler! con tag)
307  (irc:connection-handlers-set!
308   con
309   (let loop ([hs (irc:connection-handlers con)])
310     (cond [(null? hs) (error "undefined message handler" tag)]
311           [(and (pair? hs) (eq? tag (caar hs))) (cdr hs)]
312           [else (cons (car hs) (loop (cdr hs)))] ) ) ) )
313
314(define (irc:message-receiver msg)
315  (let ([params (irc:message-parameters msg)])
316    (and (pair? params) (car params)) ) )
317
318(define (irc:message-sender msg)
319  (let ([prefix (irc:message-prefix msg)])
320    (and (pair? prefix) (car prefix)) ) )
321
322)
Note: See TracBrowser for help on using the repository browser.