summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--irc/command.rkt62
1 files changed, 62 insertions, 0 deletions
diff --git a/irc/command.rkt b/irc/command.rkt
new file mode 100644
index 0000000..933f7e5
--- /dev/null
+++ b/irc/command.rkt
@@ -0,0 +1,62 @@
+#lang racket/base
+(require (for-syntax racket/base racket/list syntax/parse syntax/parse/lib/function-header)
+ irc/bot irc/users racket/format racket/string)
+(provide define-command)
+
+(struct command-registration (signature help power action))
+(define current-commands (make-parameter (make-hash)))
+
+(define (command-add signature action
+ #:help [help #f]
+ #:power [power 0])
+ (hash-set! (current-commands)
+ (car signature) (command-registration signature help power action)))
+
+(define (sufficient-power? nick wanted)
+ (or (= wanted 0)
+ (and (is-identified? nick)
+ (>= (user-power nick) wanted))))
+
+(define (command-process)
+ (define s-exp (safe-read-string (string-join (cdr (params)))))
+ (when (pair? s-exp)
+ (define command (hash-ref (current-commands) (car s-exp) #f))
+ (define required-power (command-registration-power command))
+ (when command
+ (if (sufficient-power? (source) required-power)
+ (apply (command-registration-action command)
+ (cdr s-exp))
+ (reply (format "Insufficient power (~a required)" required-power))))))
+
+(on (and (command-is 'PRIVMSG)
+ (not (source-is (current-nick))))
+ (command-process))
+
+(define-syntax (define-command stx)
+ (define-splicing-syntax-class single-keyword
+ (pattern (~seq kwname:keyword kwval:expr)))
+
+ (syntax-parse stx
+ [(_ (name:id fn ...)
+ kw:single-keyword ...
+ action ...)
+ (with-syntax ([(kw ...)
+ (append* (map syntax->list (syntax->list #'(kw ...))))])
+ #'(command-add '(name fn ...) kw ... (lambda (fn ...) action ...)))]))
+
+(define-command (list)
+ #:help "List all registered commands"
+ (reply (~s (hash-map (current-commands)
+ (λ (k v) (car (command-registration-signature v)))))))
+
+(define-command (help [command #f])
+ #:help "Display command argument names and description"
+ (if command
+ (let ([c (hash-ref (current-commands) command #f)])
+ (if c
+ (let* ([cr (command-registration-signature c)]
+ [help (command-registration-help c)])
+ (if help (reply (format "~s - ~a" cr help))
+ (reply (~s cr))))
+ (reply "There is no such command")))
+ (reply "You need to supply a command name, e.g. (help list)")))