~williewillus/public-inbox

r16: Display almost all results in sandbox context v4 APPLIED

eutro
eutro: 4
 Display almost all results in sandbox context
 ~a all results in one go
 Handle ~a errors in sandbox
 Pass out everything when calling subtricks

 5 files changed, 48 insertions(+), 36 deletions(-)
#506280 linux_buildtest.yml success
builds.sr.ht
r16/patches/linux_buildtest.yml: SUCCESS in 2m52s

[Display almost all results in sandbox context][0] v4 from [eutro][1]

[0]: https://lists.sr.ht/~williewillus/public-inbox/patches/22688
[1]: mailto:benedek.szilvasy@gmail.com

✓ #506280 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/506280
Export patchset (mbox)
How do I use this?

Copy & paste the following snippet into your terminal to import this patchset into git:

curl -s https://lists.sr.ht/~williewillus/public-inbox/patches/22688/mbox | git am -3
Learn more about email & git
View this thread in the archives

[PATCH r16 v4 1/4] Display almost all results in sandbox context Export this patch

eutro
---
 evaluator.rkt | 18 +++++++++++-------
 main.rkt      | 17 ++++++-----------
 2 files changed, 17 insertions(+), 18 deletions(-)

diff --git a/evaluator.rkt b/evaluator.rkt
index 3b93002..c396d13 100644
--- a/evaluator.rkt
+++ b/evaluator.rkt
@@ -5,7 +5,7 @@
(provide
 definitions?
 (contract-out
  [run (string? definitions? . -> . any)]))
  [run (string? definitions? predicate/c . -> . any)]))

(define definitions? (cons/c (listof (cons/c symbol? any/c))
                             (listof module-path?)))
