From c6ecb5325a8afdbb39b0bc90e85fdec04c61330d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Tue, 13 Oct 2020 16:40:51 +0200
Subject: Config loading now in 'sandbox'.

---
 config.scm           | 13 ++---------
 module/calp/main.scm | 64 ++++++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 54 insertions(+), 23 deletions(-)

diff --git a/config.scm b/config.scm
index 4092ecb3..cb5779f4 100644
--- a/config.scm
+++ b/config.scm
@@ -2,22 +2,13 @@
 ;;; Currently loaded by main, and requires that `calendar-files`
 ;;; is set to a list of files (or directories).
 
-(use-modules (vcomponent))
-
-(use-modules (srfi srfi-88)
-             (ice-9 regex)
-             ;; (ice-9 rdelim)
+(use-modules (ice-9 regex)
              (sxml simple)
-             (glob)
-
-             (calp util config)
-
-             (datetime)
 
              ;; TODO this module introduces description-filter. It should be
              ;; possible to use set-config! before the declaration point is
              ;; known. But I currently get a config error.
-             (vcomponent datetime output)
+             ;; (vcomponent datetime output)
              )
 
 (set-config! 'calendar-files (glob "~/.local/var/cal/*"))
diff --git a/module/calp/main.scm b/module/calp/main.scm
index 407f7b81..2eb1ee05 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -15,6 +15,8 @@
   :use-module (ice-9 getopt-long)
   :use-module (ice-9 regex)
   :use-module ((ice-9 popen) :select (open-input-pipe))
+  :use-module ((ice-9 sandbox) :select
+               (make-sandbox-module all-pure-and-impure-bindings))
 
   :use-module (statprof)
   :use-module (calp repl)
@@ -99,6 +101,11 @@
   (if (null? a)
       b a))
 
+(define (bindings-for module-name)
+  ;; Wrapping list so we can later export sub-modules.
+  (list (cons module-name
+              (module-map (lambda (a . _) a)
+                          (resolve-interface module-name)))))
 
 (define (wrapped-main args)
   (define opts (getopt-long args (getopt-opt options) #:stop-at-first-non-option #t))
@@ -106,6 +113,20 @@
   (define repl (option-ref opts 'repl #f))
   (define altconfig (option-ref opts 'config #f))
 
+  (define config-file
+    (cond [altconfig
+           (if (file-exists? altconfig)
+               altconfig
+               (throw 'option-error
+                      "Configuration file ~a missing" altconfig))]
+         ;; altconfig could be placed in the list below. But I want to raise an error
+         ;; if an explicitly given config is missing.
+         [(find file-exists?
+                (list
+                 (path-append (xdg-config-home) "/calp/config.scm")
+                 (path-append (xdg-sysconfdir) "/calp/config.scm")))
+          => identity]))
+
   (when stprof (statprof-start))
 
   (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a"
@@ -113,18 +134,37 @@
                                             (getpid)))]
         [repl => repl-start])
 
-  (if altconfig
-      (begin
-        (if (file-exists? altconfig)
-            (primitive-load altconfig)
-            (throw 'option-error "Configuration file ~a missing" altconfig)))
-      ;; if not altconfig, then regular config
-
-      (awhen (find file-exists?
-                   (list
-                     (path-append (xdg-config-home) "/calp/config.scm")
-                     (path-append (xdg-sysconfdir) "/calp/config.scm")))
-             (primitive-load it)))
+
+  ;; load config
+  (catch #t
+    (lambda ()
+      (eval
+       `(begin
+          (use-modules (srfi srfi-1)
+                       (srfi srfi-88)
+                       (datetime)
+                       (vcomponent)
+                       (calp util config)
+                       (glob))
+          ,@(with-input-from-file config-file
+              (lambda ()
+                (let loop ((done '()))
+                  (let ((form (read)))
+                    (if (eof-object? form)
+                        (reverse done)
+                        (loop (cons form done))))))))
+       (make-sandbox-module
+        `(((guile) use-modules)
+          ,@all-pure-and-impure-bindings
+          ))
+       ))
+    (lambda args
+      (format (current-error-port)
+              "Failed loading config file ~a~%~s~%"
+              config-file
+              args
+              )))
+
 
 
   ;; NOTE this doesn't stop at first non-option, meaning that -o flags
-- 
cgit v1.2.3