r16: Allow the evaluator to be configured from the config v1 APPLIED

eutro: 1
 Allow the evaluator to be configured from the config

 3 files changed, 65 insertions(+), 34 deletions(-)

[PATCH r16] Allow the evaluator to be configured from the config Export this patch

---
 config.rkt    | 58 +++++++++++++++++++++++++++++++--------------------
 evaluator.rkt |  1 -
 main.rkt      | 40 ++++++++++++++++++++++++++---------
 3 files changed, 65 insertions(+), 34 deletions(-)

diff --git a/config.rkt b/config.rkt
index 4f2cf41..c90b4a2 100644
--- a/config.rkt
+++ b/config.rkt
@@ -1,30 +1,42 @@
 #lang racket/base
 
-(require racket/contract)
+(require racket/contract (for-syntax syntax/parse racket/base racket/syntax))
 (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-syntax (config/c stx)
+  (syntax-parse stx
+    [(_ [key vpred] ...)
+     (syntax/loc stx (config/c [key vpred] ... #:optional))]
+    [(_ [key vpred] ... #:optional [okey ovpred] ...)
+     (define/with-syntax name stx)
+     (quasisyntax/loc stx
+       (make-contract
+        #:name 'name
+        #:first-order hash?
+        #:projection
+        (lambda (b)
+          (compose
+           (let ([check-val ((contract-projection vpred) (blame-add-context b (format "key ~s of" 'key)))])
+             (lambda (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)) ...
+           (let ([check-val ((contract-projection ovpred) (blame-add-context b (format "key ~s of" 'okey)))])
+             (lambda (x)
+               (when (hash-has-key? x 'okey)
+                 (check-val (hash-ref x 'okey)))
+               x)) ...
+           (lambda (x)
+             (unless (hash? x)
+               (raise-blame-error
+                b x
+                '(expected "hash?" given "~e")
+                x))
+             x)))))]))
 
 (define (check-config predicate config)
   (contract predicate config
diff --git a/evaluator.rkt b/evaluator.rkt
index a5e6bc1..b5b0139 100644
--- a/evaluator.rkt
+++ b/evaluator.rkt
@@ -46,7 +46,6 @@
 (define (init-evaluator)
   (parameterize ([sandbox-output 'string]
                  [sandbox-error-output 'string]
-                 [sandbox-eval-limits '(30 20)]
                  [sandbox-propagate-exceptions #f]
                  [sandbox-make-environment-variables make-environment-variables])
     (make-evaluator 'racket)))
diff --git a/main.rkt b/main.rkt
index db8f52a..74296fe 100755
--- a/main.rkt
+++ b/main.rkt
@@ -4,11 +4,12 @@
 (require
  (only-in racket/class new send)
  (only-in racket/cmdline parse-command-line)
- (only-in racket/contract -> contract or/c)
  (only-in racket/format ~a)
  (only-in racket/function const thunk)
  (only-in racket/port call-with-input-string with-input-from-string)
+ (only-in racket/sandbox sandbox-memory-limit sandbox-eval-limits)
  json
+ racket/contract
  "backend.rkt"
  "common.rkt"
  "config.rkt"
@@ -29,7 +30,13 @@
     (or/c readable?
           (config/c
            [module readable?]))]
-   [storage path-string?]))
+   [storage path-string?]
+   #:optional
+   [sandbox
+    (config/c
+     #:optional
+     [memory_limit (or/c (>=/c 0) #f)]
+     [eval_limits (or/c (list/c (or/c (>=/c 0) #f) (or/c (>=/c 0) #f)) #f)])]))
 
 (define (get-config)
   (parse-command-line
@@ -82,6 +89,16 @@
              'frontend #f)
    frontend-config))
 
+(define (call-with-sandbox-conf conf f)
+  (cond
+    [(not conf) (f)]
+    [else
+     (define mem-limit (hash-ref conf 'memory_limit (sandbox-memory-limit)))
+     (define eval-limit (hash-ref conf 'eval_limits (sandbox-eval-limits)))
+     (parameterize ([sandbox-memory-limit mem-limit]
+                    [sandbox-eval-limits eval-limit])
+       (f))]))
+
 (define (main)
   (define config (get-config))
   (define path (hash-ref config 'storage))
@@ -94,14 +111,17 @@
            (vector-ref v 0)
            (vector-ref v 1)))
 
-  (parameterize ([current-backend (new r16% [db db])]
-                 [current-frontend (make-frontend config)])
-    (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)))
+  (call-with-sandbox-conf
+   (hash-ref config 'sandbox #f)
+   (lambda ()
+    (parameterize ([current-backend (new r16% [db db])]
+                   [current-frontend (make-frontend config)])
+      (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
   (main))
-- 
2.34.1

builds.sr.ht <builds@sr.ht>

2 years ago

r16/patches/linux_buildtest.yml: SUCCESS in 2m0s

[Allow the evaluator to be configured from the config][0] from [eutro][1]

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

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

Vincent Lee <vincent@vincent-lee.net>

2 years ago

thanks, committed

eutro <benedek.szilvasy@gmail.com> writes: