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

Last change on this file since 19180 was 19180, checked in by Moritz Heidkamp, 11 years ago

vandusen: allow no after-connect hook to be defined

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