irc-process-line.rkt

#lang racket

(provide irc-process-line)

(require racket/sandbox
         racket/system
         net/base64
         srfi/13
         srfi/14
         "sandboxes.rkt"
         "vars.rkt"
         "git-version.rkt"
         (only-in "http.rkt" exn:fail:http? exn:fail:http-code)
         "userinfo.rkt"
         "utils.rkt"
         "xlate.rkt"
         (only-in "search.rkt" google-search)
         "spelled-out-time.rkt"
         "quotes.rkt"
         "re.rkt"
         "tinyurl.rkt"
         (planet neil/numspell/numspell))

(define (is-master?)
  (let ([mm (unbox *my-master*)] [id (*full-id*)])
    (cond [(regexp? mm) (regexp-match? mm id)]
          [(string? mm) (equal? mm id)]
          [else #f])))

;; (colon w) is a pattern that matches coloned words, and registers
;; their position
(define (starts-with-colon str)
  (cond [(regexp-match-positions #rx"^:(.*)" str)
         => (lambda (m) (substring+posn str (caadr m)))]
        [else #f]))
(define-match-expander colon
  (syntax-rules ()
    [(colon w) (app starts-with-colon w)]))

(define (describe-since when)
  (spelled-out-time (- (current-seconds) when)))

(define (nick->sighting-string n more)
  ;; We might have accidentally stored a bunch of sightings for this
  ;; nick.  If we were to display them all, they might get truncated,
  ;; due to the 500-character output limit.  So userinfo always gives
  ;; us at most two of the recent ones.
  (let ([ss (lookup-sightings n)])
    (if (null? ss)
        (format "I've never seen ~a before"  (string-join (cons n more) " "))
        (string-join
         (map (lambda (info)
                (string-join
                 (list
                  (format "~a was seen" (sighting-who   info))
                  (cond [(not (string? (sighting-action? info)))
                         (format "in ~a" (sighting-where info))]
                        [(equal? "quitting" (sighting-action? info))
                         (format "~a" (sighting-action? info))]
                        [else
                         (format "~a in ~a" (sighting-action? info) (sighting-where info))])
                  (format "~a ago~a" (describe-since (sighting-when  info))
                          (let ([words (string-join (sighting-words info))])
                            (if (positive? (string-length words))
                                (format ", saying \"~a\"" words)
                                ""))))
                 " "))
              ss)

         ", and then "))))

;; For rate limiting -- every time we respond to a direct request, we
;; save the time under the requstor's nick.  That way, we can later
;; check a request from the same nick to see if they've requested
;; something recently, and perhaps deny the request.
(define *action-times-by-nick* (make-hash))
(define (we-recently-did-something-for nick)
  (>= (hash-ref *action-times-by-nick* nick 0)
      (- (current-seconds) 10)))

(define (note-we-did-something-for! for-whom)
  (hash-set! *action-times-by-nick* for-whom (current-seconds)))

;; Cheap global bit to avoid nagging channels with grab instructions (doesn't
;; work when give is used in several channels at the same time, no care for
;; races)
(define last-give-instructions #f)

(define (out format-string . args)
  (let* ([str (apply format format-string args)]
         [str (if (> (string-length str) *max-output-line*)
                (string-append (substring str 0 (- *max-output-line* 4)) " ...")
                str)]
         ;; don't display newlines, so that Bad Guys won't be able
         ;; to inject IRC commands into our output.
         [str (regexp-replace* #rx"[\n\r]" str " <NEWLINE> ")])
    (log "=> ~a" str)
    (fprintf (*irc-output*) "~a~%" str)))

(define (pm #:notice? [notice? #f] target fmt . args)
  (out "~a" (format "~a ~a :~a"
                    (if notice? "NOTICE" "PRIVMSG")
                    target (apply format fmt args))))

;; ----------------------------------------------------------------------------
;; General IRC protocol matchers

(defmatcher IRC-COMMAND "ERROR"
  (log "Uh oh!"))

(define (send-NICK-and-USER)
  (when (eq? (unbox *authentication-state*) 'havent-even-tried)
    (out "CAP REQ :sasl")
    (if (*nickserv-password*)
          (begin
            (out "NICK ~a" (unbox *my-nick*))
            (out "USER luser unknown-host localhost :Amin Bandali's bot, version ~a"
                 (git-version))
            (out "AUTHENTICATE PLAIN"))
          (log "I'd register my nick, if I had a password."))
    (set-box! *authentication-state* 'tried)))

;; This message doesn't contain much information; it really just means
;; we've connected.  And not all servers emit this anyway.  The server
;; on freenode did up to about January 2010
(defmatcher IRC-COMMAND "NOTICE"
  (send-NICK-and-USER))

(defmatcher IRC-COMMAND "PING"
  (out "PONG ~a" (car (*current-words*))))

(defmatcher IRC-COMMAND (regexp #rx"^:((.*)!(.*)@(.*))$"
                                (list _ full-id nick id host))
  (define (espy target action words)
    (note-sighting (make-sighting nick target (current-seconds) action words)))
  (if (equal? nick (unbox *my-nick*))
      (match (*current-words*)
        [(list "NICK" (colon new-nick))
         (log "I seem to be called ~s now" new-nick)
         (set-box! *my-nick* new-nick)]
        [_ (log "I seem to have said ~s" (*current-words*))])
      (match (*current-words*)
        [(list "KICK" target victim mumblage ...)
         (espy target (format "kicking ~a" victim) mumblage)]
        [(list "MODE" target mode-data ...)
         (espy target (format "changing the mode to '~a'" mode-data) '())]
        [(list "INVITE" lucky-recipient (colon party) further ...)
         (espy host (format "inviting ~a to ~a" lucky-recipient party)
               further)]
        [(list "NICK" (colon first-word) rest ...)
         (espy host (format "changing their nick to ~a" first-word) '())]
        [(list "TOPIC" target (colon first-word) rest ...)
         (espy target
               (format "changing the channel's topic to '~a'"
                       (string-join (cons first-word rest))) '())]
        [(list "JOIN" (or target (colon target)))
         ;; Alas, this pretty much never triggers, since duncanm keeps his client
         ;; session around for ever
         (when (regexp-match #rx"^duncanm" nick)
           (pm target "la la la"))
         (when (regexp-match #rx"^klutometis" nick)
           (pm target "\1ACTION bows deeply before his master, inventor of incubot\1"))
         (espy target
               "joining"
               '())]
        [(list "NICK" (colon new-nick))
         ;; TODO -- call espy with the old nick, or the new one, or both?
         (log "~a wants to be known as ~a" nick new-nick)]
        [(list "PART" target (colon first-word) rest ...)
         (espy target
               "leaving the channel"
               (cons first-word rest))]
        [(list "PRIVMSG"
               target
               (regexp #px"^:\u0001([[:alpha:]]+)" (list _ extended-data-word ))
               inner-words ...
               (regexp #px"(.*)\u0001$" (list _ trailing )))
         ((*incubot-server*) 'put-string (string-join (append inner-words (list trailing)) " "))
         (espy target
               (format "doing ~a: ~a" extended-data-word
                       (string-join
                        (append inner-words (list trailing))))
               '())]
        ;; Hard to see how this will ever match, given that the above clause
        ;; would seem to match VERSION
        [(list "PRIVMSG"
               target
               (regexp #px"^:\u0001(.*)\u0001" (list _ request-word ))
               rest ...)
         (log "request: ~s" request-word)
         (when (equal? "VERSION" request-word)
           (pm #:notice? #t
               nick
               "\u0001VERSION ~a (bandali@gnu.org):v4.~a:Racket scheme version ~a on ~a\0001"
               (unbox *my-nick*)
               (git-version)
               (version)
               (system-type 'os)))]

        [(list "PRIVMSG" target (colon first-word) rest ...)
         ;; Unspeakable hack -- "irc-process-line" is way too dumb, and
         ;; merely hands us whitespace-delimited tokens; it should
         ;; really have some knowledge of what IRC lines look like, and
         ;; split the line into semantically-meaningful units.  But
         ;; until I get off my ass and do that properly ...

         ;; If first-word is just whitespace, then skip it.  This
         ;; happens when someone types a line to their IRC client that
         ;; begins with whitespace.
         (when (and (not (null? rest))
                    (regexp-match #px"^\\s*$" first-word))
           (set! first-word (car rest))
           (set! rest (cdr rest)))

         ;; fledermaus points out that people may be surprised
         ;; to find "private" messages -- those where "target"
         ;; is (unbox *my-nick*) -- recorded in the sightings log.
         (when (not (equal? target (unbox *my-nick*)))
           (espy target #f (cons first-word rest)))

         (cond
           [(and
             (or
              (regexp-match? #rx"[Bb]ot$" (canonicalize-nick nick))
              (string=? "bottle" (canonicalize-nick nick)))
             (not (and
                   (string=? (canonicalize-nick nick) "fsbot")
                   (and (not (null? rest))
                        (member (car rest) '("g" "t8"))))))
           (log "nick '~a' sounds like a bot, so I ain't gonna reply.  Bot wars, you know."
                nick)]
          [(equal? target (unbox *my-nick*))
           (log "~a privately said ~a to me"
                nick (string-join (cons first-word rest)))
           (parameterize ([*full-id* full-id])
             (do-cmd nick nick (cons first-word rest) #:rate_limit? #f))]
          [else
           ;; look for long URLs to tiny-ify, but only if we're The
           ;; Original Rudybot, so avoid annoying duplicates from multiple
           ;; bots
           (when (regexp-match? #rx"^rudybot" (unbox *my-nick*))
             (for ([word (in-list (cons first-word rest))])
               (match word
                 [(regexp url-regexp (list url _ _))
                  (when (<= 110 (string-length url))
                    ;; TODO -- calling this synchronously seems like a
                    ;; bad idea -- what if the call takes forever?
                    (with-handlers ([exn:fail:http?
                                     (lambda (e)
                                       (pm target "The URL shortener is feeling poorly today: ~a (~a)"
                                           (exn:fail:http-code e)
                                           (exn-message e)))])
                      (pm target "~a" (make-tiny-url url))))
                  ]
                 [_ #f])))
           (when (and (regexp-match? #rx"^(?i:let(')?s)" first-word)
                      (regexp-match? #rx"^(?i:jordanb)" nick))
             (log "KOMEDY GOLD: ~s" (cons first-word rest)))
           (match first-word
             ;; TODO -- use a regex that matches just those characters that
             ;; are legal in nicknames, followed by _any_ non-white
             ;; character -- that way people can use, say, a semicolon after
             ;; our nick, rather than just the comma and colon I've
             ;; hard-coded here.
             [(regexp #px"^([[:alnum:]_-]+)[,:](.*)" (list _ addressee garbage))
              (let ([words (if (positive? (string-length garbage))
                               (cons garbage rest)
                               rest)])
                (if (and (not (null? words))
                         (equal? addressee (unbox *my-nick*)))
                    (parameterize ([*full-id* full-id])
                      (do-cmd target nick words #:rate_limit?
                              (and #f
                                   (not (regexp-match #rx"^offby1" nick))
                                   (equal? target "#emacs" ))))
                    ((*incubot-server*) 'put-string (string-join rest " "))))]

             ;; These trigger fsbot, and the combination of rudybot's
             ;; reponse with fsbot's response (which for some reason
             ;; always comes second) is, dare I say it, amusing.
             [",..."                    ;[the sound of crickets permeates the air]
              (when (equal? target "#emacs")
                (pm target "Woof."))]

             [",…"                      ;[In the distance, you see a tree bark]
              (when (equal? target "#emacs")
                (pm target "\1ACTION makes like a tree, and leaves\1"))]

             [",⋱"                      ;[In the distance, there is no one to hear a tree fall]
              (when (equal? target "#emacs")
                (pm target "\1ACTION makes the sound of one hand clapping\1"))
             ]
             [",⋮"                      ;[In the distance, a fallen tree eerily rights itself]
              (when (equal? target "#emacs")
                (pm target "\1ACTION waves his hands and intones 'Abracadabra'\1"))
              ]
             [",᠁"                      ;From hell's heart I stab at thee.
              (when (equal? target "#emacs")
                (pm target "\1ACTION lobs a wicked insult at fsbot\1"))
              ]
             [_
              ((*incubot-server*)
               'put-string
               (string-join
                (if (string=? "ACTION" first-word)
                    rest
                    (cons first-word rest))
                " "))
              ])])]

        [(list "QUIT" (colon first-word) rest ...)
         (espy host "quitting"
               (cons first-word rest))]
        [_ (log "~a said ~s, which I don't understand" nick
                (text-from-word (*current-words*)))])))

(defmatcher IRC-COMMAND "AUTHENTICATE"
  (when (equal? '("+") (*current-words*))
        (out "AUTHENTICATE ~a"
             (bytes->string/utf-8
              (let ((username  (unbox *my-nick*))
                    ;; I suspect this account-name can be identical to
                    ;; the password; I simply haven't yet tried that
                    (account-name "rudebot")
                    (password (*nickserv-password*)))
                (base64-encode  (string->bytes/utf-8 (format "~a\0~a\0~a" account-name username password)) #"")))))
  )

(defmatcher IRC-COMMAND (colon host)
  (match (*current-words*)

    ;; ircd-seven (http://freenode.net/seven.shtml) emits this as soon
    ;; as we connect
    [(list "NOTICE" blather ...)
     (send-NICK-and-USER)]

    [(list digits mynick blather ...)
     (case (string->number digits)
       [(1 903)
        (log "Yay, we're in")
        (out "CAP END")
        (set-box! *authentication-state* 'succeeded)
        ;; BUGBUG --this appears to be to soon to join.  _Most_
        ;; channels will let us join now; but some require that we
        ;; authenticate with nickserv first, and at this point, even
        ;; though we've already sent our password via
        ;; send-NICK-and-USER, Nickserv hasn't processed it.  We thus
        ;; need to wait until Nickserv has acknowledged our attempt to
        ;; authenticate..

        ;; ":NickServ!NickServ@services. NOTICE rudybot :You are now identified for \u0002rudebot\u0002."
        (for ([c (*initial-channels*)]) (out "JOIN ~a" c))]
       [(366)
        (log "I, ~a, seem to have joined channel ~a."
             mynick
             (car blather))]
       [(433)
        (log "Nuts, gotta try a different nick")
        (set-box! *my-nick* (string-append (unbox *my-nick*) "_"))
        (out "NICK ~a" (unbox *my-nick*))])]
    [(list)
     (log "Completely unparseable line from the server.  current-words ~s; host ~s"
          (*current-words*)
          host)]))

(defmatcher IRC-COMMAND _ (log "Duh?"))

;; ----------------------------------------------------------------------------
;; User verbs

(define verbs        (make-hasheq))
(define master-verbs (make-hasheq))
(define verb-lines        '())
(define master-verb-lines '())
(define hidden-verb-lines '())

(require (for-syntax (only-in scheme last drop-right)))
(define-syntax (*defverb stx)
  (define (id->str id) (and (identifier? id) (symbol->string (syntax-e id))))
  (syntax-case stx ()
    [(_ verbs verb-lines (verb arg ...) desc body ...)
     (and (identifier? #'verb)
          (andmap (lambda (s) (or (identifier? s) (string? (syntax-e s))))
                  (syntax->list #'(arg ...)))
          (string? (syntax-e #'desc)))
     (let* ([raw-args (syntax->list #'(arg ...))]
            [args (map id->str raw-args)]
            [formstr
             (apply string-append
                    (id->str #'verb)
                    (map (lambda (a r)
                           (cond [(not a) (format " ~s" (syntax-e r))]
                                 [(equal? a "...") " ..."]
                                 [(regexp-match? #rx"^[?]" a)
                                  (string-append " [<" (substring a 1) ">]")]
                                 [else (string-append " <" a ">")]))
                         args raw-args))])
       (define clause
         (if (and (pair? args) (last args) (regexp-match? #rx"^[?]" (last args)))
             (let* ([opt  (last raw-args)]
                    [raw-args (drop-right raw-args 1)])
               #`[(list* #,@raw-args (and #,opt (or (list _) '())))
                  (let ([#,opt (and (pair? #,opt) (car #,opt))]) body ...)])
             #'[(list arg ...) body ...]))
       #`(begin (hash-set! verbs 'verb
                           (match-lambda #,clause
                                         [_ (reply "expecting: ~a" #,formstr)]))
                (set! verb-lines (cons '(verb #,formstr desc) verb-lines))))]))
;; defverb defines a new verb:
;;   (defverb (verb arg ...) "description" body ...)
;; where `arg ...' can use `...' to get a "rest" argument, or one
;; `?id' for an optional argument.
;; In addition, it can have up to two flags:
;; - #:whine can appear, which will wrap the verb action in a call/whine
;; - #:master means that this is a master-only verb, or
;;   #:hidden which makes it available for everyone, but not included in the
;;   `help' output for a non-master user.
(define-syntax (defverb stx)
  (let*-values ([(whine rest)
                 (syntax-case stx ()
                   [(_ #:whine . rest)
                    (values #t #'rest)]
                   [(_ kwd #:whine . rest)
                    (keyword? (syntax-e #'kwd))
                    (values #t #'(kwd . rest))]
                   [(_ . rest) (values #f #'rest)])]
                [(verbs verb-lines rest)
                 (syntax-case rest ()
                   [(#:master . rest)
                    (values #'master-verbs #'master-verb-lines #'rest)]
                   [(#:hidden . rest)
                    (values #'verbs #'hidden-verb-lines #'rest)]
                   [_ (values #'verbs #'verb-lines rest)])])
    (syntax-case rest ()
      [((verb arg ...) desc body ...)
       (and (identifier? #'verb)
            (andmap (lambda (s) (or (identifier? s) (string? (syntax-e s))))
                    (syntax->list #'(arg ...)))
            (string? (syntax-e #'desc)))
       #`(*defverb #,verbs #,verb-lines (verb arg ...) desc
           #,@(if whine #'((call/whine (lambda () body ...))) #'(body ...)))]
      [_ (raise-syntax-error 'defverb "malformed defverb" stx)])))

(define (reply fmt . args)
  (let* ([response-target (*response-target*)]
         [for-whom        (*for-whom*)]
         [response-prefix (if (equal? response-target for-whom)
                            (if (is-master?) "* " "")
                            (format (if (is-master?) "*~a: " "~a: ")
                                    for-whom))])
    (pm response-target "~a~a" response-prefix (apply format fmt args))))

;; ----------------------------------------------------------------------------
;; Misc utilities

(defverb (bug more ...) "You suck."
  (reply "Yes, I know I suck: https://github.com/offby1/rudybot/issues"))

(defverb (fom more ...) "Emit the URL for Greg Hendershott's 'Fear of Macros'"
  (reply "http://www.greghendershott.com/fear-of-macros/ ~a" (string-join more)))

(defverb (hopeless more ...) "Emit the URL that explains why the top level is hopeless"
  (reply "https://gist.github.com/samth/3083053"))

(defverb (falsy more ...) "Emit the URL that describes the various \"false\" values in various programming languages"
  (reply "https://plus.google.com/+ShriramKrishnamurthi/posts/4qvvKYC1R8Y"))

(defverb (bad-eval more ...) "Emit the URL that explains why using 'eval' is generally a mistake"
  (reply "http://blog.racket-lang.org/2011/10/on-eval-in-dynamic-languages-generally.html"))

(defverb (later "tell" recipient message ...) "backwards-compatible \"tell\""
  (let* ([response-target "memoserv"]
         [for-whom        (*for-whom*)])
    (pm response-target  "send ~a ~a says: ~a" recipient for-whom (string-join message " "))
    (reply "I asked `MemoServ' to forward the message to ~a." recipient)))

(defverb (help ?what) "what tricks can I do?"
  (let ([what (and ?what (string->symbol ?what))]
        [master? (is-master?)])
    (cond
      [(or (assq what verb-lines) (and master? (assq what master-verb-lines)))
       => (lambda (v) (reply "~a: ~a" (cadr v) (caddr v)))]
      [else (reply "~a"
                   (string-join
                    (map cadr (reverse `(,@(if master? master-verb-lines '())
                                         ,@verb-lines)))
                    ", "))])))

(defverb (version) "my source code version"
  (reply "~a" (git-version)))

(defverb (quote) "words of wisdom"
  (let ([q (one-quote)])
    ;; special case: jordanb doesn't want quotes prefixed with his nick.
    (match (*for-whom*)
      [(regexp #rx"^jordanb") (pm (*response-target*) "~a" q)]
      [_ (reply "~a" q)])))

(defverb (source) "my source location"
  (reply "git clone git://gitlab.com/offby1/rudybot.git"))

(defverb (url) "my web page"
  (reply "https://gitlab.com/offby1/rudybot"))

(defverb (g query ...) "Do a Google search"
  (let ((search-string  (string-join query " ")))
    (match (google-search search-string)
           [(cons title link)
            (reply "~a ~a" title link)]
           [_
            (reply "erp?")])))

(defverb (sentientp) "imitate fsbot"
  (reply "Any day now"))

(defverb (seen nick more ...) "did I see someone?"
  ;; TODO -- if "nick" is fsbot, and the last time we saw 'em was
  ;; quite a while ago, suggest /msg fledermaus (fsbot's owner).
  ;; Thanks to jlf for the idea.
  (reply "~a" (nick->sighting-string nick more)))

;; TODO -- figure out how to make a proper alias, rather than copying
;; and pasting the definition of "seen"
(defverb (|where's| nick more ...) "did I see someone?"
  (reply "~a" (nick->sighting-string nick more)))

(defverb (uptime) "how long was I awake"
  (reply "I've been up for ~a; this tcp/ip connection has been up for ~a"
         (describe-since *start-time*)
         (describe-since (*connection-start-time*))))

(defverb #:whine (t8 from to text ...) "translate TEXT from FROM to TO"
  (reply "~a" (xlate from to (string-join text " "))))

(defverb #:hidden (ping) "am I alive?"
  (reply "pong"))

(defverb (snotback) "another treat"
  (pm (*response-target*) "Yum! Oysters."))

;; TODO -- the "botsnack" and "quote" verbs are, for all intents,
;; identical; merge them?
(defverb (botsnack) "a treat"
  (pm (*response-target*) "~a" (random-botsnack)))

(define (random-botsnack)
  (define len (vector-length botsnack-responses))
  (vector-ref botsnack-responses (random len)))

(define botsnack-responses
  #(;; fsbot "standard" responses
    "yay!"
    ":)"
    "\1ACTION dances happily\1"
    "thank you!"
    "\1ACTION beams\1"
    "my favourite snack!"

    ;; rudybot proprietary extensions

    ;;; ungrateful
    "yech, generic brand"
    "barely even a mouthful"
    "mmm ... cheesesteak ..."
    "do I look like I eat vegan botsnacks?"

    ;;; grateful
    "you, sir, are a gent of the highest calibre"
    "thank you and one day I will return the favour"
    "OMG that's just what I needed LOL"

    ;;; other
    "yow!"
    "this is going straight to my thighs"
    "come on man, one more. I need my fix!"
    "Mighty tasty cereal flakes, Mrs. McDonough."
    "A légpárnás tele van angolnák."
    "\1ACTION wiggles his eyebrows at his cousin gabot\1"
    ))

;; ----------------------------------------------------------------------------
;; Evaluation related stuffs

(define *default-sandbox-language* 'racket)

(define (call/whine f . args)
  (define (on-error e)
    (let ([whine (if (exn? e) (exn-message e) (format "~s" e))])
      (reply ;; make sure our error message begins with "error: ".
             (if (regexp-match? #rx"^error: " whine) "~a" "error: ~a")
             whine)))
  (with-handlers ([void on-error]) (apply f args)))

(define (get-sandbox [force? #f])
  (let* ([for-whom (*for-whom*)]
         [lang (userinfo-ref for-whom 'sandbox-lang *default-sandbox-language*)]
         [lang-to-report (and (not (equal? lang *default-sandbox-language*))
                              lang)]
         [lang (case lang
                 [(r5rs) '(special r5rs)]
                 [else lang])]
         [force/new? (or force? (box #f))]
         [sb (get-sandbox-by-name *sandboxes* for-whom
                                  #:lang lang
                                  #:force/new? force/new?)])
    (when (or force? (unbox force/new?))
      (if lang-to-report
        (reply "your ~s sandbox is ready" lang-to-report)
        (reply "your sandbox is ready")))
    sb))

(define (some seq)
  (ormap values seq))

(define (do-eval words give-to)
  (define for-whom (*for-whom*))
  (define response-target (*response-target*))
  ;; catch _all_ exceptions from the sandbox, to prevent "eval (raise 1)" or
  ;; any other error from killing this thread (including creating the sandbox).
  (when give-to
    (cond [(equal? give-to (unbox *my-nick*)) (error "I'm full, thanks.")]
          [(equal? give-to for-whom)
           ;; allowing giving a value to yourself can lead to a nested call
           ;; to `call-in-sandbox-context' which will deadlock.
           (error "Talk to yourself much too?")]))
  (let ([s (get-sandbox)])
    (call-with-values (lambda () (sandbox-eval s (text-from-word words)))
      (lambda values
        ;; Even though the sandbox runs with strict memory and time limits, we
        ;; use call-with-limits here anyway, because it's possible that the
        ;; sandbox can, without exceeding its limits, return a value that will
        ;; require a lot of time and memory to convert into a string!
        ;; (make-list 100000) is an example.
        (call-with-limits 10 20 ; 10sec, 20mb
          (lambda ()
            (define (display-values values displayed shown?)
              (define (next s?)
                (display-values (cdr values) (add1 displayed) s?))
              (cond [(null? values) shown?]
                    [(void? (car values)) (next shown?)]
                    ;; prevent flooding
                    [(>= displayed *max-values-to-display*)
                     (reply
                      "; ~a values is enough for anybody; here's the rest in a list: ~v"
                      (number->english *max-values-to-display*)
                      (filter (lambda (x) (not (void? x))) values))
                     #t]
                    [else (reply "; Value~a: ~v"
                                 (if (positive? displayed)
                                   (format "#~a" (add1 displayed))
                                   "")
                                 (car values))
                          ;; another precaution against flooding.
                          (sleep 1)
                          (next #t)]))
            (define (display-values/give)
              (cond [(not give-to) (display-values values 0 #f)]
                    [(null? values)
                     (error "no value to give")]
                    [(not (null? (cdr values)))
                     (error "you can only give one value")]
                    [else
                     (sandbox-give s give-to (car values))
                     ;; BUGBUG -- we shouldn't put "my-nick" in the
                     ;; string if we're talking to a nick, as opposed to
                     ;; a channel.
                     (let* ((msg* (format "has given you a value, say \"~a: eval (GRAB)\""
                                          (unbox *my-nick*)))
                            (msg  (string-append msg* " to get it (case sensitive)")))
                       (if (not (regexp-match? #rx"^#" response-target))
                         ;; announce privately if given privately
                         (pm give-to "~a ~a" for-whom msg)
                         ;; cheap no-nag feature
                         (let* ((l last-give-instructions)
                                (msg (if (and l
                                              (equal? (car l) response-target)
                                              (< (- (current-seconds) (cdr l)) 120))
                                       msg*
                                       msg)))
                           (set! last-give-instructions
                                 (cons response-target (current-seconds)))
                           (pm response-target
                               "~a: ~a ~a" give-to for-whom msg))))
                     #t])) ; said something
            (define (display-output name output-getter)
              (let ([output (output-getter s)])
                (and (string? output) (positive? (string-length output))
                     (begin (reply "; ~a: ~s" name output) (sleep 1) #t))))
            (unless (some
                     (list
                      (display-values/give)
                      (display-output 'stdout sandbox-get-stdout)
                      (display-output 'stderr sandbox-get-stderr)))
              (reply "Done."))))))))

(defverb #:whine (init ?lang)
  "initialize a sandbox, <lang> can be 'r5rs, 'scheme, 'scheme/base, etc"
  (when ?lang
    (userinfo-set! (*for-whom*) 'sandbox-lang
                   (if (regexp-match? #rx"^http://" ?lang)
                     ?lang (string->symbol ?lang))))
  (get-sandbox #t))
(defverb #:whine (eval expr ...) "evaluate an expression(s)"
  (do-eval expr #f))
(defverb #:whine (give to expr ...) "evaluate and give someone the result"
  (do-eval expr to))

(defautoloads
  [net/uri-codec uri-encode]
  [setup/private/path-utils path->name]
  [setup/xref load-collections-xref]
  [setup/dirs find-doc-dir]
  [scribble/xref xref-binding->definition-tag xref-tag->path+anchor
                 xref-index entry-desc])
;; these cannot be autoloaded, since it leads to some problem with errortrace
(require (only-in scribble/manual-struct
                  exported-index-desc? exported-index-desc-name
                  exported-index-desc-from-libs))

(define (binding-info id-str)
  (call-in-sandbox-context (sandbox-evaluator (get-sandbox))
    (lambda ()
      (let* ([sym (string->symbol id-str)]
             [id  (namespace-symbol->identifier sym)])
        (values sym id (identifier-binding id))))))

;; Based on Eli's interactive library
(defverb #:whine (apropos str ...) "look for a binding"
  (if (null? str)
    (reply "give me something to look for")
    (let* ([arg (map (compose regexp regexp-quote) str)]
           [arg (lambda (str)
                  (andmap (lambda (rx) (regexp-match? rx str)) arg))]
           [syms (namespace-mapped-symbols
                  (call-in-sandbox-context (sandbox-evaluator (get-sandbox))
                                           current-namespace))]
           [syms (filter-map (lambda (sym)
                               (let ([str (symbol->string sym)])
                                 (and (arg str) str)))
                             syms)]
           [syms (sort syms string<?)])
      (if (null? syms)
        (reply "no matches found")
        (reply "matches: ~a." (string-join syms ", "))))))

;; Based on Eli's interactive library
(defverb #:whine (desc id) "describe an identifier"
  (define-values (sym identifier info) (binding-info id))
  (cond
    [(not info) (reply "`~s' is a toplevel (or unbound) identifier" sym)]
    [(eq? info 'lexical) (reply "`~s' is a lexical identifier" sym)]
    [(or (not (list? info)) (not (= 7 (length info))))
     (error "internal error, racket changed on me")]
    [else
     (let-values ([(source-mod source-id
                    nominal-source-mod nominal-source-id
                    source-phase import-phase
                    nominal-export-phase)
                   (apply values info)])
       (define (mpi* mpi)
         (let ([p (resolved-module-path-name
                   (module-path-index-resolve mpi))])
           (if (path? p) (path->name p) p)))
       (let ([source-mod (mpi* source-mod)]
             [nominal-source-mod (mpi* nominal-source-mod)])
         (reply
          "~a"
          (string-append*
           `("`",id"' is a bound identifier,"
             " defined"
             ,(case source-phase
                [(0) ""] [(1) "-for-syntax"] [else (error "internal error")])
             " in \"",(format "~a" source-mod)"\""
             ,(if (not (eq? sym source-id))
                (format " as `~s'" source-id)
                "")
             " required"
             ,(case import-phase
                [(0) ""] [(1) "-for-syntax"] [else (error "internal error")])
             " "
             ,(if (equal? source-mod nominal-source-mod)
                "directly"
                (format "through \"~a\"~a"
                        nominal-source-mod
                        (if (not (eq? sym nominal-source-id))
                          (format " where it is defined as `~s'"
                                  nominal-source-id)
                          "")))
             ,(case nominal-export-phase
                [(0) ""] [(1) (format ", (exported-for-syntax)")]
                [else (error "internal error")]))))))]))

;; Based on help/help-utils

(define remove-doc-dir
  (regexp (string-append "^" (regexp-quote (path->string (find-doc-dir))) "/")))
(define doc-url "http://docs.racket-lang.org/")
(defverb #:whine (doc id) "find documentation for a binding"
  (define-values (sym identifier info) (binding-info id))
  (define xref
    (load-collections-xref (lambda () (log "Loading help index..."))))
  (if info
    (let ([tag (xref-binding->definition-tag xref info 0)])
      (if tag
        (let*-values ([(file anchor) (xref-tag->path+anchor xref tag)]
                      [(file) (path->string file)]
                      [(m) (regexp-match-positions remove-doc-dir file)]
                      [(url) (and m (string-append
                                     doc-url
                                     (substring file (cdar m))))]
                      [(url) (cond [(and anchor url)
                                    (string-append url "#" (uri-encode anchor))]
                                   [url url]
                                   [else "??hidden??"])])
          (reply "~a" url))
        (error 'help
               "no documentation found for: ~e provided by: ~a"
               sym
               (module-path-index-resolve (caddr info)))))
    (search-for-exports xref sym)))

(define (search-for-exports xref sym)
  (let ([idx (xref-index xref)]
        [libs null])
    (for ([entry (in-list idx)])
      (when (and (exported-index-desc? (entry-desc entry))
                 (eq? sym (exported-index-desc-name (entry-desc entry))))
        (set! libs (append libs (exported-index-desc-from-libs
                                 (entry-desc entry))))))
    (if (null? libs)
      (reply "not found in any library's documentation: ~a" sym)
      (reply "no docs for a current binding, but provided by: ~a"
             (string-join (map symbol->string (remove-duplicates libs))
                          ", ")))))

;; ----------------------------------------------------------------------------
;; Master tools

(define *master-password* #f)
(defverb #:hidden (authenticate ?passwd) "request a passwd, or use one"
  (cond [(not ?passwd)
         (let ([passwd (random 1000000000)])
           (set! *master-password* (cons (current-seconds) passwd))
           (log "--->>> Temporary password: ~a <<<---" passwd)
           (pm (*for-whom*) "Check the logs."))]
        [(not *master-password*)
         (reply "No password set")]
        [(> (- (current-seconds) (car *master-password*)) 120)
         (reply "Too late, generate a new password")]
        [(not (equal? (string->number ?passwd) (cdr *master-password*)))
         ;; avoid brute force attacks however unlikely
         (set! *master-password* #f)
         (log "Bad authentication attempt!")
         (reply "Bad password, generate a new one now")]
        [else
         (set-box! *my-master* (*full-id*))
         ;; in case the password was uttered publicly, avoid hijacks it
         (set! *master-password* #f)
         (log "I am a mindless puppet")
         (reply "[bows deeply] Welcome, oh great master!")]))

(defverb #:master (join channel) "ask me to join a channel"
  (if (regexp-match? #rx"^#" channel)
    (begin (out "JOIN ~a" channel) (reply "OK"))
    (reply "not a proper channel name")))

(defverb #:master (part channel) "ask me to part from a channel"
  (if (regexp-match? #rx"^#" channel)
    (begin (out "PART ~a" channel) (reply "OK"))
    (reply "not a proper channel name")))

(defverb #:master (emote stuff ...) "tell me to do something"
  (pm (*response-target*) "\1ACTION ~a\1" (string-join stuff)))

(defverb (swat victim) "smite 'em"
  ;; You'd think I could just use "emote" here.  Nope, apparantly
  ;; that's not bound like a normal function.
  (pm (*response-target*) "\1ACTION waves his Palm of Slapping® threateningly at ~a\1" victim))

(defverb #:master (ghost victim) "kill an errant client that's using my favorite nick"
  (pm "NickServ" (format "ghost ~a ~a" victim (*nickserv-password*))))

(defverb #:master (nick new-nick) "tell me to rename myself"
  (out "NICK ~a" new-nick))

(defverb #:master (system command ...) "run something"
  (let ([s (open-output-string)])
    (parameterize ([current-output-port s] [current-error-port s])
      (call-with-PATH (lambda () (call/whine system (string-join command)))))
    (let* ([s (get-output-string s)]
           [s (regexp-replace #rx"^[ \r\n]+" s "")]
           [s (regexp-replace #rx"[ \r\n]+$" s "")]
           [s (regexp-replace* #rx" *[\r\n] *" s " <NL> ")])
      (reply "~a" (if (equal? s "") "OK" s)))))

(define-namespace-anchor anchor)
(define my-namespace (namespace-anchor->namespace anchor))
(defverb #:master (top-eval expr ...) "evaluate something in the sandbox"
  (call/whine
   (lambda ()
     (reply "~s"
            (eval (read (open-input-string
                         (string-append "(begin " (string-join expr) ")")))
                  my-namespace)))))

;; Handy for when I discover the bot has somehow lost its auth --
;; perhaps due to a netsplit
(defverb #:master (reauth) "Resend password to NickServ"
  ;; BUGBUG -- keep the password out of the log.
  (pm "NickServ" "identify ~a" (*nickserv-password*)))

;; ----------------------------------------------------------------------------
;; Incubot-like

(define (get-incubot-witticism words)
  (define incubot-witticism ((*incubot-server*) 'get (map string-downcase words)))
  (define (strip-just-one rx) (curryr (curry regexp-replace rx) ""))

  ;; Ideally we'd prevent ACTION from getting into the corpus in the
  ;; first place.  See https://github.com/offby1/rudybot/issues/14
  (define (trim-ACTION str)
    (regexp-replace #rx"\1ACTION (.*)\1" str "\\1"))

  (define (trim-leading-nick str)
    (if (regexp-match #px"^http(s)?://" str)
        str
        ((strip-just-one #px"^\\w+?: *") str)))

  (and (string? incubot-witticism)
       (lambda ()
         (reply "~a"
                (trim-ACTION
                 (trim-leading-nick incubot-witticism))))))

;; ----------------------------------------------------------------------------
;; Main dispatchers

(define (do-cmd response-target for-whom words #:rate_limit? [rate_limit? #f])
  (parameterize ([*for-whom* for-whom]
                 [*response-target* response-target])
    (if (and rate_limit? (we-recently-did-something-for for-whom))
      (log "Not doing anything for ~a, since we recently did something for them."
           for-whom)
      (let loop ([words words]
                 [verb (string->symbol (string-downcase (car words)))])
        (cond [(or (hash-ref verbs verb #f)
                   (and (is-master?) (hash-ref master-verbs verb #f)))
               => (lambda (p)
                    (log "Doing for ~a: ~a ~s" for-whom verb (cdr words))
                    (p (cdr words)))]
              [(roughly-evaluable? for-whom (text-from-word words))
               (loop (cons "eval" words) 'eval)]
              [(get-incubot-witticism words)
               => (lambda (p) (p))]
              [else (log "Not doing for ~a: ~a" for-whom (text-from-word words))
                    (reply "eh?  Try \"~a: help\"." (unbox *my-nick*))])
        (note-we-did-something-for! for-whom)))))

;; Maps a word to a (text . (start . end)) position in the original text
;; (store the text to avoid worrying about a global `*current-line*'
;; thing that can disappear)
(define word-posns (make-weak-hasheq))
;; Utility to get text from a word to the end (also accepts a list, and
;; will use the first word); `emergency' is some value to use in case we
;; don't find the text
(define (text-from-word w [emergency w])
  (cond [(pair? w) (text-from-word (car w) emergency)]
        [(not (string? w))
         (error 'text-from-word "Bad code, I have a bug -- got: ~s" w)]
        [else (cond [(hash-ref word-posns w #f)
                     => (lambda (p) (substring (car p) (cadr p)))]
                    [(string? emergency) emergency]
                    [(list? emergency) (string-join emergency " ")]
                    [else (format "~a" emergency)])]))
;; Sometimes we need to take a substring of a word -- so use this to
;; register its info too
(define (substring+posn str b [e (string-length str)])
  (let ([p (hash-ref word-posns str #f)]
        [r (substring str b e)])
    (when p
      (hash-set! word-posns r
                 (cons (car p) (cons (+ (cadr p) b) (+ (cadr p) e)))))
    r))

(define rx:word #px"(?:\\p{L}+|\\p{N}+|\\p{S}|\\p{P})+")
(define (irc-process-line line)
  (let* ([posns (regexp-match-positions* rx:word line)]
         [words (map (lambda (p)
                       (let ([s (substring line (car p) (cdr p))])
                         (hash-set! word-posns s (cons line p))
                         s))
                     posns)])
    (when (null? words) (log "BAD IRC LINE: ~a" line))
    (parameterize ([*current-words* (cdr words)])
      (domatchers IRC-COMMAND (car words)))))