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

Last change on this file since 33475 was 33475, checked in by Moritz Heidkamp, 5 years ago

vandusen: Support comma as recipient separator, too (thanks LemonBoy? for the patch)

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