jollibot

view commands.lisp @ 0:ca9a5ca950dd

find changesets by author, revision, files, or words in the commit message
Initial check-in
author Thomas Jollans <thomas@jollans.com>
date Sun Oct 19 01:52:42 2008 +0200 (2008-10-19)
parents
children
line source
1 ;; *commands* -- list of ("cmd-name" cmd-func doc-string)
2 ;; where cmd-func must take 4 arguments: connection source-nick channel text
3 (defvar *commands* ())
4
5 ;;;;;; AUTHORIZATION HANDLING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6 (defparameter *loggedin* ())
7 (defun authorization (nick)
8 (or (cadr (assoc nick *loggedin* :test #'equal)) nil))
9
10 (defmacro require-auth (cnn nick chan authlevel
11 &body ok-forms)
12 (let ((auth (gensym)))
13 `(let ((,auth (authorization ,nick)))
14 (if (or (and (not ,authlevel) ,auth)
15 (member ,authlevel ,auth))
16 (progn
17 ,@ok-forms)
18 (irc:privmsg ,cnn ,chan
19 (format nil "~A: You are not authorized to do that."
20 ,nick))
21 ))
22 ))
23
24 ;;;;;; COMMAND META MACROS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25 (defmacro auth-irc-command (required-auth cname fargs cargs &body forms)
26 (let* ((str (gensym))
27 (rfargs (append fargs (list str)))
28 (cargs-list (gensym))
29 (docstring (and (stringp (first forms)) (first forms))) ; or nil
30 (auth-code (if (eq required-auth t)
31 `(progn)
32 `(require-auth ,@fargs ,required-auth)))
33 (func `(lambda ,rfargs
34 (let* ((,cargs-list (split-string ,str ,(length cargs)))
35 ,@(loop for vname in cargs
36 for i from 1
37 collect `(,vname (nth ,i ,cargs-list))))
38 (,@auth-code ,@forms)
39 ))))
40 `(setf *commands* (cons (list ,cname ,func ,docstring) *commands*))
41 ))
42
43 (defmacro irc-command (cname fargs cargs &body forms)
44 `(auth-irc-command t ,cname ,fargs ,cargs ,@forms))
45
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;;;;; COMMAND DEFINITIONS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49
50 (irc-command "say" (cnn src chan) (str)
51 "say <stuff>: Regurgitate given text."
52 (irc:privmsg cnn chan (string-rest str)))
53
54 (auth-irc-command 'admin "quit" (cnn src chan) (msg)
55 "quit <message>: Quit IRC"
56 (irc:quit cnn (string-rest msg)))
57
58 (irc-command "login" (cnn src chan) (cr1 cr2)
59 "login <user> <password> / login <password>: authenticate yourself to me."
60 (let ((cred (cond
61 ((= 0 (length cr2)) (list src cr1))
62 (t (list cr1 cr2)))))
63 (let ((auth (assoc cred *users* :test #'equal)))
64 (if auth
65 (progn
66 (setf *loggedin* (cons (list src (cadr auth)) *loggedin*))
67 (irc:privmsg cnn chan
68 (format nil "~A: Login OK. You are ~A"
69 src (cadr auth))))
70 (irc:privmsg cnn chan
71 (format nil "~A: Login FAILED."
72 src))))))
73
74 (irc-command "logout" (cnn src chan) ()
75 "logout: Drop privileges"
76 (let ((auth-line (assoc src *loggedin* :test #'equal)))
77 (if auth-line
78 (progn
79 (setf *loggedin* (remove auth-line *loggedin* :test #'equal))
80 (irc:privmsg cnn src "Logged out."))
81 (irc:privmsg cnn src "You weren't even logged in!!"))))
82
83 (irc-command "commands" (cnn src chan) ()
84 "commands: show available commands."
85 (irc:privmsg cnn chan
86 (format nil "Commands: ~S"
87 (map 'list #'car *commands*))))
88
89 (irc-command "info" (cnn src chan) ()
90 (irc:privmsg cnn chan "This is a bot written in Common Lisp. Code to be published. Meanwhile, ask free-zombie for more info."))
91
92 (defun cmd-help (cnn src chan str)
93 (let ((cmd (string-trim '(#\Space #\Tab) (string-rest str))))
94 (if (= 0 (length cmd))
95 (irc:privmsg cnn chan "Say 'commands' for a list of commands, help <command> for command-specific documentation.")
96 (let ((cmd-info (assoc cmd *commands* :test #'equal)))
97 (irc:privmsg cnn chan
98 (cond ((caddr cmd-info) (caddr cmd-info))
99 (cmd-info (format nil "No help for '~A'" cmd))
100 (t (format nil "No such command '~A'" cmd))))
101 )
102 )))
103
104 (let ((help-doc "help <command>: show command documentation"))
105 (setf *commands* (append *commands*
106 (list
107 (list "help" #'cmd-help help-doc)
108 (list "?" #'cmd-help help-doc)))))
109
110