source: project/release/4/vandusen/trunk/vandusen.scm @ 39080

Last change on this file since 39080 was 39080, checked in by Moritz Heidkamp, 3 months ago

vandusen: Work around the fact taht dynamic-wind's after thunk is not invoked when the main thunk is exited via an error

File size: 6.0 KB
Line 
1(module vandusen 
2
3($
4 debug
5 config
6 call-with-connection
7 start
8 command
9 message-handler
10 plugin
11 reply-to
12 whisper-to
13 say
14 add-finalizer
15 set-nick!
16 after-connect
17 dynamic-wind+)
18
19(import chicken scheme srfi-1 extras data-structures)
20(use irc posix srfi-18)
21
22(cond-expand
23 (total-irregex
24  (use irregex))
25 (else
26  (require-library regex)
27  (import irregex)
28  (define irregex-num-submatches irregex-submatches)))
29
30(include "irc-helpers")
31
32(define config (make-parameter '((nick . "vandusen"))))
33(define config-file #f)
34
35(define (load-config file)
36  (load file)
37  (set! config-file file))
38
39(define (reload-config)
40  (load config-file))
41
42(let ((old config))
43  (set! config
44        (case-lambda
45         (() (old))
46         ((value) (old (append value (old)))))))
47
48(define ($ setting . value)
49  (if (null? value)
50      (alist-ref setting (config))
51      (config (alist-update! setting (car value) (config)))))
52
53(define (debug message)
54  (when ($ 'debug)
55    (print "debug: " message)))
56
57(define (dynamic-wind+ before thunk after)
58  (let ((exn #f))
59    (dynamic-wind
60        before
61        (lambda ()
62          (handle-exceptions e
63            (set! exn (list e))
64            (thunk)))
65        (lambda ()
66          (after)
67          (when exn
68            (signal (car exn)))))))
69
70(define connection #f)
71(define connection-mutex (make-mutex))
72
73(define after-connect (make-parameter #f))
74(define (run-after-connect)
75  (and (after-connect) ((after-connect))))
76
77(define (call-with-connection proc)
78  (dynamic-wind+
79      (lambda ()
80        (mutex-lock! connection-mutex))
81      (cut proc connection)
82      (lambda ()
83        (mutex-unlock! connection-mutex))))
84
85(define (start config-file)
86  (load-config config-file)
87  (set! connection (irc:connection server: ($ 'host) nick: ($ 'nick) user: (or ($ 'user) "nobody")  real-name: (or ($ 'real-name) "nobody") port: (or ($ 'port) 6667) password: ($ 'password) reconnect-timeout: (or ($ 'reconnect-timeout) 3600000)))
88  (initialize)
89  (print (format "connecting to ~A as ~A" ($ 'host) ($ 'nick)))
90  (irc:connect connection)
91  (run-after-connect)
92 
93  (call-with-connection 
94      (lambda (c)
95        (for-each (lambda (channel) 
96                    (print (format "joining ~A" channel))
97                    (irc:join c channel)) ($ 'channels))))
98 
99  (let loop ()
100    (condition-case (irc:run-message-loop connection debug: ($ 'debug))
101        (ex (i/o net) 
102            (irc:disconnect connection)
103            (print-error-message ex (current-error-port))
104            (print "reconnecting ...")
105            (irc:connect connection)
106            (loop)))))
107
108
109(define commands '())
110
111(define (command name . args)
112  (set! commands (alist-update! name args commands)))
113
114(define (message-handler . args)
115  (apply irc:add-message-handler! connection args))
116
117(define plugins '())
118
119(define (plugin name thunk)
120  (set! plugins (alist-update! name thunk plugins)))
121
122(define (load-plugins)
123  (for-each (lambda (plugin) 
124              (debug (format "loading plugin ~A" (car plugin)))
125              ((cdr plugin)))
126            plugins))
127
128(define (reply-to message text #!key (method irc:say) (prefixed (eq? irc:say method)))
129  (call-with-connection (cut irc:reply <> message text method prefixed)))
130
131(define (say . args)
132  (call-with-connection 
133      (lambda (c)
134        (apply irc:say (cons c args)))))
135
136(define (whisper-to . args)
137  (call-with-connection
138      (lambda (c)
139        (apply irc:whisper c args))))
140
141(define (match-body matcher)
142  (irregex `(: " :" (* whitespace) ,matcher (* whitespace) eos)))
143
144(define (irregex-match-all-submatches m irregex)
145  (if (zero? (irregex-num-submatches irregex))
146      '()
147      (map (cut irregex-match-substring m <>) 
148           (iota (irregex-num-submatches irregex) 1))))
149
150(define (register-command matcher handler #!key public)
151  (define (make-handler matcher)
152    (let ((matcher (irregex matcher)))
153      (lambda (m)
154        (and-let* ((body (irc:message-body m))
155                   (matches (irregex-search matcher body)))
156          (if (or public (member (car (irc:message-prefix m)) ($ 'operators)))
157              (thread-start! 
158               (lambda ()
159                 (apply handler (cons m (irregex-match-all-submatches matches matcher)))))
160              (reply-to m "sorry, you are not allowed to do this"))))))
161
162  (when ($ 'allow-query)
163    (irc:add-message-handler! connection
164                              (make-handler matcher)
165                              receiver: ($ 'nick)
166                              command: "PRIVMSG"
167                              body: (match-body matcher)))
168
169  (let ((matcher `(: ,($ 'nick) (or #\: #\,) (+ whitespace) ,matcher)))
170    (irc:add-message-handler! connection (let ((handle (make-handler matcher)))
171                                           (lambda (m)
172                                             (and (eq? (string-ref (car (irc:message-parameters m)) 0) #\#)
173                                                  (handle m))))
174                              command: "PRIVMSG"
175                              body: (match-body matcher))))
176
177(define (de-register-commands)
178  (let ((handlers (##sys#slot connection 11)))
179    (##sys#setslot connection 11 (filter (lambda (h)
180                                           (and (pair? h) (eq? 'ping (car h))))
181                                         handlers))))
182
183(define (re-register-commands)
184  (register-command "reload"
185                    (lambda (msg) 
186                      (print "reloading")
187                      (initialize)
188                      (reply-to msg "reloaded" method: irc:action)))
189  (for-each (lambda (command) 
190              (debug (conc "registering command " (car command)))
191              (apply register-command (cdr command))) commands))
192
193(define (set-nick! nick)
194  (de-register-commands)
195  ($ 'nick nick)
196  (call-with-connection (cut irc:nick <> nick))
197  (re-register-commands))
198
199(define add-finalizer #f)
200(define initialize #f)
201
202(let ((finalizers '()))
203  (set! add-finalizer
204        (lambda (f)
205          (set! finalizers (cons f finalizers))))
206
207  (set! initialize
208        (lambda ()
209          (for-each (lambda (f) (f)) finalizers)
210         (de-register-commands)
211          (set! commands '())
212          (set! finalizers '())
213          (include "handlers")
214          (reload-config)
215          (load-plugins)
216         (re-register-commands)))
217  )
218
219)
Note: See TracBrowser for help on using the repository browser.