eutro: 2 Add open-attachment More attachment-data work 7 files changed, 183 insertions(+), 117 deletions(-)
r16/patches/linux_buildtest.yml: SUCCESS in 1m53s [Add open-attachment][0] v2 from [eutro][1] [0]: https://lists.sr.ht/~williewillus/public-inbox/patches/25413 [1]: mailto:benedek.szilvasy@gmail.com ✓ #595665 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/595665
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~williewillus/public-inbox/patches/25413/mbox | git am -3Learn more about email & git
--- frontends/discord.rkt | 83 ++++++++++++++++++++++++++++--------------- info.rkt | 3 +- scribblings/r16.scrbl | 14 +++++++- 3 files changed, 69 insertions(+), 31 deletions(-) diff --git a/frontends/discord.rkt b/frontends/discord.rkt index 9923cbe..532217a 100644 --- a/frontends/discord.rkt +++ b/frontends/discord.rkt @@ -33,6 +33,13 @@ (define (message-author-id message) (hash-ref (hash-ref message 'author) 'id)) +(define-syntax-rule (thread-loop body ...) + (thread + (thunk + (let loop () + body ... + (loop))))) + (define discord-frontend% (class* object% [r16-frontend<%>] (init-field client) @@ -70,13 +77,10 @@ (http:trigger-typing-indicator client channel))) (define _typing-thread - (thread - (thunk - (let loop () - (for ([(channel _) (unbox counters-box)]) - (trigger-typing channel)) - (sleep 5) - (loop))))) + (thread-loop + (for ([(channel _) (unbox counters-box)]) + (trigger-typing channel)) + (sleep 5))) (lambda (proc) (define channel (hash-ref (current-message) 'channel_id)) @@ -86,30 +90,33 @@ (thunk (change-counter channel -1)))))) (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)))))) + (thread-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)))))) (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))))) + (thread-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)))))) + + (define open-attachment-thread + (thread-loop + (match-define (list url cust chan) (thread-receive)) + (define port + (with-handlers ([exn:fail? (const #f)]) + (parameterize ([current-custodian cust]) + (get-pure-port url)))) + (channel-put chan port))) (define current-message (make-parameter #f)) @@ -149,6 +156,7 @@ (define/public (get-enrich-context) (define message (current-message)) (define message-contents (hash-ref message 'content)) + (define message-attachments (or (hash-ref message 'attachments #f) null)) (define message-author (message-author-id message)) (define/contract (emote-image id) @@ -171,6 +179,22 @@ (-> bytes? (or/c string? bytes?) (or/c symbol? string? bytes?) http:attachment?) (http:attachment data (~a type) name)) + (define attachment-count (length message-attachments)) + + (define/contract (open-attachment [index 0]) + (->* () (exact-nonnegative-integer?) (or/c input-port? #f)) + (let/cc return + (define chan (make-channel)) + (when (>= index attachment-count) + (return #f)) + (define attachment (list-ref message-attachments index)) + #; ;; is an attachment size cap necessary? + (when (> (hash-ref attachment 'size) OPEN_ATTACHMENT_MAX_SIZE_BYTES) + (return #f)) + (define attachment-url (string->url (hash-ref attachment 'proxy_url))) + (thread-send open-attachment-thread (list attachment-url (current-custodian) chan)) + (channel-get chan))) + (define (storage-info type) (match type ['guild (cons 65536 'global)] @@ -214,6 +238,7 @@ (read-storage . ,(read-storage trick-obj)) (write-storage . ,(write-storage trick-obj)) (attachment-data . ,http:attachment-data) + (open-attachment . ,open-attachment) ,@(car base)) ,@(cdr base)))) diff --git a/info.rkt b/info.rkt index f0301b0..0ff3f17 100644 --- a/info.rkt +++ b/info.rkt @@ -8,6 +8,7 @@ "threading-lib")) (define build-deps '("racket-doc" "rackunit-lib" - "scribble-lib")) + "scribble-lib" + "threading-doc")) (define test-omit-paths '("presentation")) (define scribblings '(("scribblings/r16.scrbl" ()))) diff --git a/scribblings/r16.scrbl b/scribblings/r16.scrbl index a55282e..35d39b8 100644 --- a/scribblings/r16.scrbl +++ b/scribblings/r16.scrbl @@ -1,6 +1,6 @@ #lang scribble/manual -@(require (for-label racket/base)) +@(require (for-label racket/base (only-in racket/math natural?) racket/contract)) @title{R16 -- Community-Driven Interactive Code Evaluation} @@ -94,6 +94,7 @@ The @tt{frontend} object in the configuration file can have the following keys a ] @subsection{Trick Environment Extensions} + In additional to the bindings described above, the following items are available in the trick environment. @@ -143,3 +144,14 @@ A trick's "trick-local storage" can be per-guild, per-channel, or per-user; each } This will always be a no-op when invoked from the eval command. + +@defproc[(attachment-data [attachment any/c]) bytes?]{ +Get the payload of an attachment created with @racket[make-attachment]. +} + +@defproc[(open-attachment [index natural? 0]) (or/c input-port? #f)]{ +Opens the @racket[index]th attachment of the message as an input port. + +Returns @racket[#f] if the message doesn't have an @racket[index]th attachment, or +if the attachment couldn't be opened for any other reason. +} -- 2.33.0
- Extract thread-loop to utils.rkt - Bind attachment-count in sandbox - Macro for off-thread functions, which now use sync/timeout on the channel-put-event rather than channel-put -ing directly - Changes delete-caller to no longer attempt to reply to the caller message. This only worked previously because of a convenient race condition. - Slightly refactors emote-image to deobfuscate what it does --- frontends/discord.rkt | 147 +++++++++++++++++++++++------------------- main.rkt | 27 ++++---- scribblings/r16.scrbl | 11 ++-- utils.rkt | 15 +++++ 4 files changed, 114 insertions(+), 86 deletions(-) create mode 100644 utils.rkt diff --git a/frontends/discord.rkt b/frontends/discord.rkt index 532217a..e5cff23 100644 --- a/frontends/discord.rkt +++ b/frontends/discord.rkt @@ -19,7 +19,8 @@ "../config.rkt" (prefix-in ev: "../evaluator.rkt") "../interface.rkt" - "../log.rkt") + "../log.rkt" + "../utils.rkt") (provide r16-make-frontend) @@ -33,12 +34,24 @@ (define (message-author-id message) (hash-ref (hash-ref message 'author) 'id)) -(define-syntax-rule (thread-loop body ...) - (thread - (thunk - (let loop () - body ... - (loop))))) +(define-syntax-rule (define/off-thread (name args ...) + body ...) + (begin + (define worker-thread + (thread-loop + (match (thread-receive) + [(vector chan args ...) + (define res (let () body ...)) + (sync/timeout 1 (channel-put-evt chan res))] + [_ (void)]))) + (define (name args ...) + (define chan (make-channel)) + (sync + chan + (guard-evt + (thunk + (thread-send worker-thread (vector chan args ...)) + never-evt)))))) (define discord-frontend% (class* object% [r16-frontend<%>] @@ -89,36 +102,28 @@ proc (thunk (change-counter channel -1)))))) - (define deleter-thread - (thread-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)))))) - - (define emote-image-thread - (thread-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)))))) - - (define open-attachment-thread - (thread-loop - (match-define (list url cust chan) (thread-receive)) - (define port - (with-handlers ([exn:fail? (const #f)]) - (parameterize ([current-custodian cust]) - (get-pure-port url)))) - (channel-put chan port))) + (define/off-thread (do-delete-message message) + (with-handlers ([exn:fail:network? identity]) + (http:delete-message + client + (hash-ref message 'channel_id) + (hash-ref message 'id)))) + + (define/off-thread (get-emote-image id) + (with-handlers ([exn:fail? (const #f)]) + ; TODO this only uses PNG, racket-cord needs to expose an animated field on emoji + (~> (~a "https://cdn.discordapp.com/emojis/" id ".png?v=1") + string->url + get-pure-port + port->bytes))) + + (define/off-thread (open-attachment-url cust url) + (with-handlers ([exn:fail? (const #f)]) + (parameterize ([current-custodian cust]) + (get-pure-port url)))) (define current-message (make-parameter #f)) + (define current-deleted-box (make-parameter #f)) (define (format-run-result rr) `(,(ev:run-result-stdout rr) @@ -154,6 +159,7 @@ (define emote-image-cache (make-hash)) (define/public (get-enrich-context) + (define deleted-box (current-deleted-box)) (define message (current-message)) (define message-contents (hash-ref message 'content)) (define message-attachments (or (hash-ref message 'attachments #f) null)) @@ -165,15 +171,16 @@ 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))))))) + (let/cc return + ; Is this an emote that this bot has encountered? + ; If not, don't bother requesting it and just return #f + (unless (set-member? known-emotes id) + (return #f)) + (define data (get-emote-image id)) + ; If empty byte string returned, return #f + (unless (and data (positive? (bytes-length data))) + (return #f)) + data)))) (define/contract (make-attachment data name type) (-> bytes? (or/c string? bytes?) (or/c symbol? string? bytes?) http:attachment?) @@ -191,9 +198,9 @@ #; ;; is an attachment size cap necessary? (when (> (hash-ref attachment 'size) OPEN_ATTACHMENT_MAX_SIZE_BYTES) (return #f)) - (define attachment-url (string->url (hash-ref attachment 'proxy_url))) - (thread-send open-attachment-thread (list attachment-url (current-custodian) chan)) - (channel-get chan))) + (open-attachment-url + (current-custodian) + (string->url (hash-ref attachment 'proxy_url))))) (define (storage-info type) (match type @@ -226,7 +233,9 @@ #t))))))) (define (delete-caller) - (thread-send deleter-thread (cons client message))) + (when (box-cas! deleted-box #f #t) + (do-delete-message message)) + (void)) (lambda (base trick-obj _args _parent-context) `(((message-contents . ,message-contents) @@ -239,6 +248,7 @@ (write-storage . ,(write-storage trick-obj)) (attachment-data . ,http:attachment-data) (open-attachment . ,open-attachment) + (attachment-count . ,attachment-count) ,@(car base)) ,@(cdr base)))) @@ -268,27 +278,30 @@ (define (message-received _ws-client _client message) (parameterize ([current-message message] + [current-deleted-box (box #f)] [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) + (match-define (cons func func-args) (parse-command content)) + (when func + (define contents + (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 func-args))) + (create-message-with-contents + channel + (and (not (unbox (current-deleted-box))) message) + contents))))) + + (define (create-message-with-contents channel reply-message contents) (define char-cap 2000) (define slice-size 30) @@ -305,7 +318,9 @@ (if (or attachment (non-empty-string? raw-content)) (truncate-string raw-content char-cap) "\u200b")) - (define reference (hash 'message_id (hash-ref message 'id))) + (define reference + (and reply-message + (hash 'message_id (hash-ref reply-message 'id)))) (http:create-message client channel content #:file attachment diff --git a/main.rkt b/main.rkt index 49643e0..db8f52a 100755 --- a/main.rkt +++ b/main.rkt @@ -14,6 +14,7 @@ "config.rkt" "log.rkt" "interface.rkt" + "utils.rkt" (prefix-in db: "trick-db.rkt")) (define (readable? x) @@ -87,25 +88,19 @@ (define db (db:make-trickdb path json->trick)) (define r16-receiver (make-log-receiver r16-logger 'debug)) - (thread - (thunk - (let loop () - (let ([v (sync r16-receiver)]) - (printf "[~a] ~a\n" - (vector-ref v 0) - (vector-ref v 1))) - (loop)))) + (thread-loop + (define v (sync r16-receiver)) + (printf "[~a] ~a\n" + (vector-ref v 0) + (vector-ref v 1))) (parameterize ([current-backend (new r16% [db db])] [current-frontend (make-frontend config)]) - (thread - (thunk - (let loop () - (sleep 30) - (define result (send (current-backend) save)) - (when (exn:fail? result) - (log-r16-error (~a "Error saving tricks: " result))) - (loop)))) + (thread-loop + (sleep 30) + (define result (send (current-backend) save)) + (when (exn:fail? result) + (log-r16-error (~a "Error saving tricks: " result)))) (send (current-frontend) start))) (module* main #f diff --git a/scribblings/r16.scrbl b/scribblings/r16.scrbl index 35d39b8..7b49b31 100644 --- a/scribblings/r16.scrbl +++ b/scribblings/r16.scrbl @@ -98,9 +98,8 @@ The @tt{frontend} object in the configuration file can have the following keys a In additional to the bindings described above, the following items are available in the trick environment. - @defproc[(delete-caller) void?]{ -Thunk that deletes the message that invoked this sandbox. +Delete the message that invoked this sandbox. } @defproc[(emote-lookup [name string?]) (or/c string? #f)]{ @@ -115,7 +114,7 @@ Function that returns the PNG data of the emote with ID @racket[id], or @racket[ [name (or/c string? bytes?)] [mime (or/c symbol? string? bytes?)]) any/c]{ Creates an attachment with payload @racket[payload], filename @racket[name], and MIME-type @racket[mime]. -This opaque object must be returned from the trick to be sent to Discord. +This object must be returned from the trick to be sent to Discord. If more than one attachment is returned, an unspecified one is sent. } @@ -150,8 +149,12 @@ Get the payload of an attachment created with @racket[make-attachment]. } @defproc[(open-attachment [index natural? 0]) (or/c input-port? #f)]{ -Opens the @racket[index]th attachment of the message as an input port. +Opens the @racket[index]th attachment of the message that invoked this sandbox, as an input port. Returns @racket[#f] if the message doesn't have an @racket[index]th attachment, or if the attachment couldn't be opened for any other reason. } + +@defthing[attachment-count natural?]{ +The number of files attached to the message that invoked this sandbox. +} diff --git a/utils.rkt b/utils.rkt new file mode 100644 index 0000000..6aa0e18 --- /dev/null +++ b/utils.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +(require (for-syntax racket/base syntax/parse)) + +(provide thread-loop) + +(define-syntax (thread-loop stx) + (syntax-parse stx + [(_ body:expr ...) + (syntax/loc stx + (let () + (define (loop) + body ... + (loop)) + (thread loop)))])) -- 2.33.0
builds.sr.ht <builds@sr.ht>r16/patches/linux_buildtest.yml: SUCCESS in 1m53s [Add open-attachment][0] v2 from [eutro][1] [0]: https://lists.sr.ht/~williewillus/public-inbox/patches/25413 [1]: mailto:benedek.szilvasy@gmail.com ✓ #595665 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/595665