@@ -72,16 +72,20 @@
                 [sandbox-reader (language-morph-reader definitions)])
    (make-evaluator 'racket)))

(define (run code definitions)
(define (run code definitions pass-out?)
  (parameterize ([current-environment-variables (make-environment-variables)])
    (let* ((evaluator (init-evaluator definitions))
           (results (call-with-values
    (let* ([evaluator (init-evaluator definitions)]
           [results (call-with-values
                     (thunk
                      (with-handlers ([(const #t) identity])
                        (evaluator code)))
                     list))
           (stdout (get-output evaluator))
           (stderr (get-error-output evaluator)))
                     (lambda results
                       (for/list ([result (in-list results)])
                         (if (pass-out? result)
                             result
                             (call-in-sandbox-context evaluator (thunk (~a result)))))))]
           [stdout (get-output evaluator)]
           [stderr (get-error-output evaluator)])
      (kill-evaluator evaluator)
      (apply values
             `(,stdout
diff --git a/main.rkt b/main.rkt
index 314de4e..9a7d61d 100755
--- a/main.rkt
+++ b/main.rkt
@@ -107,7 +107,7 @@
(define (run-snippet client db message code)
  (let ([code (strip-backticks code)])
    (with-typing-indicator client message
      (thunk (ev:run code (evaluation-ctx #f client message db (context-id message) "" #f))))))
      (thunk (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
@@ -139,7 +139,8 @@
                      db
                      context-id
                      (or body "")
                      #f)))))
                      #f)
                     http:attachment?))))
         (~a "Trick " name " doesn't exist!")))))

(define (update-trick client db message text)
@@ -423,14 +424,8 @@
          (format "~a... [~a more characters]" (substring str 0 slicepos) restsize))
        str)))

(define (empty-string? s)
  (and (string? s) (= (string-length s) 0)))

(define (create-message-with-contents client channel message . contents)
  (let* ([content (apply ~a #:separator "\n"
                         (~>> contents
                              (map (lambda (x) (if (custom-write? x) "#<redacted>" x)))
                              (filter-not (disjoin void? http:attachment? empty-string?))))]
(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)
@@ -449,7 +444,7 @@
      (match-let ([(cons func content) (parse-command content)])
        (when func
          (call-with-values (thunk (func client db message content))
                            (curry create-message-with-contents client channel message)))))))
                            (create-message-with-contents client channel message)))))))

(define (init-client folder token)
  (log-r16-info "Storing tricks in ~a" folder)
-- 
2.31.1

[PATCH r16 v4 2/4] ~a all results in one go Export this patch

eutro
---
 evaluator.rkt | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/evaluator.rkt b/evaluator.rkt
index c396d13..25fe6f3 100644
--- a/evaluator.rkt
+++ b/evaluator.rkt
@@ -80,10 +80,13 @@
                      (with-handlers ([(const #t) identity])
                        (evaluator code)))
                     (lambda results
                       (for/list ([result (in-list results)])
                         (if (pass-out? result)
                             result
                             (call-in-sandbox-context evaluator (thunk (~a result)))))))]
                       (call-in-sandbox-context
                        evaluator
                        (thunk
                         (for/list ([result (in-list results)])
                           (if (pass-out? result)
                               result
                               (~a result)))))))]
           [stdout (get-output evaluator)]
           [stderr (get-error-output evaluator)])
      (kill-evaluator evaluator)
-- 
2.31.1

[PATCH r16 v4 3/4] Handle ~a errors in sandbox Export this patch

eutro
---
 evaluator.rkt | 35 ++++++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 13 deletions(-)

diff --git a/evaluator.rkt b/evaluator.rkt
index 25fe6f3..74ab5bc 100644
--- a/evaluator.rkt
+++ b/evaluator.rkt
@@ -1,6 +1,6 @@
#lang racket

(require racket/contract racket/sandbox syntax/strip-context)
(require racket/contract racket/sandbox racket/exn syntax/strip-context)

(provide
 definitions?
@@ -75,18 +75,27 @@
(define (run code definitions pass-out?)
  (parameterize ([current-environment-variables (make-environment-variables)])
    (let* ([evaluator (init-evaluator definitions)]
           [results (call-with-values
                     (thunk
                      (with-handlers ([(const #t) identity])
                        (evaluator code)))
                     (lambda results
                       (call-in-sandbox-context
                        evaluator
                        (thunk
                         (for/list ([result (in-list results)])
                           (if (pass-out? result)
                               result
                               (~a result)))))))]
           [results
            (call-with-values
             (thunk
              (with-handlers ([(const #t) identity])
                (evaluator code)))
             (lambda results
               (call-in-sandbox-context
                evaluator
                (thunk
                 (for/list ([result (in-list results)]
                            #:when (not (void? result)))
                   (if (pass-out? result)
                       result
                       (with-handlers
                         ([(const #t)
                           (lambda (e)
                             (with-handlers ([(const #t) (const "#<errored>")])
                               ((error-display-handler)
                                (exn-message e)
                                e)))])
                         (~a result))))))))]
           [stdout (get-output evaluator)]
           [stderr (get-error-output evaluator)])
      (kill-evaluator evaluator)
-- 
2.31.1

[PATCH r16 v4 4/4] Pass out everything when calling subtricks Export this patch

eutro
---
 main.rkt | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/main.rkt b/main.rkt
index 9a7d61d..47c47e2 100755
--- a/main.rkt
+++ b/main.rkt
@@ -265,7 +265,8 @@
                        db
                        context-id
                        (if arguments (~a arguments) "")
                        parent-ctx)))
                        parent-ctx)
                       (const #t)))
               list)])
          (write-string stdout)
          (unless (void? stderr) (write-string stderr (current-error-port)))
-- 
2.31.1
builds.sr.ht
r16/patches/linux_buildtest.yml: SUCCESS in 2m52s

[Display almost all results in sandbox context][0] v4 from [eutro][1]

[0]: https://lists.sr.ht/~williewillus/public-inbox/patches/22688
[1]: mailto:benedek.szilvasy@gmail.com

✓ #506280 SUCCESS r16/patches/linux_buildtest.yml https://builds.sr.ht/~williewillus/job/506280