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

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

vandusen: initial import

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