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

Last change on this file was 39081, checked in by Moritz Heidkamp, 6 months ago

vandusen: Simplify dynamic-wind+ (thanks megane!)

File size: 5.8 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  (handle-exceptions exn
59    (signal exn)
60    (dynamic-wind
61        before
62        thunk
63        after)))
64
65(define connection #f)
66(define connection-mutex (make-mutex))
67
68(define after-connect (make-parameter #f))
69(define (run-after-connect)
70  (and (after-connect) ((after-connect))))
71
72(define (call-with-connection proc)
73  (dynamic-wind+
74      (lambda ()
75        (mutex-lock! connection-mutex))
76      (cut proc connection)
77      (lambda ()
78        (mutex-unlock! connection-mutex))))
79
80(define (start config-file)
81  (load-config config-file)
82  (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)))
83  (initialize)
84  (print (format "connecting to ~A as ~A" ($ 'host) ($ 'nick)))
85  (irc:connect connection)
86  (run-after-connect)
87 
88  (call-with-connection 
89      (lambda (c)
90        (for-each (lambda (channel) 
91                    (print (format "joining ~A" channel))
92                    (irc:join c channel)) ($ 'channels))))
93 
94  (let loop ()
95    (condition-case (irc:run-message-loop connection debug: ($ 'debug))
96        (ex (i/o net) 
97            (irc:disconnect connection)
98            (print-error-message ex (current-error-port))
99            (print "reconnecting ...")
100            (irc:connect connection)
101            (loop)))))
102
103
104(define commands '())
105
106(define (command name . args)
107  (set! commands (alist-update! name args commands)))
108
109(define (message-handler . args)
110  (apply irc:add-message-handler! connection args))
111
112(define plugins '())
113
114(define (plugin name thunk)
115  (set! plugins (alist-update! name thunk plugins)))
116
117(define (load-plugins)
118  (for-each (lambda (plugin) 
119              (debug (format "loading plugin ~A" (car plugin)))
120              ((cdr plugin)))
121            plugins))
122
123(define (reply-to message text #!key (method irc:say) (prefixed (eq? irc:say method)))
124  (call-with-connection (cut irc:reply <> message text method prefixed)))
125
126(define (say . args)
127  (call-with-connection 
128      (lambda (c)
129        (apply irc:say (cons c args)))))
130
131(define (whisper-to . args)
132  (call-with-connection
133      (lambda (c)
134        (apply irc:whisper c args))))
135
136(define (match-body matcher)
137  (irregex `(: " :" (* whitespace) ,matcher (* whitespace) eos)))
138
139(define (irregex-match-all-submatches m irregex)
140  (if (zero? (irregex-num-submatches irregex))
141      '()
142      (map (cut irregex-match-substring m <>) 
143           (iota (irregex-num-submatches irregex) 1))))
144
145(define (register-command matcher handler #!key public)
146  (define (make-handler matcher)
147    (let ((matcher (irregex matcher)))
148      (lambda (m)
149        (and-let* ((body (irc:message-body m))
150                   (matches (irregex-search matcher body)))
151          (if (or public (member (car (irc:message-prefix m)) ($ 'operators)))
152              (thread-start! 
153               (lambda ()
154                 (apply handler (cons m (irregex-match-all-submatches matches matcher)))))
155              (reply-to m "sorry, you are not allowed to do this"))))))
156
157  (when ($ 'allow-query)
158    (irc:add-message-handler! connection
159                              (make-handler matcher)
160                              receiver: ($ 'nick)
161                              command: "PRIVMSG"
162                              body: (match-body matcher)))
163
164  (let ((matcher `(: ,($ 'nick) (or #\: #\,) (+ whitespace) ,matcher)))
165    (irc:add-message-handler! connection (let ((handle (make-handler matcher)))
166                                           (lambda (m)
167                                             (and (eq? (string-ref (car (irc:message-parameters m)) 0) #\#)
168                                                  (handle m))))
169                              command: "PRIVMSG"
170                              body: (match-body matcher))))
171
172(define (de-register-commands)
173  (let ((handlers (##sys#slot connection 11)))
174    (##sys#setslot connection 11 (filter (lambda (h)
175                                           (and (pair? h) (eq? 'ping (car h))))
176                                         handlers))))
177
178(define (re-register-commands)
179  (register-command "reload"
180                    (lambda (msg) 
181                      (print "reloading")
182                      (initialize)
183                      (reply-to msg "reloaded" method: irc:action)))
184  (for-each (lambda (command) 
185              (debug (conc "registering command " (car command)))
186              (apply register-command (cdr command))) commands))
187
188(define (set-nick! nick)
189  (de-register-commands)
190  ($ 'nick nick)
191  (call-with-connection (cut irc:nick <> nick))
192  (re-register-commands))
193
194(define add-finalizer #f)
195(define initialize #f)
196
197(let ((finalizers '()))
198  (set! add-finalizer
199        (lambda (f)
200          (set! finalizers (cons f finalizers))))
201
202  (set! initialize
203        (lambda ()
204          (for-each (lambda (f) (f)) finalizers)
205         (de-register-commands)
206          (set! commands '())
207          (set! finalizers '())
208          (include "handlers")
209          (reload-config)
210          (load-plugins)
211         (re-register-commands)))
212  )
213
214)
Note: See TracBrowser for help on using the repository browser.