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

(module vandusen 

($
 debug
 config
 call-with-connection
 start
 command
 message-handler
 plugin
 reply-to
 whisper-to
 say
 add-finalizer
 set-nick!
 after-connect
 dynamic-wind+)

(import chicken scheme srfi-1 extras data-structures)
(use irc posix srfi-18)

(cond-expand
 (total-irregex
  (use irregex))
 (else
  (require-library regex)
  (import irregex)
  (define irregex-num-submatches irregex-submatches)))

(include "irc-helpers")

(define config (make-parameter '((nick . "vandusen"))))
(define config-file #f)

(define (load-config file)
  (load file)
  (set! config-file file))

(define (reload-config)
  (load config-file))

(let ((old config))
  (set! config
        (case-lambda
         (() (old))
         ((value) (old (append value (old)))))))

(define ($ setting . value)
  (if (null? value)
      (alist-ref setting (config))
      (config (alist-update! setting (car value) (config)))))

(define (debug message)
  (when ($ 'debug)
    (print "debug: " message)))

(define (dynamic-wind+ before thunk after)
  (handle-exceptions exn
    (signal exn)
    (dynamic-wind
        before
        thunk
        after)))

(define connection #f)
(define connection-mutex (make-mutex))

(define after-connect (make-parameter #f))
(define (run-after-connect)
  (and (after-connect) ((after-connect))))

(define (call-with-connection proc)
  (dynamic-wind+
      (lambda ()
        (mutex-lock! connection-mutex))
      (cut proc connection)
      (lambda ()
        (mutex-unlock! connection-mutex))))

(define (start config-file)
  (load-config config-file)
  (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)))
  (initialize)
  (print (format "connecting to ~A as ~A" ($ 'host) ($ 'nick)))
  (irc:connect connection)
  (run-after-connect)
  
  (call-with-connection 
      (lambda (c)
        (for-each (lambda (channel) 
                    (print (format "joining ~A" channel))
                    (irc:join c channel)) ($ 'channels))))
  
  (let loop ()
    (condition-case (irc:run-message-loop connection debug: ($ 'debug))
        (ex (i/o net) 
            (irc:disconnect connection)
            (print-error-message ex (current-error-port))
            (print "reconnecting ...")
            (irc:connect connection)
            (loop)))))


(define commands '())

(define (command name . args)
  (set! commands (alist-update! name args commands)))

(define (message-handler . args)
  (apply irc:add-message-handler! connection args))

(define plugins '())

(define (plugin name thunk)
  (set! plugins (alist-update! name thunk plugins)))

(define (load-plugins)
  (for-each (lambda (plugin) 
              (debug (format "loading plugin ~A" (car plugin)))
              ((cdr plugin)))
            plugins))

(define (reply-to message text #!key (method irc:say) (prefixed (eq? irc:say method)))
  (call-with-connection (cut irc:reply <> message text method prefixed)))

(define (say . args)
  (call-with-connection 
      (lambda (c)
        (apply irc:say (cons c args)))))

(define (whisper-to . args)
  (call-with-connection
      (lambda (c)
        (apply irc:whisper c args))))

(define (match-body matcher)
  (irregex `(: " :" (* whitespace) ,matcher (* whitespace) eos)))

(define (irregex-match-all-submatches m irregex)
  (if (zero? (irregex-num-submatches irregex))
      '()
      (map (cut irregex-match-substring m <>) 
           (iota (irregex-num-submatches irregex) 1))))

(define (register-command matcher handler #!key public)
  (define (make-handler matcher)
    (let ((matcher (irregex matcher)))
      (lambda (m)
        (and-let* ((body (irc:message-body m))
                   (matches (irregex-search matcher body)))
          (if (or public (member (car (irc:message-prefix m)) ($ 'operators)))
              (thread-start! 
               (lambda ()
                 (apply handler (cons m (irregex-match-all-submatches matches matcher)))))
              (reply-to m "sorry, you are not allowed to do this"))))))

  (when ($ 'allow-query)
    (irc:add-message-handler! connection
                              (make-handler matcher)
                              receiver: ($ 'nick)
                              command: "PRIVMSG"
                              body: (match-body matcher)))

  (let ((matcher `(: ,($ 'nick) (or #\: #\,) (+ whitespace) ,matcher)))
    (irc:add-message-handler! connection (let ((handle (make-handler matcher)))
                                           (lambda (m)
                                             (and (eq? (string-ref (car (irc:message-parameters m)) 0) #\#)
                                                  (handle m))))
                              command: "PRIVMSG"
                              body: (match-body matcher))))

(define (de-register-commands)
  (let ((handlers (##sys#slot connection 11)))
    (##sys#setslot connection 11 (filter (lambda (h)
                                           (and (pair? h) (eq? 'ping (car h))))
                                         handlers))))

(define (re-register-commands)
  (register-command "reload"
                    (lambda (msg) 
                      (print "reloading")
                      (initialize)
                      (reply-to msg "reloaded" method: irc:action)))
  (for-each (lambda (command) 
              (debug (conc "registering command " (car command)))
              (apply register-command (cdr command))) commands))

(define (set-nick! nick)
  (de-register-commands)
  ($ 'nick nick)
  (call-with-connection (cut irc:nick <> nick))
  (re-register-commands))

(define add-finalizer #f)
(define initialize #f)

(let ((finalizers '()))
  (set! add-finalizer
        (lambda (f)
          (set! finalizers (cons f finalizers))))

  (set! initialize
        (lambda ()
          (for-each (lambda (f) (f)) finalizers)
         (de-register-commands)
          (set! commands '())
          (set! finalizers '())
          (include "handlers")
          (reload-config)
          (load-plugins)
         (re-register-commands)))
  )

)