diff --git a/guix/ui.scm b/guix/ui.scm index e6829bd4d60..e953ef23ca1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -250,11 +250,11 @@ arbitrary code execution." (error "can't sever module?")) (hashq-remove! (module-submodules parent) tail))))) -(define* (load/isolated file bindings +(define* (load/isolated port bindings #:key (time-limit 30) (allocation-limit #e1e6)) - "Read and evaluate code from FILE in a isolated evaluation environment that + "Read and evaluate code from PORT in a isolated evaluation environment that only contains the given BINDINGS. Evaluation may not take more than TIME-LIMIT seconds and may not allocate more than ALLOCATION-LIMIT bytes." ;; This is similar to 'eval-in-sandbox' except that the time and allocation @@ -265,7 +265,7 @@ TIME-LIMIT seconds and may not allocate more than ALLOCATION-LIMIT bytes." (lambda () (call-with-time-and-allocation-limits time-limit allocation-limit (lambda () - (eval (call-with-input-file file read/safe) module)))) + (eval (read/safe port) module)))) (lambda () (sever-module! module))))) @@ -300,9 +300,10 @@ TIME-LIMIT seconds and may not allocate more than ALLOCATION-LIMIT bytes." #:key (on-error 'nothing-special) (isolated? #f)) - "Load the user provided Scheme source code FILE. When ISOLATED? is true, -load FILE in an isolated \"sandbox\" where only IMPORTS are available--see the -documentation for (ice-9 sandbox) for what goes into IMPORTS." + "Load the user provided Scheme source code FILE-OR-PORT. When ISOLATED? is true, +load FILE-OR-PORT in an isolated \"sandbox\" where only IMPORTS are +available--see the documentation for (ice-9 sandbox) for what goes into +IMPORTS." (define (error-string frame args) (call-with-output-string (lambda (port) @@ -324,14 +325,23 @@ documentation for (ice-9 sandbox) for what goes into IMPORTS." module)) imports))))) + (when (and (port? file-or-port) (not isolated?)) + ;; XXX: This case is not implemented because it's hard to defend and hard + ;; to implement due to the use of the compiler instead of the interpreter. + (leave (G_ "code coming from a port must be isolated~%"))) + (catch #t (lambda () (if isolated? (call-with-prompt tag (lambda () - (load/isolated (try-canonicalize-path file) - (append imports - (force pure-bindings-sans-allocators)))) + (let loop ((port file-or-port)) + (if (port? port) + (load/isolated port + (append + imports + (force pure-bindings-sans-allocators))) + (call-with-input-file file-or-port loop)))) (const #f)) (save-module-excursion (lambda () @@ -351,7 +361,7 @@ documentation for (ice-9 sandbox) for what goes into IMPORTS." ;; compiled, which then allows us to provide better error ;; reporting with source line numbers. (without-compiler-optimizations - (load (try-canonicalize-path file)))) + (load (try-canonicalize-path file-or-port)))) (const #f))))))) (lambda _ ;; XXX: Errors are reported from the pre-unwind handler below, but @@ -363,7 +373,7 @@ documentation for (ice-9 sandbox) for what goes into IMPORTS." (let* ((stack (make-stack #t handle-error tag)) (frame (last-frame-with-source stack))) - (report-load-error file args frame) + (report-load-error file-or-port args frame) (case on-error ((debug) diff --git a/tests/ui.scm b/tests/ui.scm index 438acae5252..048f8500722 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2017, 2019-2020, 2022 Ludovic Courtès +;;; Copyright © 2013-2017, 2019-2020, 2022, 2026 Ludovic Courtès ;;; Copyright © 2022 Taiju HIGASHI ;;; ;;; This file is part of GNU Guix. @@ -26,11 +26,19 @@ #:use-module ((gnu packages) #:select (specification->package)) #:use-module (guix tests) #:use-module (guix utils) + #:use-module ((guix channels) + #:select (channel->code + %default-guix-channel + guix-channel? + channel-introduction)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) #:use-module (ice-9 regex)) ;; Test the (guix ui) module. @@ -369,4 +377,84 @@ Second line" 24)) ("PAGER" #false)) (assert-equals-find-available-pager ""))))) +(test-equal "load/isolated, reading exceeds limits" + 'quit ;'limit-exceeded is raised, caught, and then 'quit is raised + (let ((port (make-custom-binary-input-port + "infinite-paren-stream" + (lambda (bv start count) + (bytevector-u8-set! bv start (char->integer #\()) + 1) + #f #f #f))) + (catch #t + (lambda () + (load* port '() #:isolated? #t) + #f) + (lambda (key . args) + key)))) + +(test-equal "load/isolated, attempt to import module" + 'quit + (call-with-input-string (object->string + '(begin + (use-modules (system foreign)) + (dereference-pointer (make-pointer 123)))) + (lambda (port) + (catch #t + (lambda () + (load* port '() #:isolated? #t) + #f) + (lambda (key . args) + key))))) + +(test-equal "load/isolated, attempt to allocate with 'cons'" + 'quit + ;; 'make-list' is not available in the environment so try to allocate memory + ;; via macro expansion or repeated calls to 'cons'. + (call-with-input-string + (object->string + '(letrec-syntax ((make-list + (lambda (s) + (syntax-case s () + ((_ 0) #''()) + ((_ n) + #`(cons #f + (make-list + #,(- (syntax->datum #'n) 1)))))))) + (make-list 100000))) + (lambda (port) + (catch #t + (lambda () + (load* port '() #:isolated? #t) + #f) + (lambda (key . args) + key))))) + +(test-equal "load/isolated, attempt to allocate with 'make-vector'" + 'quit + ;; 'make-vector' is not available in the environment. + (call-with-input-string (object->string '(make-vector 123123123)) + (lambda (port) + (catch #t + (lambda () + (load* port '() #:isolated? #t) + #f) + (lambda (key . args) + key))))) + +(test-assert "load/isolated, use of allowed bindings" + (call-with-input-string + (object->string + `(list ,(channel->code %default-guix-channel))) + (lambda (port) + (match (load* port + '(((guix channels) + channel make-channel-introduction openpgp-fingerprint)) + #:isolated? #t) + ((channel) + ;; The channels have a different 'location' field value hence this + ;; limited comparison. + (and (guix-channel? channel) + (equal? (channel-introduction channel) + (channel-introduction %default-guix-channel)))))))) + (test-end "ui")