~williewillus/r16

1cefcd4372c871cd701790f5524103a267ac67de — eutro 4 months ago 92bbc4f
Separate frontend and backend, improve internal error handling and add config
6 files changed, 875 insertions(+), 511 deletions(-)

A backend.rkt
A common.rkt
A config.rkt
A frontends/discord.rkt
A interface.rkt
M main.rkt
A backend.rkt => backend.rkt +178 -0
@@ 0,0 1,178 @@
#lang racket

(require "interface.rkt" "common.rkt"
         (prefix-in ev: "evaluator.rkt")
         (prefix-in db: "trick-db.rkt")
         threading)

(provide r16%)

(define r16%
  (class* object% [r16-backend<%>]
    (init-field db)
    (field [start-time (current-seconds)])

    (define (evaluation-context enrich-context context-id trick args parent-ctx)
      (define placeholder (make-placeholder #f))

      (define/contract (call-subtrick name arguments)
        (-> (or/c symbol? string?) any/c any)
        (define trick-obj (db:get-trick db context-id (~a name)))
        (if trick-obj
            (let ()
              (define rr
                (ev:run
                 (trick-body trick-obj)
                 (evaluation-context
                  enrich-context
                  context-id
                  trick-obj
                  (if arguments (~a arguments) "")
                  parent-ctx)
                 (const #t)))
              (write-string (ev:run-result-stdout rr))
              (cond [(ev:run-result-stderr rr)
                     => (lambda (stderr) (write-string stderr (current-error-port)))])
              (apply values (ev:run-result-results rr)))
            (raise (make-exn:fail:contract (~a "Trick " name " doesn't exist!")))))

      (define (read-args)
        (with-handlers ([exn:fail:read? #f])
          (sequence->list (in-producer read eof (open-input-string args)))))

      (define base
        `(((string-args    . ,args)
           (read-args      . ,read-args)
           (call-trick     . ,call-subtrick)
           (parent-context . ,parent-ctx))
          threading))
      (define new-context (enrich-context base trick args parent-ctx))
      (placeholder-set! placeholder (make-hash (car new-context)))
      (make-reader-graph new-context))

    (define (response? x)
      (send (current-frontend) response? x))

    (define/public (evaluate code)
      (define enrich-context (send (current-frontend) get-enrich-context))
      (define ev-ctx (evaluation-context enrich-context (current-context-id) #f "" #f))
      (ev:run code ev-ctx response?))

    (define/public (call name args)
      (define ctx-id (current-context-id))
      (define trick-obj (db:get-trick db ctx-id name))
      (cond
        [trick-obj
         (db:update-trick! db ctx-id name
                           (lambda (t)
                             (~> (trick-invocations t) add1
                                 (set-trick-invocations! t _))
                             t)
                           (const #t))
         (define enrich-context (send (current-frontend) get-enrich-context))
         (define ev-ctx (evaluation-context enrich-context (current-context-id) trick-obj args #f))
         (define code (trick-body trick-obj))
         (ev:run code ev-ctx response?)]
        [else
         (~a "Trick " name " doesn't exist!")]))

    (define/public (delete name)
      (define ctx-id (current-context-id))
      (define trick-obj (db:get-trick db ctx-id name))
      (define frontend (current-frontend))
      (cond
        [(not trick-obj)
         (~a "Trick " name " doesn't exist!")]
        [(db:remove-trick!
          db ctx-id name
          (lambda (t) (send frontend can-modify? t)))
         (~a "Successfully removed trick " name "!")]
        [else
         (~a "You cannot modify trick " name "!")]))

    (define/public (register name code author timestamp)
      (cond
        [(zero? (string-length code))
         (~a "Trick " name " needs a body!")]
        [(db:add-trick!
          db (current-context-id) name
          (thunk (trick author code timestamp (make-hash) 0)))
         (~a "Successfully registered trick " name "!")]
        [else (update name code)]))

    (define/public (update name code)
      (define ctx-id (current-context-id))
      (define trick-obj (db:get-trick db ctx-id name))
      (define frontend (current-frontend))
      (cond
        [(not trick-obj)
         (~a "Trick " name " doesn't exist!")]
        [(zero? (string-length code))
         (~a "Trick " name " needs a body!")]
        [(db:update-trick!
          db ctx-id name
          (lambda (trick-obj)
            (trick (trick-author trick-obj)
                   code
                   (trick-created trick-obj)
                   (trick-storage trick-obj)
                   (trick-invocations trick-obj)))
          (lambda (t)
            (send frontend can-modify? t)))
         (~a "Successfully updated trick " name "!")]))

    (define/public (lookup name)
      (db:get-trick db (current-context-id) name))

    (define/public (popular)
      (sort (db:all-tricks db (current-context-id)) cmp-tricks))

    (define/public (save)
      (with-handlers ([exn:fail? identity])
        (if (db:commit-db! db trick->json)
            'success
            'unchanged)))

    (define/public (about)
      (string-join
       `("R16 -- A Racket Trick Bot"
         ,(~a "Running on Racket " (version))
         "Brought to you by williewillus, Alwinfy, and Eutro"
         "Project Homepage: https://sr.ht/~williewillus/r16")
       "\n"))

    (define/public (stats)
      (define all-tricks (db:all-tricks db (current-context-id)))
      (define total-invocations
        (for/sum ([pair (in-list all-tricks)])
          (trick-invocations (cdr pair))))
      (string-join
       (list (~a "Uptime (dd:hh:mm:ss): " (uptime))
             (~a "Bytes in use: " (current-memory-use))
             (~a "Total trick invocations (for your guild): " total-invocations))
       "\n"))

    (define (uptime)
      (define seconds-in-minute 60)
      (define seconds-in-hour (* 60 60))
      (define seconds-in-day (* 24 60 60))
      (let*-values
          ([(v) (- (current-seconds) start-time)]
           [(days v) (quotient/remainder v seconds-in-day)]
           [(hours v) (quotient/remainder v seconds-in-hour)]
           [(minutes seconds) (quotient/remainder v seconds-in-minute)])
        (~>> (list days hours minutes seconds)
             (map (lambda (x)
                    (~a #:min-width 2
                        #:align 'right
                        #:pad-string "0"
                        x)))
             (string-join _ ":"))))

    (super-new)))

(define (cmp-tricks lt rt)
  (let ([l (cdr lt)] [r (cdr rt)])
    (if (= (trick-invocations l) (trick-invocations r))
        (string>? (trick-created l) (trick-created r))
        (> (trick-invocations l) (trick-invocations r)))))

A common.rkt => common.rkt +25 -0
@@ 0,0 1,25 @@
#lang racket

(provide (struct-out trick) json->trick trick->json)

(struct trick
  (author
   body
   created
   [storage #:mutable]
   [invocations #:mutable]))

(define (trick->json trick)
  (hasheq 'author (trick-author trick)
          'body (trick-body trick)
          'created (trick-created trick)
          'data (trick-storage trick)
          'invocations (trick-invocations trick)))

(define (json->trick json)
  (trick
   (hash-ref json 'author)
   (hash-ref json 'body)
   (hash-ref json 'created)
   (make-hash (hash->list (hash-ref json 'data #hash())))
   (hash-ref json 'invocations)))

A config.rkt => config.rkt +31 -0
@@ 0,0 1,31 @@
#lang racket

(provide config/c check-config)

(define-syntax-rule (config/c [key vpred] ...)
  (make-contract
   #:name '(config/c [key vpred] ...)
   #:first-order
   (lambda (x) (hash? x))
   #:projection
   (lambda (b)
     (compose
      (let ([check-val ((contract-projection vpred) b)])
        (lambda (x)
          (unless (hash? x)
            (raise-blame-error
             b x
             '(expected "hash?" given "~e")
             x))
          (unless (hash-has-key? x 'key)
            (raise-blame-error
             b x
             '(expected "hash with key ~e" given "~e")
             'key x)) ...
          (check-val (hash-ref x 'key))
          x)) ...))))

(define (check-config predicate config)
  (contract predicate config
            'config 'config
            'config #f))

A frontends/discord.rkt => frontends/discord.rkt +483 -0
@@ 0,0 1,483 @@
#lang racket

(require "../interface.rkt"
         "../log.rkt"
         "../common.rkt"
         "../config.rkt"
         (prefix-in rc: racket-cord)
         (prefix-in http: racket-cord/http)
         (prefix-in ev: "../evaluator.rkt")
         (only-in net/url get-pure-port string->url)
         threading)

(provide r16-make-frontend)

(define (message-from-bot? message)
  (and (hash-ref message 'author #f)
       (hash-ref (hash-ref message 'author) 'bot #f)))

(define (context-id message)
  (or (hash-ref message 'guild_id #f) (hash-ref message 'channel_id #f)))

(define (message-author-id message)
  (hash-ref (hash-ref message 'author) 'id))

(define discord-frontend%
  (class* object% [r16-frontend<%>]
    (init-field client)
    (init-field bot-prefix)
    (init-field trick-prefix)

    (define typing-thread
      (thread
       (thunk
        (let loop ([data #hash()])
          (match-let ([(list val client channel) (thread-receive)])
            (let* ([key (cons (hash-ref (rc:client-user client) 'id) channel)]
                   [newval (+ val (hash-ref data key 0))])
              (unless (zero? newval)
                (with-handlers ([exn:fail? (const #f)]) (http:trigger-typing-indicator client channel)))
              (loop (hash-set data key newval))))))))

    (define deleter-thread
      (thread
       (thunk
        (let loop ()
          (match-let ([(cons client message) (thread-receive)])
            (with-handlers ([exn:fail:network? identity])
              (http:delete-message
               client
               (hash-ref message 'channel_id)
               (hash-ref message 'id)))
            (loop))))))

    (define emote-image-thread
      (thread
       (thunk
        (let loop ()
          (let ([message (thread-receive)])
            ; TODO this only uses PNG, racket-cord needs to expose an animated field on emoji
            (channel-put (cdr message)
                         (with-handlers ([exn:fail? (const #f)])
                           (~> (~a "https://cdn.discordapp.com/emojis/" (car message) ".png?v=1")
                               string->url
                               get-pure-port
                               port->bytes))))
          (loop)))))

    (define current-message (make-parameter #f))

    (define (format-run-result rr)
      `(,(ev:run-result-stdout rr)
        ,@(ev:run-result-results rr)
        ,@(let ([stderr (ev:run-result-stderr rr)])
            (if stderr
                (list (string-append "\n:warning: stderr:\n" stderr))
                null))))

    (define/public (response? v)
      (http:attachment? v))

    (define/public (can-modify? trick-obj)
      (define author-id (message-author-id (current-message)))
      (define perms (bitwise-ior rc:permission-administrator
                                 rc:permission-manage-guild))
      (or
       (equal? (trick-author trick-obj) author-id)
       (and~> (current-message)
              (hash-ref _ 'member)
              (hash-ref _ 'permissions)
              string->number
              (bitwise-and perms)
              ((negate zero?)))))

    ; emote name -> emote id
    (define emote-lookup-cache (make-hash))

    ; set of emote ids known by the bot
    (define known-emotes (mutable-set))

    ; emote id -> bytes
    (define emote-image-cache (make-hash))

    (define/public (get-enrich-context)
      (define message (current-message))
      (define message-contents (hash-ref message 'content))
      (define message-author (message-author-id message))

      (define/contract (emote-image id)
        (-> string? (or/c bytes? #f))
        (hash-ref!
         emote-image-cache
         id
         (thunk
          (and 
           ; Is this an emote that this bot has encountered?
           ; If not, don't bother requesting it and just return #f
           (set-member? known-emotes id)
           (let ([ch (make-channel)])
             (thread-send emote-image-thread (cons id ch))
             (let ([data (channel-get ch)])
               ; If empty byte string returned, return #f
               (and data (positive? (bytes-length data)) data)))))))

      (define/contract (make-attachment data name type)
        (-> bytes? (or/c string? bytes?) (or/c symbol? string? bytes?) http:attachment?)
        (http:attachment data (~a type) name))

      (define (storage-info type)
        (match type
          ['guild   (cons 65536 'global)]
          ['channel (cons 8192  (string->symbol (hash-ref message 'channel_id)))]
          ['user    (cons 2048  (string->symbol (message-author-id message)))]
          [_        (cons 0     #f)]))

      (define/contract ((read-storage trick) type)
        (-> (or/c trick? #f) (-> (or/c 'guild 'channel 'user) any/c))
        (let ([datum (and~> trick
                            trick-storage
                            (hash-ref (cdr (storage-info type)) #f)
                            (with-input-from-string read)
                            (with-handlers ([exn:fail:read? (const #f)]) _))])
          (and (not (eof-object? datum)) datum)))
      (define/contract ((write-storage trick) type data)
        (-> (or/c trick? #f) (-> (or/c 'guild 'channel 'user) any/c boolean?))
        (and
         trick
         (match-let ([(cons limit key) (storage-info type)])
           (and
            key
            (let ([data (with-output-to-string (curry write data))])
              (and
               (<= (string-length data) limit)
               (begin
                 (hash-set! (trick-storage trick) key data)
                 #t)))))))

      (define (delete-caller)
        (thread-send deleter-thread (cons client message)))

      (lambda (base trick-obj _args _parent-context)
        `(((message-contents . ,message-contents)
           (message-author   . ,message-author)
           (emote-lookup     . ,(curry hash-ref emote-lookup-cache))
           (emote-image      . ,emote-image)
           (delete-caller    . ,delete-caller)
           (make-attachment  . ,make-attachment)
           (read-storage     . ,(read-storage trick-obj))
           (write-storage    . ,(write-storage trick-obj))
           (attachment-data  . ,http:attachment-data)
           ,@(car base))
          ,@(cdr base))))

    (define/public (start)
      (define discord-receiver (make-log-receiver rc:discord-logger 'debug))
      (define r16-receiver (make-log-receiver r16-logger 'debug))
      (~>
       (let loop ()
         (let ([v (sync discord-receiver r16-receiver)])
           (printf "[~a] ~a\n"
                   (vector-ref v 0)
                   (vector-ref v 1)))
         (loop))
       thunk thread)
      (~>
       (let loop ()
        (sleep 30)
        (define result (send (current-backend) save))
        (when (exn:fail? result)
          (log-r16-error (~a "Error saving tricks: " result)))
        (loop))
       thunk thread)
      (rc:on-event 'raw-message-create client message-received)
      (rc:on-event 'raw-guild-create client guild-create)
      (rc:start-client client))

    (define (guild-create _ws-client _client guild)
      ; eagerly fill all the emote mappings for each guild, so we don't need to touch the
      ; network when tricks call emote-id
      (let ([known (mutable-set)])
        (for ([emote (in-list (hash-ref guild 'emojis null))])
          (hash-set! emote-lookup-cache (hash-ref emote 'name) (hash-ref emote 'id))
          (set-add! known (hash-ref emote 'id)))
        (set-union! known-emotes known)
        (log-r16-debug "Preloaded ~a emote ID's" (set-count known))))

    (define (message-received _ws-client _client message)
      (parameterize ([current-message message]
                     [current-context-id (context-id message)])
        (define content (string-trim (hash-ref message 'content)))
        (define channel (hash-ref message 'channel_id))
        (unless (message-from-bot? message)
          (match-let ([(cons func content) (parse-command content)])
            (when func
              (create-message-with-contents
               channel
               message
               (with-handlers
                 ([exn?
                   (lambda (e)
                     (define port (open-output-string))
                     (parameterize ([current-error-port port])
                       ((error-display-handler) (exn-message e) e))
                     (define error-message (get-output-string port))
                     (log-r16-error (~a "Internal error:\n" error-message))
                     (list (~a ":warning: Internal error:\n" error-message)))])
                 (func content))))))))

    (define (create-message-with-contents channel message contents)
      (define char-cap 2000)
      (define slice-size 30)

      (define (truncate-string str cap)
        (define len (string-length str))
        (if (> len cap)
            (let* ([slicepos (- cap slice-size)] [restsize (- len slicepos)])
              (format "~a... [~a more characters]" (substring str 0 slicepos) restsize))
            str))

      (define raw-content (string-trim (apply ~a #:separator "\n" (filter string? contents))))
      (define attachment (findf http:attachment? contents))
      (define content
        (if (or attachment (non-empty-string? raw-content))
            (truncate-string raw-content char-cap)
            "\u200b"))
      (define reference (hash 'message_id (hash-ref message 'id)))

      (http:create-message client channel content
                           #:file attachment
                           #:reply-to reference
                           #:allowed-mentions (hash 'parse '())))

    (define (with-typing-indicator thunk)
      (let ([payload (list client (hash-ref (current-message) 'channel_id))])
        (thread-send typing-thread (cons 1 payload))
        (let ([result (call-with-values thunk list)])
          (thread-send typing-thread (cons -1 payload))
          (apply values result))))

    (define parse-command
      (let ()
        (define (split-once str)
          (let ([index (index-where (string->list str) char-whitespace?)])
            (if index
                (values (substring str 0 index) (string-trim (substring str index)))
                (values str ""))))

        (define-syntax-rule (check-trick-prereqs
                             [(name-out body-out) text]
                             body ...)
          (let-values ([(name-out body-out) (split-once text)])
            (cond
              [(non-empty-string? name-out)
               body ...]
              [else
               (list (~a "Missing the name for the trick!"))])))

        (struct command (func help)
          #:property prop:procedure (struct-field-index func))
        (define-syntax-rule (define/command (name text)
                              help
                              body ...)
          (define name (command (lambda (text) body ...) help)))

        (define-syntax-rule (define/command/trick (name name-binding
                                                        body-binding)
                              help
                              body ...)
          (define/command (name text)
            help
            (check-trick-prereqs
             [(name-binding body-binding) text]
             body ...)))

        (define (strip-backticks code)
          (let ([groups (regexp-match #px"```(\\w+\n)?(.+)```|`(.+)`" code)])
            (if groups
                (or (third groups) (fourth groups))
                code)))

        (define (codeblock-quote result)
          (~a "```scheme\n" result "```"))

        (define/command (call-snippet text)
          " [_code_]:  evaluate [_code_] as a Racket form"
          (with-typing-indicator
            (thunk
             (define result
               (send (current-backend) evaluate (strip-backticks text)))
             (if (ev:run-result? result)
                 (format-run-result result)
                 (list result)))))

        (define/command/trick (call-trick name body)
          " [_name_] ...:  invoke the trick [_name_], evaluating its source code in a fresh sandbox"
          (with-typing-indicator
            (thunk
             (define result
               (send (current-backend) call name body))
             (if (ev:run-result? result)
                 (format-run-result result)
                 (list result)))))

        (define/command/trick (register-trick name body)
          " [_name_] [_code_]:  register [_code_] as a trick with name [_name_]"
          (list
           (send (current-backend) register
                 name (strip-backticks body)
                 (message-author-id (current-message))
                 (hash-ref (current-message) 'timestamp))))

        (define/command/trick (show-trick name _body)
          " [_name_]:  show metadata and source for the trick [_name_]"
          (define trick-obj (send (current-backend) lookup name))
          (list
           (if trick-obj
               (format
                (~a
                 #:separator "\n"
                 "Trick **~a**, created by <@~a>, has been invoked `~a` times."
                 "__Source code:__"
                 "~a")
                name
                (trick-author trick-obj)
                (trick-invocations trick-obj)
                (codeblock-quote (trick-body trick-obj)))
               (~a "Trick " name " doesn't exist!"))))

        (define/command/trick (update-trick name body)
          " [_name_] [_code_]:  change the source of the trick [_name_]; requires ownership or administrator"
          (list (send (current-backend) update name (strip-backticks body))))

        (define/command/trick (delete-trick name _body)
          " [_name_]:  delete the trick [_name_]; requires ownership or administrator and cannot be undone!"
          (list (send (current-backend) delete name)))

        (define/command (popular text)
          ":  show a leaderboard of popular tricks"
          (define leaderboard-size 10)
          (define tricks (send (current-backend) popular))
          (define pages (exact-ceiling (/ (length tricks) leaderboard-size)))
          (define pageno
            (~> text (string->number 10 'number-or-false) (or 1)
                inexact->exact (max 1) (min pages) sub1))
          (define page (drop tricks (* leaderboard-size pageno)))
          (list
           (if (empty? tricks)
               (~a "There aren't any tricks registered in your guild! \
                    Use `" bot-prefix "register` to create one.")
               (apply
                ~a "**Most popular tricks in your guild (page " (add1 pageno) " of " pages "):**"
                (for/list ([i (in-naturals (add1 (* leaderboard-size pageno)))]
                           [trick
                            (if (> (length page) leaderboard-size)
                                (take page leaderboard-size)
                                page)])
                  (~a
                   "\n" i ". **" (car trick) "**, by <@" (trick-author (cdr trick))
                   ">, invoked **" (trick-invocations (cdr trick)) "**x"))))))

        (define/command (about _text)
          ":  show version info"
          (list (send (current-backend) about)))

        (define/command (help _text)
          ":  show this message"
          (list help-message))

        (define/command (stats _text)
          ":  show operational stats"
          (list (send (current-backend) stats)))

        (define (save _text)
          (list
           (match (send (current-backend) save)
             ['success "Saved"]
             ['unchanged "Nothing to save"]
             [e (~a "Error saving tricks: " e)])))

        (define command-table
          (hash
           "eval" call-snippet
           "call" call-trick

           "register" register-trick
           "show" show-trick
           "update" update-trick
           "delete" delete-trick

           "popular" popular
           "about" about
           "help" help
           "stats" stats

           ;; hidden
           "save" save))

        (define (format-command-help name)
          (define command (hash-ref command-table name))
          (format "~a**~a**~a" bot-prefix name (command-help command)))

        (define help-message
          (~>
           `("Commands:"
             ,(format-command-help "eval")
             ,(format-command-help "call")
             ,(format "~a[_trickname_]: shorthand for ~acall [_trickname_]"
                      trick-prefix bot-prefix)
             ""
             ,(format-command-help "register")
             ,(format-command-help "show")
             ,(format-command-help "update")
             ,(format-command-help "delete")
             ""
             ,(format-command-help "popular")
             ,(format-command-help "about")
             ,(format-command-help "help")
             ,(format-command-help "stats")
             ""
             "For documentation on what is available in the trick environment, please see the R16 documentation:"
             "https://docs.racket-lang.org/r16/index.html")
           (string-join "\n")))

        (define (strip-trim msg prefix)
          (string-trim (substring msg (string-length prefix))))

        (define (parse-command content)
          (cond
            ; if trick-prefix, return (call-trick rest)
            [(string-prefix? content trick-prefix)
             (cons call-trick (strip-trim content trick-prefix))]
            ; if prefix, find the command or fall through
            [(and
              (string-prefix? content bot-prefix)
              (let ()
                (define-values (command args)
                  (split-once (strip-trim content bot-prefix)))
                (define found (hash-ref command-table command #f))
                (and found (cons found (string-trim args)))))]
            ; return falsey value for func
            [else (cons #f content)]))

        parse-command))

    (super-new)))

(define discord-config?
  (config/c
   [bot_token string?]))

(define (r16-make-frontend raw-config)
  (define config (check-config discord-config? raw-config))
  (define token (hash-ref config 'bot_token))
  (define bot-prefix (hash-ref config 'bot_prefix "!rkt "))
  (define trick-prefix (hash-ref config 'trick_prefix "!!"))
  (define client
    (rc:make-client
     token
     #:auto-shard #t
     #:intents (list rc:intent-guilds rc:intent-guild-messages)))
  (new discord-frontend%
       [client client]
       [bot-prefix bot-prefix]
       [trick-prefix trick-prefix]))

A interface.rkt => interface.rkt +86 -0
@@ 0,0 1,86 @@
#lang racket

(require (only-in "evaluator.rkt" definitions? run-result?)
         threading
         "common.rkt")

(provide r16-backend? r16-frontend?
         r16-backend<%> r16-frontend<%>
         current-backend current-frontend
         current-context-id)

;; an r16 frontend
(define r16-frontend<%>
  (interface ()
    ;; get whether a value should be passed out of the sandbox
    [response?          (->m any/c boolean?)]

    ;; get a function that introduces new bindings to the base sandbox definitions
    ;;
    ;; this function may be called repeatedly within the sandbox,
    ;; so use this to initialise any state,
    ;; and to close over any parameters
    [get-enrich-context (->m (-> #;base definitions?
                                 #;trick (or/c trick? #f)
                                 #;args string?
                                 #;parent-ctx (or/c definitions? #f)
                                 definitions?))]

    ;; get whether there are sufficient permissions to modify a trick
    [can-modify?        (->m trick? boolean?)]

    ;; start this frontend
    [start (->m any)]))

;; the r16 backend
(define r16-backend<%>
  (interface ()
    ;; evaluate a code snippet, returning either an error message or a run result
    [evaluate (#;code string? . ->m . (or/c string? run-result?))]

    ;; call a trick with arguments, returning either an error message or a run result
    [call     (#;trick string? #;args string? . ->m . (or/c string? run-result?))]

    ;; delete a trick, returning an error or success message
    [delete   (#;trick string? . ->m . string?)]

    ;; register a trick, returning an error or success message
    [register (#;trick string? #;code string?
               #;author string? #;timestamp string?
               . ->m . string?)]

    ;; update a trick, returning an error or success message
    [update   (#;trick string? #;code string? . ->m . string?)]

    ;; look up a trick by name
    [lookup   (#;trick string? . ->m . (or/c trick? #f))]

    ;; list the registered tricks, sorted by invocation count
    [popular  (->m (listof (cons/c string? trick?)))]

    ;; save the database, returning the status
    [save     (->m (or/c 'success 'unchanged exn:fail?))]

    ;; get version info
    [about    (->m string?)]

    ;; get operational stats
    [stats    (->m string?)]))

(define (r16-frontend? x)
  (is-a? x r16-frontend<%>))

(define (r16-backend? x)
  (is-a? x r16-backend<%>))

(define/contract current-frontend
  (parameter/c (or/c r16-frontend? #f))
  (make-parameter #f))

(define/contract current-backend
  (parameter/c (or/c r16-backend? #f))
  (make-parameter #f))

(define/contract current-context-id
  (parameter/c string?)
  (make-parameter "anonymous"))

M main.rkt => main.rkt +72 -511
@@ 1,521 1,82 @@
#!/usr/bin/env racket
#lang racket

(require
 (prefix-in rc: racket-cord)
 (prefix-in http: racket-cord/http)
 (prefix-in db: "trick-db.rkt")

 (prefix-in ev: "evaluator.rkt")
 "log.rkt"
 (only-in net/url get-pure-port string->url)
 json
 threading)

(define prefix "!rkt ")
(define trick-prefix "!!")
(define leaderboard-size 10)
(define start-time 0)

(define (strip-trim msg prefix)
  (string-trim (substring msg (string-length prefix))))

(define (message-from-bot? message)
  (and (hash-ref message 'author #f)
       (hash-ref (hash-ref message 'author) 'bot #f)))

(define (context-id message)
  (or (hash-ref message 'guild_id #f) (hash-ref message 'channel_id #f)))

(define (message-author-id message)
  (hash-ref (hash-ref message 'author) 'id))

(struct trick
  (author
   body
   created
   [storage #:mutable]
   [invocations #:mutable]))

(define (can-modify? message trick)
  (let ([author-id (message-author-id message)]
        [perms (bitwise-ior rc:permission-administrator
                            rc:permission-manage-guild)])
    (or
     (equal? (trick-author trick) author-id)
     (let ([memb (hash-ref message 'member)])
       (and~> memb
              (hash-ref _ 'permissions)
              string->number
              (bitwise-and perms)
              ((negate zero?)))))))

(define (strip-backticks code)
  (let ([groups (regexp-match #px"```(\\w+\n)?(.+)```|`(.+)`" code)])
    (if groups
        (or (third groups) (fourth groups))
        code)))

(define (codeblock-quote result)
  (~a "```scheme\n" result "```"))

(define (split-once str)
  (let ([index (index-where (string->list str) char-whitespace?)])
    (if index
        (values (substring str 0 index) (string-trim (substring str index)))
        (values str #f))))

(define-syntax-rule (check-trick-prereqs message text context-out name-out body-out body)
  (let ([context-out (context-id message)])
    (let-values ([(name-out body-out) (split-once text)])
      (if (non-empty-string? name-out)
          body
          (~a "Missing the name for the trick!")))))

(define deleter-thread
  (thread
   (thunk (let loop ()
            (match-let ([(cons client message) (thread-receive)])
              (with-handlers ([exn:fail:network? identity])
                (http:delete-message
                 client
                 (hash-ref message 'channel_id)
                 (hash-ref message 'id)))
              (loop))))))

(define typing-thread
  (thread
   (thunk
    (let loop ([data #hash()])
      (match-let ([(list val client channel) (thread-receive)])
        (let* ([key (cons (hash-ref (rc:client-user client) 'id) channel)]
               [newval (+ val (hash-ref data key 0))])
          (unless (zero? newval)
            (with-handlers ([exn:fail? (const #f)]) (http:trigger-typing-indicator client channel)))
          (loop (hash-set data key newval))))))))

(define (with-typing-indicator client message thunk)
  (let ([payload (list client (hash-ref message 'channel_id))])
    (thread-send typing-thread (cons 1 payload))
    (let ([result (call-with-values thunk list)])
      (thread-send typing-thread (cons -1 payload))
      (apply values result))))


(define (make-trick body message parent)
  (trick (if parent (trick-author parent) (message-author-id message))
         (strip-backticks body)
         (if parent (trick-created parent) (hash-ref message 'timestamp))
         (if parent (trick-storage parent) (make-hash))
         (if parent (trick-invocations parent) 0)))

(define (format-run-result rr)
  (apply values
         `(,(ev:run-result-stdout rr)
           ,@(ev:run-result-results rr)
           ,@(let ([stderr (ev:run-result-stderr rr)])
               (if stderr
                   (list (string-append "\n:warning: stderr:\n" stderr))
                   null)))))

(define (run-snippet client db message code)
  (let ([code (strip-backticks code)])
    (with-typing-indicator client message
      (thunk
       (format-run-result
        (ev:run code (evaluation-ctx #f client message db (context-id message) "" #f) http:attachment?))))))

(define (register-trick client db message text)
  (check-trick-prereqs
   message text
   context-id name body
   (cond
     [(not body) (~a "Trick " name " needs a body!")]
     [(db:add-trick! db context-id name (thunk (make-trick body message #f)))
      (~a "Successfully registered trick " name "!")]
     [else (update-trick client db message text)])))

(define (call-trick client db message text)
  (check-trick-prereqs
   message text
   context-id name body
   (let ([trick (db:get-trick db context-id name)])
     (if trick
         (begin
           (db:update-trick! db context-id name
                             (lambda (t) (set-trick-invocations! t (add1 (trick-invocations t))) t)
                             (const #t))
           (with-typing-indicator client message
             (thunk
              (format-run-result
               (ev:run
                (trick-body trick)
                (evaluation-ctx
                 trick
                 client
                 message
                 db
                 context-id
                 (or body "")
                 #f)
                http:attachment?)))))
         (~a "Trick " name " doesn't exist!")))))

(define (update-trick client db message text)
  (check-trick-prereqs
   message text
   context-id name body
   (cond
     [(not body) (~a "Trick " name " needs a body!")]
     [(db:update-trick! db context-id name (curry make-trick body message) (curry can-modify? message))
      (~a "Successfully updated trick " name "!")]
     [else (~a "Trick " name " doesn't exist, or you can't modify it!")])))

(define (delete-trick client db message text)
  (check-trick-prereqs
   message text
   context-id name _
   (if (db:remove-trick! db context-id name (curry can-modify? message))
       (~a "Successfully removed trick " name "!")
       (~a "Trick " name " doesn't exist, or you can't remove it!"))))

(define (uptime)
  (define seconds-in-minute 60)
  (define seconds-in-hour (* 60 60))
  (define seconds-in-day (* 24 60 60))
  (let*-values ([(v) (- (current-seconds) start-time)]
                [(days v) (quotient/remainder v seconds-in-day)]
                [(hours v) (quotient/remainder v seconds-in-hour)]
                [(minutes seconds) (quotient/remainder v seconds-in-minute)])
    (~>> (list days hours minutes seconds)
         (map (lambda (x) (~a #:min-width 2 #:align 'right #:pad-string "0" x)))
         (string-join _ ":"))))

(define (stats client db message text)
  (string-join
   (list (~a "Uptime (dd:hh:mm:ss): " (uptime))
         (~a "Bytes in use: " (current-memory-use))
         (~a "Total trick invocations (for your guild): "
             (for/sum ([pair (in-list (db:all-tricks db (context-id message)))])
               (trick-invocations (cdr pair)))))
   "\n"))

(define (cmp-tricks lt rt)
  (let ([l (cdr lt)] [r (cdr rt)])
    (if (= (trick-invocations l) (trick-invocations r))
        (string>? (trick-created l) (trick-created r))
        (> (trick-invocations l) (trick-invocations r)))))

(define (popular-tricks client db message text)
  (let* ([tricks (sort (db:all-tricks db (context-id message)) cmp-tricks)]
         [pages  (exact-ceiling (/ (length tricks) leaderboard-size))]
         [pageno (~> text (string->number 10 'number-or-false) (or 1) inexact->exact (max 1) (min pages) sub1)]
         [page   (drop tricks (* leaderboard-size pageno))])
    (if (empty? tricks)
        (~a "There aren't any tricks registered in your guild! Use `" prefix "register` to create one.")
        (apply ~a "**Most popular tricks in your guild (page " (add1 pageno) " of " pages "):**"
               (for/list ([i (in-naturals (add1 (* leaderboard-size pageno)))]
                          [trick
                            (if (> (length page) leaderboard-size)
                                (take page leaderboard-size)
                                page)])
                 (~a
                  "\n" i ". **" (car trick) "**, by <@" (trick-author (cdr trick))
                  ">, invoked **" (trick-invocations (cdr trick)) "**x"))))))

(define (show-trick client db message text)
  (check-trick-prereqs
   message text
   context-id name _
   (let ([trick (db:get-trick db context-id name)])
     (if trick
         (~a
          "Trick **"
          name
          "**, created by <@"
          (trick-author trick)
          ">, has been invoked **`"
          (trick-invocations trick)
          "`** times.\n__Source code:__\n"
          (codeblock-quote (trick-body trick)))
         (~a "Trick " name " doesn't exist!")))))

(define about
  (string-join
   `("R16 -- A Racket Trick Bot for Discord"
     ,(~a "Running on Racket " (version))
     "Brought to you by williewillus, Alwinfy, and Eutro"
     "Project Homepage: https://sr.ht/~williewillus/r16")
   "\n"))

(define help
  (string-replace
   (string-join
    `("Commands:"
      "PREFIX**eval** [_code_]:  evaluate [_code_] as a Racket form"
      "PREFIX**call** [_name_] ...:  invoke the trick [_name_], evaluating its source code in a fresh sandbox"
      "!![_trickname_]:  shorthand for !rkt call [_trickname_]"
(require json threading
         "common.rkt"
         "backend.rkt"
         "interface.rkt"
         "config.rkt"
         (prefix-in db: "trick-db.rkt"))

(define (readable? x)
  (and (string? x)
       (with-handlers ([void (const #f)])
         (read (open-input-string x))
         #t)))

(define r16-config?
  (config/c
   [frontend
    (or/c readable?
          (config/c
           [module readable?]))]
   [storage path-string?]))

(define help-string
  (~a #:separator "\n"
      "Options available:"
      "  -h"
      "  --help                  Show this message"
      ""
      "PREFIX**register** [_name_] [_code_]:  register [_code_] as a trick with name [_name_]"
      "PREFIX**show** [_name_]:  show metadata and source for the trick [_name_]"
      "PREFIX**update** [_name_] [_code_]:  change the source of the trick [_name_]; requires ownership or administrator"
      "PREFIX**delete** [_name_]:  delete the trick [_name_]; requires ownership or administrator and cannot be undone!"
      "  -c [config]"
      "  --config [config]       Read the config from [config]"
      ""
      "PREFIX**popular**:  show a leaderboard of popular tricks"
      "PREFIX**about**:  show version info"
      "PREFIX**help**:  show this message"
      "PREFIX**stats**:  show operational stats"
      ""
      "For documentation on what is available in the trick environment, please see the R16 documentation:"
      "https://docs.racket-lang.org/r16/index.html")
    "\n")
   "PREFIX" prefix))

(define/contract (make-attachment data name type)
  (-> bytes? (or/c string? bytes?) (or/c symbol? string? bytes?) http:attachment?)
  (http:attachment data (~a type) name))

(define/contract ((call-subtrick client db context-id message parent-ctx) name arguments)
  (-> rc:client? db:trickdb? string? jsexpr? any/c (-> (or/c symbol? string?) any/c any))
  (let ([trick (db:get-trick db context-id (~a name))])
    (if trick
        (let ()
          (define rr
            (ev:run
             (trick-body trick)
             (evaluation-ctx
              trick
              client
              message
              db
              context-id
              (if arguments (~a arguments) "")
              parent-ctx)
             (const #t)))
          (write-string (ev:run-result-stdout rr))
          (cond [(ev:run-result-stderr rr)
                 => (lambda (stderr) (write-string stderr (current-error-port)))])
          (apply values (ev:run-result-results rr)))
        (raise (make-exn:fail:contract (~a "Trick " name " doesn't exist!"))))))

(define (storage-info message type)
  (match type
    ['guild   (cons 65536 'global)]
    ['channel (cons 8192  (string->symbol (hash-ref message 'channel_id)))]
    ['user    (cons 2048  (string->symbol (message-author-id message)))]
    [_        (cons 0     #f)]))

(define/contract (read-storage trick message type)
  (-> (or/c trick? #f) jsexpr? (or/c 'guild 'channel 'user) any/c)
  (let ([datum (and~> trick
                      trick-storage
                      (hash-ref (cdr (storage-info message type)) #f)
                      (with-input-from-string read)
                      (with-handlers ([exn:fail:read? (const #f)]) _))])
    (and (not (eof-object? datum)) datum)))
(define/contract (write-storage trick message type data)
  (-> (or/c trick? #f) jsexpr? (or/c 'guild 'channel 'user) any/c boolean?)
  (and
   trick
   (match-let ([(cons limit key) (storage-info message type)])
     (and
      key
      (let ([data (with-output-to-string (curry write data))])
        (and
         (<= (string-length data) limit)
         (begin
           (hash-set! (trick-storage trick) key data)
           #t)))))))

; emote name -> emote id
(define emote-lookup-cache (make-hash))

; set of emote ids known by the bot
(define known-emotes (mutable-set))

; emote id -> bytes
(define emote-image-cache (make-hash))
(define emote-image-thread
  (thread
   (thunk
    (let loop ()
      (let ([message (thread-receive)])
        ; TODO this only uses PNG, racket-cord needs to expose an animated field on emoji
        (channel-put (cdr message)
                     (with-handlers ([exn:fail? (const #f)])
                       (~> (~a "https://cdn.discordapp.com/emojis/" (car message) ".png?v=1")
                           string->url
                           get-pure-port
                           port->bytes))))
      (loop)))))

(define/contract (emote-image id)
  (-> string? (or/c bytes? #f))
  (hash-ref!
   emote-image-cache
   id
   (thunk
    (and 
     ; Is this an emote that this bot has encountered?
     ; If not, don't bother requesting it and just return #f
     (set-member? known-emotes id)
     (let ([ch (make-channel)])
       (thread-send emote-image-thread (cons id ch))
       (let ([data (channel-get ch)])
         ; If empty byte string returned, return #f
         (and data (positive? (bytes-length data)) data)))))))

(define (evaluation-ctx trick client message db context-id args parent-ctx)
  (let* ([placeholder (make-placeholder #f)]
         [ctx
          `((message-contents . ,(hash-ref message 'content))
            (string-args      . ,args)
            (read-args        . ,(thunk
                                  (with-handlers ([exn:fail:read? #f])
                                    (let loop ([data (open-input-string args)])
                                      (let ([val (read data)])
                                        (if (eof-object? val) null (cons val (loop data))))))))
            (emote-lookup     . ,(curry hash-ref emote-lookup-cache))
            (emote-image      . ,emote-image)
            (delete-caller    . ,(thunk (thread-send deleter-thread (cons client message))))
            (make-attachment  . ,make-attachment)
            (attachment-data  . ,http:attachment-data)
            (call-trick       . ,(call-subtrick client db context-id message placeholder))
            (message-author   . ,(message-author-id message))
            (read-storage     . ,(curry read-storage trick message))
            (write-storage    . ,(curry write-storage trick message))
            (parent-context   . ,parent-ctx))])
    (placeholder-set! placeholder (make-hash ctx))
    (cons (make-reader-graph ctx) '(threading))))

(define (trick->json trick)
  (hasheq 'author (trick-author trick)
          'body (trick-body trick)
          'created (trick-created trick)
          'data (trick-storage trick)
          'invocations (trick-invocations trick)))

(define (json->trick json)
  (trick
   (hash-ref json 'author)
   (hash-ref json 'body)
   (hash-ref json 'created)
   (make-hash (hash->list (hash-ref json 'data #hash())))
   (hash-ref json 'invocations)))

(define command-table
  `(("about"    . ,(const about))
    ("call"     . ,call-trick)
    ("delete"   . ,delete-trick)
    ("eval"     . ,run-snippet)
    ("help"     . ,(const help))
    ("popular"  . ,popular-tricks)
    ("register" . ,register-trick)
    ("save"     . ,(lambda (_client db _msg _text)
                     (with-handlers ([exn:fail? (lambda (e)
                                                  (~a "Error saving tricks: " e))])
                       (if (db:commit-db! db trick->json)
                           "Saved"
                           "Nothing to save"))))
    ("show"     . ,show-trick)
    ("update"   . ,update-trick)
    ("stats"   . ,stats)))

(define (parse-command content)
  (cond
    ; If trick-prefix, return (call-trick rest)
    [(string-prefix? content trick-prefix)
     (cons call-trick (strip-trim content trick-prefix))]
    ; If prefix, find the command or fall through
    [(and
      (string-prefix? content prefix)
      (let ([content (strip-trim content prefix)])
        (ormap
         (lambda (pair)
           (match-let ([(cons cmdname func) pair])
             (and (string-prefix? content cmdname)
                  (cons func (strip-trim content cmdname)))))
         command-table)))]
    ; Return falsey value for func
    [else (cons #f content)]))

(define char-cap 2000)
(define slice-size 30)

(define (truncate-string str cap)
  (let ([len (string-length str)])
    (if (> len cap)
        (let* ([slicepos (- cap slice-size)] [restsize (- len slicepos)])
          (format "~a... [~a more characters]" (substring str 0 slicepos) restsize))
        str)))

(define ((create-message-with-contents client channel message) . contents)
  (let* ([content (apply ~a #:separator "\n" (filter string? contents))]
         [attachment (findf http:attachment? contents)]
         [content (if (or attachment (non-empty-string? content))
                      (truncate-string content char-cap)
                      "\u200b")]
         [reference (hash 'message_id (hash-ref message 'id))])
    (http:create-message client channel content
                         #:file attachment
                         #:reply-to reference
                         #:allowed-mentions (hash 'parse '()))))

(define ((message-received db) _ws-client client message)
  (let ([content (string-trim (hash-ref message 'content))]
        [channel (hash-ref message 'channel_id)])
    (unless (message-from-bot? message)
      (match-let ([(cons func content) (parse-command content)])
        (when func
          (call-with-values (thunk (func client db message content))
                            (create-message-with-contents client channel message)))))))

(define (guild-create _ws-client _client guild)
  ; eagerly fill all the emote mappings for each guild, so we don't need to touch the
  ; network when tricks call emote-id
  (let ([known (mutable-set)])
    (for ([emote (in-list (hash-ref guild 'emojis null))])
      (hash-set! emote-lookup-cache (hash-ref emote 'name) (hash-ref emote 'id))
      (set-add! known (hash-ref emote 'id)))
    (set-union! known-emotes known)
    (log-r16-debug "Preloaded ~a emote ID's" (set-count known))))

(define (init-client folder token)
  (log-r16-info "Storing tricks in ~a" folder)
  (let* ([client (rc:make-client token
                                 #:auto-shard #t
                                 #:intents (list rc:intent-guilds rc:intent-guild-messages))]
         [db     (db:make-trickdb folder json->trick)])
    (thread
     (thunk
      (let loop ()
        (sleep 30)
        (db:commit-db! db trick->json)
        (loop))))
    (rc:on-event 'raw-message-create client (message-received db))
    (rc:on-event 'raw-guild-create client guild-create)
    client))

(define (get-folder)
  (define argv (current-command-line-arguments))
  (if (< (vector-length argv) 1)
      (raise-user-error "Please pass the directory to be used to store trick data.")
      (vector-ref argv 0)))
      "  --                      Read the config from stdin"))

(define (get-config)
  (define json
    (match (current-command-line-arguments)
      [(vector "--") (read-json)]
      [(vector (or "-c" "--config") config-string)
       (call-with-input-string config-string read-json)]
      [(vector (or "-h" "--help")) (raise-user-error help-string)]
      [(vector path) (call-with-input-file* path read-json)]
      [(vector) (raise-user-error (~a "Please pass the config.\n" help-string))]
      [_ (raise-user-error (~a "Unrecognised options.\n" help-string))]))
  (contract r16-config? json
            'config 'config
            'config #f))

(define (make-frontend config)
  (define frontend-config (hash-ref config 'frontend))

  (define frontend-module-string
    (if (string? frontend-config)
        frontend-config
        (hash-ref frontend-config 'module)))

  (define frontend-module
    (with-input-from-string
      frontend-module-string
      read))

  (define make-frontend
    (~> (~a "Frontend " frontend-module " does not provide r16-make-frontend") raise-user-error thunk
        (dynamic-require frontend-module 'r16-make-frontend _)))

  ((contract (-> jsexpr? r16-frontend?) make-frontend
             frontend-module 'frontend
             'frontend #f)
   frontend-config))

(define (main)
  (define discord-receiver (make-log-receiver rc:discord-logger 'debug))
  (define r16-receiver (make-log-receiver r16-logger 'debug))
  (thread
   (thunk
    (let loop ()
      (let ([v (sync discord-receiver r16-receiver)])
        (printf "[~a] ~a\n"
                (vector-ref v 0)
                (vector-ref v 1)))
      (loop))))
  (set! start-time (current-seconds))
  (rc:start-client (init-client (get-folder)
                                (getenv "BOT_TOKEN"))))
  (define config (get-config))
  (define path (hash-ref config 'storage))
  (define db (db:make-trickdb path json->trick))

  (parameterize ([current-backend (new r16% [db db])]
                 [current-frontend (make-frontend config)])
    (send (current-frontend) start)))

(module* main #f
  (main))