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

* 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>

2 files changed, 110 insertions, 12 deletions

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 <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")