tribes/guix
1
0
Fork 1
mirror of https://git.savannah.gnu.org/git/guix.git synced 2026-06-12 19:34:05 +02:00
Code Activity

ui: ‘load*’ accepts a file name or a port.

Browse Source 
* guix/ui.scm (load/isolated): Change ‘file’ parameter to ‘port’ and adjust
accordingly.
(load*): Change ‘file’ to ‘file-or-port’ and adjust accordingly.
* tests/ui.scm ("load/isolated, reading exceeds limits")
("load/isolated, attempt to import module")
("load/isolated, attempt to allocate with 'cons'")
("load/isolated, attempt to allocate with 'make-vector'")
("load/isolated, use of allowed bindings"): New tests.

Change-Id: I0ec8fa2717c02041d409f6dc59b753d4501107f9
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Ludovic Courtès
2026-02-27 17:28:44 +01:00
parent 882f46bdd7
commit 2d4f290e17
2 changed files with 110 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files
guix/ui.scm
+21 -11
View File
@@ -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)
tests/ui.scm
+89 -1
View File
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2017, 2019-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013-2017, 2019-2020, 2022, 2026 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
;;;
;;; 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")