PageRenderTime 188ms CodeModel.GetById 13ms app.highlight 166ms RepoModel.GetById 1ms app.codeStats 0ms

/irc-process-line.rkt

http://github.com/elibarzilay/rudybot
Unknown | 853 lines | 778 code | 75 blank | 0 comment | 0 complexity | 6cada44c46522426e829b7e448344256 MD5 | raw file
  1#lang racket
  2
  3(provide irc-process-line)
  4
  5(require scheme/sandbox
  6         scheme/system
  7         srfi/13
  8         srfi/14
  9         (except-in "sandboxes.rkt" main)
 10         "vars.rkt"
 11         "git-version.rkt"
 12         "userinfo.rkt"
 13         "utils.rkt"
 14         (except-in "xlate.rkt" main)
 15         (except-in "spelled-out-time.rkt" main)
 16         (except-in "quotes.rkt" main)
 17         (except-in "re.rkt" main)
 18         (except-in "tinyurl.rkt" main)
 19         (planet schematics/macro/macro)
 20         (planet neil/numspell/numspell)
 21         )
 22
 23(define (is-master?)
 24  (let ([mm (unbox *my-master*)] [id (*full-id*)])
 25    (cond [(regexp? mm) (regexp-match? mm id)]
 26          [(string? mm) (equal? mm id)]
 27          [else #f])))
 28
 29;; (colon w) is a pattern that matches coloned words, and registers
 30;; their position
 31(define (starts-with-colon str)
 32  (cond [(regexp-match-positions #rx"^:(.*)" str)
 33         => (lambda (m) (substring+posn str (caadr m)))]
 34        [else #f]))
 35(define-match-expander colon
 36  (syntax-rules ()
 37    [(colon w) (app starts-with-colon w)]))
 38
 39(define (describe-since when)
 40  (spelled-out-time (- (current-seconds) when)))
 41
 42(define (nick->sighting-string n)
 43  ;; We might have accidentally stored a bunch of sightings for this
 44  ;; nick.  If we were to display them all, they might get truncated,
 45  ;; due to the 500-character output limit.  So userinfo always gives
 46  ;; us at most two of the recent ones.
 47  (let ([ss (lookup-sightings n)])
 48    (if (null? ss)
 49        (format "No sign of ~a" n)
 50        (string-join
 51         (map (lambda (info)
 52                (format "~a was seen ~ain/on ~a ~a ago~a"
 53                        (sighting-who   info)
 54                        (aif it (sighting-action? info) (string-append it " ") "")
 55                        (sighting-where info)
 56                        (describe-since (sighting-when  info))
 57                        (let ([words (string-join (sighting-words info))])
 58                          (if (positive? (string-length words))
 59                              (format ", saying \"~a\"" words)
 60                              ""))))
 61              ss)
 62         ", and then "))))
 63
 64;; For rate limiting -- every time we respond to a direct request, we
 65;; save the time under the requstor's nick.  That way, we can later
 66;; check a request from the same nick to see if they've requested
 67;; something recently, and perhaps deny the request.
 68(define *action-times-by-nick* (make-hash))
 69(define (we-recently-did-something-for nick)
 70  (>= (hash-ref *action-times-by-nick* nick 0)
 71      (- (current-seconds) 10)))
 72
 73(define (note-we-did-something-for! for-whom)
 74  (hash-set! *action-times-by-nick* for-whom (current-seconds)))
 75
 76;; Cheap global bit to avoid nagging channels with grab instructions (doesn't
 77;; work when give is used in several channels at the same time, no care for
 78;; races)
 79(define last-give-instructions #f)
 80
 81(define (out format-string . args)
 82  (let* ([str (apply format format-string args)]
 83         [str (if (> (string-length str) *max-output-line*)
 84                (string-append (substring str 0 (- *max-output-line* 4)) " ...")
 85                str)]
 86         ;; don't display newlines, so that Bad Guys won't be able
 87         ;; to inject IRC commands into our output.
 88         [str (regexp-replace* #rx"[\n\r]" str " <NEWLINE> ")])
 89    (log "=> ~a" str)
 90    (fprintf (*irc-output*) "~a~%" str)))
 91
 92(define (pm #:notice? [notice? #f] target fmt . args)
 93  (out "~a" (format "~a ~a :~a"
 94                    (if notice? "NOTICE" "PRIVMSG")
 95                    target (apply format fmt args))))
 96
 97;; ----------------------------------------------------------------------------
 98;; General IRC protocol matchers
 99
100(defmatcher IRC-COMMAND "ERROR"
101  (log "Uh oh!"))
102
103(define (send-NICK-and-USER)
104  (when (eq? (unbox *authentication-state*) 'havent-even-tried)
105    (out "NICK ~a" (unbox *my-nick*))
106    ;; RFC 1459 suggests that most of this data is ignored.
107    (out "USER luser unknown-host localhost :Eric Hanchrow's bot, version ~a"
108         (git-version))
109    (if (*nickserv-password*)
110        (pm "NickServ" "identify ~a" (*nickserv-password*))
111        (log "I'd register my nick, if I had a password."))
112    (set-box! *authentication-state* 'tried)))
113
114;; This message doesn't contain much information; it really just means
115;; we've connected.  And not all servers emit this anyway.  The server
116;; on freenode did up to about January 2010
117(defmatcher IRC-COMMAND "NOTICE"
118  (send-NICK-and-USER))
119
120(defmatcher IRC-COMMAND "PING"
121  (out "PONG ~a" (car (*current-words*))))
122
123(defmatcher IRC-COMMAND (regexp #rx"^:((.*)!(.*)@(.*))$"
124                                (list _ full-id nick id host))
125  (define (espy target action words)
126    (note-sighting (make-sighting nick target (current-seconds) action words)))
127  (if (equal? nick (unbox *my-nick*))
128    (match (*current-words*)
129      [(list "NICK" (colon new-nick))
130       (log "I seem to be called ~s now" new-nick)
131       (set-box! *my-nick* new-nick)]
132      [_ (log "I seem to have said ~s" (*current-words*))])
133    (match (*current-words*)
134      [(list "KICK" target victim mumblage ...)
135       (espy target (format "kicking ~a" victim) mumblage)]
136      [(list "MODE" target mode-data ...)
137       (espy target (format "changing the mode to '~a'" mode-data) '())]
138      [(list "INVITE" lucky-recipient (colon party) further ...)
139       (espy host (format "inviting ~a to ~a" lucky-recipient party)
140             further)]
141      [(list "NICK" (colon first-word) rest ...)
142       (espy host (format "changing their nick to ~a" first-word) '())]
143      [(list "TOPIC" target (colon first-word) rest ...)
144       (espy target
145             (format "changing the channel's topic to '~a'"
146                     (string-join (cons first-word rest))) '())]
147      [(list "JOIN" (colon target))
148       ;; Alas, this pretty much never triggers, since duncanm keeps his client
149       ;; session around for ever
150       (when (regexp-match #rx"^duncanm" nick)
151         (pm target "la la la"))
152       (when (regexp-match #rx"^klutometis" nick)
153         (pm target "\1ACTION bows deeply before his master, inventor of incubot\1"))
154       (espy target
155             (format "joining")
156             '())]
157      [(list "NICK" (colon new-nick))
158       ;; TODO -- call espy with the old nick, or the new one, or both?
159       (log "~a wants to be known as ~a" nick new-nick)]
160      [(list "PART" target (colon first-word) rest ...)
161       (espy target
162             "leaving the channel"
163             (cons first-word rest))]
164      [(list "PRIVMSG"
165             target
166             (regexp #px"^:\u0001([[:alpha:]]+)" (list _ extended-data-word ))
167             inner-words ...
168             (regexp #px"(.*)\u0001$" (list _ trailing )))
169       ((*incubot-server*) 'put (string-join (append inner-words (list trailing)) " "))
170       (espy target
171             (format "doing ~a: ~a" extended-data-word
172                     (string-join
173                      (append inner-words (list trailing))))
174             '())]
175      ;; Hard to see how this will ever match, given that the above clause
176      ;; would seem to match VERSION
177      [(list "PRIVMSG"
178             target
179             (regexp #px"^:\u0001(.*)\u0001" (list _ request-word ))
180             rest ...)
181       (log "request: ~s" request-word)
182       (when (equal? "VERSION" request-word)
183         (pm #:notice? #t
184             nick
185             "\u0001VERSION ~a (offby1@blarg.net):v4.~a:PLT scheme version ~a on ~a\0001"
186             (unbox *my-nick*)
187             (git-version)
188             (version)
189             (system-type 'os)))]
190
191      [(list "PRIVMSG" target (colon first-word) rest ...)
192       ;; Unspeakable hack -- "irc-process-line" is way too dumb, and
193       ;; merely hands us whitespace-delimited tokens; it should
194       ;; really have some knowledge of what IRC lines look like, and
195       ;; split the line into semantically-meaningful units.  But
196       ;; until I get off my ass and do that properly ...
197
198       ;; If first-word is just whitespace, then skip it.  This
199       ;; happens when someone types a line to their IRC client that
200       ;; begins with whitespace.
201       (when (and (not (null? rest))
202                  (regexp-match #px"^\\s*$" first-word))
203         (set! first-word (car rest))
204         (set! rest (cdr rest)))
205
206       ;; fledermaus points out that people may be surprised
207       ;; to find "private" messages -- those where "target"
208       ;; is (unbox *my-nick*) -- recorded in the sightings log.
209       (when (not (equal? target (unbox *my-nick*)))
210         (espy target #f (cons first-word rest)))
211
212       (cond
213        [(regexp-match? #rx"[Bb]ot$" nick)
214         (log "nick '~a' ends with 'bot', so I ain't gonna reply.  Bot wars, you know."
215              nick)]
216        [(equal? target (unbox *my-nick*))
217         (log "~a privately said ~a to me"
218              nick (string-join (cons first-word rest)))
219         (parameterize ([*full-id* full-id])
220           (do-cmd nick nick (cons first-word rest) #:rate_limit? #f))]
221        [else
222         ;; look for long URLs to tiny-ify, but only if we're The
223         ;; Original Rudybot, so avoid annoying duplicates from multiple
224         ;; bots
225         (when (regexp-match? #rx"^rudybot" (unbox *my-nick*))
226           (for ([word (in-list (cons first-word rest))])
227             (match word
228               [(regexp url-regexp (list url _ _))
229                (when (<= 75 (string-length url))
230                  (pm target "~a" (make-tiny-url url)))]
231               [_ #f])))
232         (when (and (regexp-match? #rx"^(?i:let(')?s)" first-word)
233                    (regexp-match? #rx"^(?i:jordanb)" nick))
234           (log "KOMEDY GOLD: ~s" (cons first-word rest)))
235         (match first-word
236           ;; TODO -- use a regex that matches just those characters that
237           ;; are legal in nicknames, followed by _any_ non-white
238           ;; character -- that way people can use, say, a semicolon after
239           ;; our nick, rather than just the comma and colon I've
240           ;; hard-coded here.
241           [(regexp #px"^([[:alnum:]_-]+)[,:](.*)" (list _ addressee garbage))
242            (let ([words (if (positive? (string-length garbage))
243                             (cons garbage rest)
244                             rest)])
245              (if (and (not (null? words))
246                       (equal? addressee (unbox *my-nick*)))
247                  (parameterize ([*full-id* full-id])
248                    (do-cmd target nick words #:rate_limit?
249                            (and #f
250                                 (not (regexp-match #rx"^offby1" nick))
251                                 (equal? target "#emacs" ))))
252                  ((*incubot-server*) 'put (string-join (cons first-word rest) " "))))]
253           [(regexp #px",+\\.+")
254            (when (equal? target "#emacs")
255              (pm target "Woof."))]
256
257           [_
258            ((*incubot-server*) 'put (string-join (cons first-word rest) " "))
259            ])])]
260
261      [(list "QUIT" (colon first-word) rest ...)
262       (espy host "quitting"
263             (cons first-word rest))]
264      [_ (log "~a said ~s, which I don't understand" nick
265              (text-from-word (*current-words*)))])))
266
267(defmatcher IRC-COMMAND (colon host)
268  (match (*current-words*)
269
270    ;; ircd-seven (http://freenode.net/seven.shtml) emits this as soon
271    ;; as we connect
272    [(list "NOTICE" blather ...)
273     (send-NICK-and-USER)]
274
275    [(list digits mynick blather ...)
276     (case (string->number digits)
277       [(1)
278        (log "Yay, we're in")
279        (set-box! *authentication-state* 'succeeded)
280        ;; BUGBUG --this appears to be to soon to join.  _Most_
281        ;; channels will let us join now; but some require that we
282        ;; authenticate with nickserv first, and at this point, even
283        ;; though we've already sent our password via
284        ;; send-NICK-and-USER, Nickserv hasn't processed it.  We thus
285        ;; need to wait until Nickserv has acknowledged our attempt to
286        ;; authenticate..
287
288        ;; ":NickServ!NickServ@services. NOTICE rudybot :You are now identified for \u0002rudebot\u0002."
289        (for ([c (*initial-channels*)]) (out "JOIN ~a" c))]
290       [(366)
291        (log "I, ~a, seem to have joined channel ~a."
292             mynick
293             (car blather))]
294       [(433)
295        (log "Nuts, gotta try a different nick")
296        (set-box! *my-nick* (string-append (unbox *my-nick*) "_"))
297        (out "NICK ~a" (unbox *my-nick*))])]
298    [(list)
299     (log "Completely unparseable line from the server.  current-words ~s; host ~s"
300          (*current-words*)
301          host)]))
302
303(defmatcher IRC-COMMAND _ (log "Duh?"))
304
305;; ----------------------------------------------------------------------------
306;; User verbs
307
308(define verbs        (make-hasheq))
309(define master-verbs (make-hasheq))
310(define verb-lines        '())
311(define master-verb-lines '())
312(define hidden-verb-lines '())
313
314(require (for-syntax (only-in scheme last drop-right)))
315(define-syntax (*defverb stx)
316  (define (id->str id) (and (identifier? id) (symbol->string (syntax-e id))))
317  (syntax-case stx ()
318    [(_ verbs verb-lines (verb arg ...) desc body ...)
319     (and (identifier? #'verb)
320          (andmap (lambda (s) (or (identifier? s) (string? (syntax-e s))))
321                  (syntax->list #'(arg ...)))
322          (string? (syntax-e #'desc)))
323     (let* ([raw-args (syntax->list #'(arg ...))]
324            [args (map id->str raw-args)]
325            [formstr
326             (apply string-append
327                    (id->str #'verb)
328                    (map (lambda (a r)
329                           (cond [(not a) (format " ~s" (syntax-e r))]
330                                 [(equal? a "...") " ..."]
331                                 [(regexp-match? #rx"^[?]" a)
332                                  (string-append " [<" (substring a 1) ">]")]
333                                 [else (string-append " <" a ">")]))
334                         args raw-args))])
335       (define clause
336         (if (and (pair? args) (last args) (regexp-match? #rx"^[?]" (last args)))
337             (let* ([opt  (last raw-args)]
338                    [raw-args (drop-right raw-args 1)])
339               #`[(list* #,@raw-args (and #,opt (or (list _) '())))
340                  (let ([#,opt (and (pair? #,opt) (car #,opt))]) body ...)])
341             #'[(list arg ...) body ...]))
342       #`(begin (hash-set! verbs 'verb
343                           (match-lambda #,clause
344                                         [_ (reply "expecting: ~a" #,formstr)]))
345                (set! verb-lines (cons '(verb #,formstr desc) verb-lines))))]))
346;; defverb defines a new verb:
347;;   (defverb (verb arg ...) "description" body ...)
348;; where `arg ...' can use `...' to get a "rest" argument, or one
349;; `?id' for an optional argument.
350;; In addition, it can have up to two flags:
351;; - #:whine can appear, which will wrap the verb action in a call/whine
352;; - #:master means that this is a master-only verb, or
353;;   #:hidden which makes it available for everyone, but not included in the
354;;   `help' output for a non-master user.
355(define-syntax (defverb stx)
356  (let*-values ([(whine rest)
357                 (syntax-case stx ()
358                   [(_ #:whine . rest)
359                    (values #t #'rest)]
360                   [(_ kwd #:whine . rest)
361                    (keyword? (syntax-e #'kwd))
362                    (values #t #'(kwd . rest))]
363                   [(_ . rest) (values #f #'rest)])]
364                [(verbs verb-lines rest)
365                 (syntax-case rest ()
366                   [(#:master . rest)
367                    (values #'master-verbs #'master-verb-lines #'rest)]
368                   [(#:hidden . rest)
369                    (values #'verbs #'hidden-verb-lines #'rest)]
370                   [_ (values #'verbs #'verb-lines rest)])])
371    (syntax-case rest ()
372      [((verb arg ...) desc body ...)
373       (and (identifier? #'verb)
374            (andmap (lambda (s) (or (identifier? s) (string? (syntax-e s))))
375                    (syntax->list #'(arg ...)))
376            (string? (syntax-e #'desc)))
377       #`(*defverb #,verbs #,verb-lines (verb arg ...) desc
378           #,@(if whine #'((call/whine (lambda () body ...))) #'(body ...)))]
379      [_ (raise-syntax-error 'defverb "malformed defverb" stx)])))
380
381(define (reply fmt . args)
382  (let* ([response-target (*response-target*)]
383         [for-whom        (*for-whom*)]
384         [response-prefix (if (equal? response-target for-whom)
385                            (if (is-master?) "* " "")
386                            (format (if (is-master?) "*~a: " "~a: ")
387                                    for-whom))])
388    (pm response-target "~a~a" response-prefix (apply format fmt args))))
389
390;; ----------------------------------------------------------------------------
391;; Misc utilities
392
393(defverb (help ?what) "what tricks can I do?"
394  (let ([what (and ?what (string->symbol ?what))]
395        [master? (is-master?)])
396    (cond
397      [(or (assq what verb-lines) (and master? (assq what master-verb-lines)))
398       => (lambda (v) (reply "~a: ~a" (cadr v) (caddr v)))]
399      [else (reply "~a"
400                   (string-join
401                    (map cadr (reverse `(,@(if master? master-verb-lines '())
402                                         ,@verb-lines)))
403                    ", "))])))
404
405(defverb (version) "my source code version"
406  (reply "~a" (git-version)))
407
408(defverb (quote) "words of wisdom"
409  (let ([q (one-quote)])
410    ;; special case: jordanb doesn't want quotes prefixed with his nick.
411    (match (*for-whom*)
412      [(regexp #rx"^jordanb") (pm (*response-target*) "~a" q)]
413      [_ (reply "~a" q)])))
414
415(defverb (source) "my source location"
416  (reply "git clone git://github.com/offby1/rudybot.git"))
417
418(defverb (seen nick) "did I see someone?"
419  ;; TODO -- if "nick" is fsbot, and the last time we saw 'em was
420  ;; quite a while ago, suggest /msg fledermaus (fsbot's owner).
421  ;; Thanks to jlf for the idea.
422  (reply "~a" (nick->sighting-string nick)))
423
424(defverb (uptime) "how long was I awake"
425  (reply "I've been up for ~a; this tcp/ip connection has been up for ~a"
426         (describe-since *start-time*)
427         (describe-since (*connection-start-time*))))
428
429(defverb #:whine (t8 from to text ...) "translate TEXT from FROM to TO"
430  (reply (xlate from to (string-join text " "))))
431
432(defverb #:hidden (ping) "am I alive?"
433  (reply "pong"))
434
435;; ----------------------------------------------------------------------------
436;; Evaluation related stuffs
437
438(define *default-sandbox-language* 'racket)
439
440(define (call/whine f . args)
441  (define (on-error e)
442    (let ([whine (if (exn? e) (exn-message e) (format "~s" e))])
443      (reply ;; make sure our error message begins with "error: ".
444             (if (regexp-match? #rx"^error: " whine) "~a" "error: ~a")
445             whine)))
446  (with-handlers ([void on-error]) (apply f args)))
447
448(define (get-sandbox [force? #f])
449  (let* ([for-whom (*for-whom*)]
450         [lang (userinfo-ref for-whom 'sandbox-lang *default-sandbox-language*)]
451         [lang-to-report (and (not (equal? lang *default-sandbox-language*))
452                              lang)]
453         [lang (case lang
454                 [(r5rs) '(special r5rs)]
455                 [else lang])]
456         [force/new? (or force? (box #f))]
457         [sb (get-sandbox-by-name *sandboxes* for-whom lang force/new?)])
458    (when (or force? (unbox force/new?))
459      (if lang-to-report
460        (reply "your ~s sandbox is ready" lang-to-report)
461        (reply "your sandbox is ready")))
462    sb))
463
464(define (do-eval words give-to)
465  (define for-whom (*for-whom*))
466  (define response-target (*response-target*))
467  ;; catch _all_ exceptions from the sandbox, to prevent "eval (raise 1)" or
468  ;; any other error from killing this thread (including creating the sandbox).
469  (when give-to
470    (cond [(equal? give-to (unbox *my-nick*)) (error "I'm full, thanks.")]
471          [(equal? give-to for-whom)
472           ;; allowing giving a value to yourself can lead to a nested call
473           ;; to `call-in-sandbox-context' which will deadlock.
474           (error "Talk to yourself much too?")]))
475  (let ([s (get-sandbox)])
476    (call-with-values (lambda () (sandbox-eval s (text-from-word words)))
477      (lambda values
478        ;; Even though the sandbox runs with strict memory and time limits, we
479        ;; use call-with-limits here anyway, because it's possible that the
480        ;; sandbox can, without exceeding its limits, return a value that will
481        ;; require a lot of time and memory to convert into a string!
482        ;; (make-list 100000) is an example.
483        (call-with-limits 10 20 ; 10sec, 20mb
484          (lambda ()
485            (define (display-values values displayed shown?)
486              (define (next s?)
487                (display-values (cdr values) (add1 displayed) s?))
488              (cond [(null? values) shown?]
489                    [(void? (car values)) (next shown?)]
490                    ;; prevent flooding
491                    [(>= displayed *max-values-to-display*)
492                     (reply
493                      "; ~a values is enough for anybody; here's the rest in a list: ~s"
494                      (number->english *max-values-to-display*)
495                      (filter (lambda (x) (not (void? x))) values))
496                     #t]
497                    [else (reply "; Value~a: ~s"
498                                 (if (positive? displayed)
499                                   (format "#~a" (add1 displayed))
500                                   "")
501                                 (car values))
502                          ;; another precaution against flooding.
503                          (sleep 1)
504                          (next #t)]))
505            (define (display-values/give)
506              (cond [(not give-to) (display-values values 0 #f)]
507                    [(null? values)
508                     (error "no value to give")]
509                    [(not (null? (cdr values)))
510                     (error "you can only give one value")]
511                    [else
512                     (sandbox-give s give-to (car values))
513                     ;; BUGBUG -- we shouldn't put "my-nick" in the
514                     ;; string if we're talking to a nick, as opposed to
515                     ;; a channel.
516                     (let* ((msg* (format "has given you a value, say \"~a: eval (GRAB)\""
517                                          (unbox *my-nick*)))
518                            (msg  (string-append msg* " to get it (case sensitive)")))
519                       (if (not (regexp-match? #rx"^#" response-target))
520                         ;; announce privately if given privately
521                         (pm give-to "~a ~a" for-whom msg)
522                         ;; cheap no-nag feature
523                         (let* ((l last-give-instructions)
524                                (msg (if (and l
525                                              (equal? (car l) response-target)
526                                              (< (- (current-seconds) (cdr l)) 120))
527                                       msg*
528                                       msg)))
529                           (set! last-give-instructions
530                                 (cons response-target (current-seconds)))
531                           (pm response-target
532                               "~a: ~a ~a" give-to for-whom msg))))
533                     #t])) ; said something
534            (define (display-output name output-getter)
535              (let ([output (output-getter s)])
536                (and (string? output) (positive? (string-length output))
537                     (begin (reply "; ~a: ~s" name output) (sleep 1) #t))))
538            (unless (or (display-values/give)
539                        (display-output 'stdout sandbox-get-stdout)
540                        (display-output 'stderr sandbox-get-stderr))
541              (reply "Done."))))))))
542
543(defverb #:whine (init ?lang)
544  "initialize a sandbox, <lang> can be 'r5rs, 'scheme, 'scheme/base, etc"
545  (when ?lang
546    (userinfo-set! (*for-whom*) 'sandbox-lang
547                   (if (regexp-match? #rx"^http://" ?lang)
548                     ?lang (string->symbol ?lang))))
549  (get-sandbox #t))
550(defverb #:whine (eval expr ...) "evaluate an expression(s)"
551  (do-eval expr #f))
552(defverb #:whine (give to expr ...) "evaluate and give someone the result"
553  (do-eval expr to))
554
555(defautoloads
556  [net/uri-codec uri-encode]
557  [setup/private/path-utils path->name]
558  [setup/xref load-collections-xref]
559  [setup/dirs find-doc-dir]
560  [scribble/xref xref-binding->definition-tag xref-tag->path+anchor
561                 xref-index entry-desc])
562;; these cannot be autoloaded, since it leads to some problem with errortrace
563(require (only-in scribble/manual-struct
564                  exported-index-desc? exported-index-desc-name
565                  exported-index-desc-from-libs))
566
567(define (binding-info id-str)
568  (call-in-sandbox-context (sandbox-evaluator (get-sandbox))
569    (lambda ()
570      (let* ([sym (string->symbol id-str)]
571             [id  (namespace-symbol->identifier sym)])
572        (values sym id (identifier-binding id))))))
573
574;; Based on Eli's interactive library
575(defverb #:whine (apropos str ...) "look for a binding"
576  (if (null? str)
577    (reply "give me something to look for")
578    (let* ([arg (map (compose regexp regexp-quote) str)]
579           [arg (lambda (str)
580                  (andmap (lambda (rx) (regexp-match? rx str)) arg))]
581           [syms (namespace-mapped-symbols
582                  (call-in-sandbox-context (sandbox-evaluator (get-sandbox))
583                                           current-namespace))]
584           [syms (filter-map (lambda (sym)
585                               (let ([str (symbol->string sym)])
586                                 (and (arg str) str)))
587                             syms)]
588           [syms (sort syms string<?)])
589      (if (null? syms)
590        (reply "no matches found")
591        (reply "matches: ~a." (string-join syms ", "))))))
592
593;; Based on Eli's interactive library
594(defverb #:whine (desc id) "describe an identifier"
595  (define-values (sym identifier info) (binding-info id))
596  (cond
597    [(not info) (reply "`~s' is a toplevel (or unbound) identifier" sym)]
598    [(eq? info 'lexical) (reply "`~s' is a lexical identifier" sym)]
599    [(or (not (list? info)) (not (= 7 (length info))))
600     (error "internal error, racket changed on me")]
601    [else
602     (let-values ([(source-mod source-id
603                    nominal-source-mod nominal-source-id
604                    source-phase import-phase
605                    nominal-export-phase)
606                   (apply values info)])
607       (define (mpi* mpi)
608         (let ([p (resolved-module-path-name
609                   (module-path-index-resolve mpi))])
610           (if (path? p) (path->name p) p)))
611       (let ([source-mod (mpi* source-mod)]
612             [nominal-source-mod (mpi* nominal-source-mod)])
613         (reply
614          "~a"
615          (string-append*
616           `("`",id"' is a bound identifier,"
617             " defined"
618             ,(case source-phase
619                [(0) ""] [(1) "-for-syntax"] [else (error "internal error")])
620             " in \"",(format "~a" source-mod)"\""
621             ,(if (not (eq? sym source-id))
622                (format " as `~s'" source-id)
623                "")
624             " required"
625             ,(case import-phase
626                [(0) ""] [(1) "-for-syntax"] [else (error "internal error")])
627             " "
628             ,(if (equal? source-mod nominal-source-mod)
629                "directly"
630                (format "through \"~a\"~a"
631                        nominal-source-mod
632                        (if (not (eq? sym nominal-source-id))
633                          (format " where it is defined as `~s'"
634                                  nominal-source-id)
635                          "")))
636             ,(case nominal-export-phase
637                [(0) ""] [(1) (format ", (exported-for-syntax)")]
638                [else (error "internal error")]))))))]))
639
640;; Based on help/help-utils
641
642(define remove-doc-dir
643  (regexp (string-append "^" (regexp-quote (path->string (find-doc-dir))) "/")))
644(define doc-url "http://docs.racket-lang.org/")
645(defverb #:whine (doc id) "find documentation for a binding"
646  (define-values (sym identifier info) (binding-info id))
647  (define xref
648    (load-collections-xref (lambda () (log "Loading help index..."))))
649  (if info
650    (let ([tag (xref-binding->definition-tag xref info 0)])
651      (if tag
652        (let*-values ([(file anchor) (xref-tag->path+anchor xref tag)]
653                      [(file) (path->string file)]
654                      [(m) (regexp-match-positions remove-doc-dir file)]
655                      [(url) (and m (string-append
656                                     doc-url
657                                     (substring file (cdar m))))]
658                      [(url) (cond [(and anchor url)
659                                    (string-append url "#" (uri-encode anchor))]
660                                   [url url]
661                                   [else "??hidden??"])])
662          (reply "~a" url))
663        (error 'help
664               "no documentation found for: ~e provided by: ~a"
665               sym
666               (module-path-index-resolve (caddr info)))))
667    (search-for-exports xref sym)))
668
669(define (search-for-exports xref sym)
670  (let ([idx (xref-index xref)]
671        [libs null])
672    (for ([entry (in-list idx)])
673      (when (and (exported-index-desc? (entry-desc entry))
674                 (eq? sym (exported-index-desc-name (entry-desc entry))))
675        (set! libs (append libs (exported-index-desc-from-libs
676                                 (entry-desc entry))))))
677    (if (null? libs)
678      (reply "not found in any library's documentation: ~a" sym)
679      (reply "no docs for a current binding, but provided by: ~a"
680             (string-join (map symbol->string (remove-duplicates libs))
681                          ", ")))))
682
683;; Silly stuffs
684
685(define-syntax-rule (defspecbotverbs db ...)
686  (begin (defverb #:hidden (db term (... ...)) "look something up"
687           (pm (*response-target*) "specbot: ~a ~a" 'db (string-join term)))
688         ...))
689(defspecbotverbs
690  db clhs r5rs cocoa elisp clim ieee754 ppc posix man cltl2 cltl2-section)
691
692(define-syntax-rule (defminionverbs verb ...)
693  (begin (defverb #:hidden (verb stuff (... ...)) "do some minion work"
694           (pm (*response-target*) "minion: ~a ~a" 'verb (string-join stuff)))
695         ...))
696(defminionverbs chant advice memo)
697
698(defverb (later "tell" nick something ...) "leave a message for someone"
699  (pm (*response-target*) "minion: memo for ~a: ~a told me to tell you: ~a"
700      nick (*for-whom*) (string-join something)))
701
702;; ----------------------------------------------------------------------------
703;; Master tools
704
705(define *master-password* #f)
706(defverb #:hidden (authenticate ?passwd) "request a passwd, or use one"
707  (cond [(not ?passwd)
708         (let ([passwd (random 1000000000)])
709           (set! *master-password* (cons (current-seconds) passwd))
710           (log "--->>> Temporary password: ~a <<<---" passwd)
711           (pm (*for-whom*) "Check the logs."))]
712        [(not *master-password*)
713         (reply "No password set")]
714        [(> (- (current-seconds) (car *master-password*)) 120)
715         (reply "Too late, generate a new password")]
716        [(not (equal? (string->number ?passwd) (cdr *master-password*)))
717         ;; avoid brute force attacks however unlikely
718         (set! *master-password* #f)
719         (log "Bad authentication attempt!")
720         (reply "Bad password, generate a new one now")]
721        [else
722         (set-box! *my-master* (*full-id*))
723         ;; in case the password was uttered publicly, avoid hijacks it
724         (set! *master-password* #f)
725         (log "I am a mindless puppet")
726         (reply "[bows deeply] Welcome, oh great master!")]))
727
728(defverb #:master (join channel) "ask me to join a channel"
729  (if (regexp-match? #rx"^#" channel)
730    (begin (out "JOIN ~a" channel) (reply "OK"))
731    (reply "not a proper channel name")))
732
733(defverb #:master (part channel) "ask me to part from a channel"
734  (if (regexp-match? #rx"^#" channel)
735    (begin (out "PART ~a" channel) (reply "OK"))
736    (reply "not a proper channel name")))
737
738(defverb #:master (tell who stuff ...) "tell me to tell someone something"
739  (pm (*response-target*) "~a: ~a" who (string-join stuff)))
740
741(defverb #:master (emote stuff ...) "tell me to do something"
742  (pm (*response-target*) "\1ACTION ~a\1" (string-join stuff)))
743
744(defverb #:master (for who stuff ...) "tell me something in someone's name"
745  (parameterize ([*full-id* ""]) ; avoid allowing master commands
746    (do-cmd (*response-target*) who stuff)))
747
748(defverb #:master (ghost victim) "kill an errant client that's using my favorite nick"
749  (pm "NickServ" (format "ghost ~a ~a" victim (*nickserv-password*))))
750
751(defverb #:master (nick new-nick) "tell me to rename myself"
752  (out "NICK ~a" new-nick))
753
754(defverb #:master (system command ...) "run something"
755  (let ([s (open-output-string)])
756    (parameterize ([current-output-port s] [current-error-port s])
757      (call-with-PATH (lambda () (call/whine system (string-join command)))))
758    (let* ([s (get-output-string s)]
759           [s (regexp-replace #rx"^[ \r\n]+" s "")]
760           [s (regexp-replace #rx"[ \r\n]+$" s "")]
761           [s (regexp-replace* #rx" *[\r\n] *" s " <NL> ")])
762      (reply "~a" (if (equal? s "") "OK" s)))))
763
764(define-namespace-anchor anchor)
765(define my-namespace (namespace-anchor->namespace anchor))
766(defverb #:master (top-eval expr ...) "evaluate something in the sandbox"
767  (call/whine
768   (lambda ()
769     (reply "~s"
770            (eval (read (open-input-string
771                         (string-append "(begin " (string-join expr) ")")))
772                  my-namespace)))))
773
774;; ----------------------------------------------------------------------------
775;; Incubot-like
776
777(define (get-incubot-witticism words)
778  (define incubot-witticism ((*incubot-server*) 'get words))
779  (define (strip-just-one rx) (curryr (curry regexp-replace rx) ""))
780  (define (trim-ACTION str)
781    (regexp-replace #rx"\1ACTION (.*)\1" str "\\1"))
782  (define (trim-leading-nick str)
783    (if (regexp-match #px"^http(s)?://" str)
784      str
785      ((strip-just-one #px"^\\w+?: *") str)))
786  (and incubot-witticism
787       (lambda ()
788         (reply "~a" (trim-ACTION (trim-leading-nick incubot-witticism))))))
789
790;; ----------------------------------------------------------------------------
791;; Main dispatchers
792
793(define (do-cmd response-target for-whom words #:rate_limit? [rate_limit? #f])
794  (parameterize ([*for-whom* for-whom]
795                 [*response-target* response-target])
796    (if (and rate_limit? (we-recently-did-something-for for-whom))
797      (log "Not doing anything for ~a, since we recently did something for them."
798           for-whom)
799      (let loop ([words words]
800                 [verb (string->symbol (string-downcase (car words)))])
801        (cond [(or (hash-ref verbs verb #f)
802                   (and (is-master?) (hash-ref master-verbs verb #f)))
803               => (lambda (p)
804                    (log "Doing for ~a: ~a ~s" for-whom verb (cdr words))
805                    (p (cdr words)))]
806              [(roughly-evaluable? for-whom (text-from-word words))
807               (loop (cons "eval" words) 'eval)]
808              [(get-incubot-witticism words)
809               => (lambda (p)
810                    (log "Spewing wisdom for ~a re ~a"
811                         for-whom (text-from-word words))
812                    (p))]
813              [else (log "Not doing for ~a: ~a" for-whom (text-from-word words))
814                    (reply "eh?  Try \"~a: help\"." (unbox *my-nick*))])
815        (note-we-did-something-for! for-whom)))))
816
817;; Maps a word to a (text . (start . end)) position in the original text
818;; (store the text to avoid worrying about a global `*current-line*'
819;; thing that can disappear)
820(define word-posns (make-weak-hasheq))
821;; Utility to get text from a word to the end (also accepts a list, and
822;; will use the first word); `emergency' is some value to use in case we
823;; don't find the text
824(define (text-from-word w [emergency w])
825  (cond [(pair? w) (text-from-word (car w) emergency)]
826        [(not (string? w))
827         (error 'text-from-word "Bad code, I have a bug -- got: ~s" w)]
828        [else (cond [(hash-ref word-posns w #f)
829                     => (lambda (p) (substring (car p) (cadr p)))]
830                    [(string? emergency) emergency]
831                    [(list? emergency) (string-join emergency " ")]
832                    [else (format "~a" emergency)])]))
833;; Sometimes we need to take a substring of a word -- so use this to
834;; register its info too
835(define (substring+posn str b [e (string-length str)])
836  (let ([p (hash-ref word-posns str #f)]
837        [r (substring str b e)])
838    (when p
839      (hash-set! word-posns r
840                 (cons (car p) (cons (+ (cadr p) b) (+ (cadr p) e)))))
841    r))
842
843(define rx:word #px"(?:\\p{L}+|\\p{N}+|\\p{S}|\\p{P})+")
844(define (irc-process-line line)
845  (let* ([posns (regexp-match-positions* rx:word line)]
846         [words (map (lambda (p)
847                       (let ([s (substring line (car p) (cdr p))])
848                         (hash-set! word-posns s (cons line p))
849                         s))
850                     posns)])
851    (when (null? words) (log "BAD IRC LINE: ~a" line))
852    (parameterize ([*current-words* (cdr words)])
853      (domatchers IRC-COMMAND (car words)))))