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

Last change on this file since 21508 was 21101, checked in by Moritz Heidkamp, 10 years ago

vandusen: add vandusen-pager module by Christian Kellermann and bump version

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