[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/09: potluck: Add ability to load potluck package in sandbox.
From: |
Andy Wingo |
Subject: |
05/09: potluck: Add ability to load potluck package in sandbox. |
Date: |
Mon, 24 Apr 2017 16:46:35 -0400 (EDT) |
wingo pushed a commit to branch wip-potluck
in repository guix.
commit 86e7ce849e5b2832a041c80503aba82c63badbbe
Author: Andy Wingo <address@hidden>
Date: Mon Apr 24 14:05:34 2017 +0200
potluck: Add ability to load potluck package in sandbox.
* guix/potluck/environment.scm: New file.
* Makefile.am (MODULES): Add new files.
* guix/potluck/packages.scm (make-potluck-sandbox-module)
(eval-in-sandbox): New helpers.
(load-potluck-package): New public function.
---
Makefile.am | 1 +
guix/potluck/environment.scm | 538 +++++++++++++++++++++++++++++++++++++++++++
guix/potluck/packages.scm | 59 +++++
3 files changed, 598 insertions(+)
diff --git a/Makefile.am b/Makefile.am
index 295d7b3..628283b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -128,6 +128,7 @@ MODULES = \
guix/packages.scm \
guix/git.scm \
guix/potluck/build-systems.scm \
+ guix/potluck/environment.scm \
guix/potluck/licenses.scm \
guix/potluck/packages.scm \
guix/import/utils.scm \
diff --git a/guix/potluck/environment.scm b/guix/potluck/environment.scm
new file mode 100644
index 0000000..f28ca11
--- /dev/null
+++ b/guix/potluck/environment.scm
@@ -0,0 +1,538 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Andy Wingo <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix potluck environment))
+
+;;; Commentary:
+;;;
+;;; This module's public interface forms a safe set of stable bindings
+;;; available to Guix potluck package definition files.
+;;;
+;;; Code:
+
+(define-syntax-rule (define-bindings module-name binding ...)
+ (module-use! (module-public-interface (current-module))
+ (resolve-interface 'module-name #:select '(binding ...))))
+
+;; Core bindings.
+(define-bindings (guile)
+ and
+ begin
+ apply
+ call-with-values
+ values
+ case
+ case-lambda
+ case-lambda*
+ cond
+ define
+ define*
+ define-values
+ do
+ if
+ lambda
+ lambda*
+ let
+ let*
+ letrec
+ letrec*
+ or
+ quasiquote
+ quote
+ ;; Can't allow mutation to globals.
+ ;; set!
+ unless
+ unquote
+ unquote-splicing
+ when
+ while
+ λ)
+
+;; Macro bindings.
+(define-bindings (guile)
+ ;; Although these have "current" in their name, they are lexically
+ ;; scoped, not dynamically scoped.
+ current-filename
+ current-source-location
+ ;; A subset of Guile's macro capabilities, for simplicity.
+ define-syntax
+ define-syntax-parameter
+ define-syntax-rule
+ identifier-syntax
+ let-syntax
+ letrec-syntax
+ syntax-error
+ syntax-rules)
+
+;; Iteration bindings.
+(define-bindings (guile)
+ compose
+ for-each
+ identity
+ iota
+ map
+ map-in-order
+ const
+ noop)
+
+;; Unspecified bindings.
+(define-bindings (guile)
+ unspecified?
+ *unspecified*)
+
+;; Predicate bindings.
+(define-bindings (guile)
+ ->bool
+ and-map
+ and=>
+ boolean?
+ eq?
+ equal?
+ eqv?
+ negate
+ not
+ or-map)
+
+;; The current ports (current-input-port et al) are dynamically scoped,
+;; which is a footgun from a sandboxing perspective. It's too easy for
+;; a procedure that is the result of a sandboxed evaluation to be later
+;; invoked in a different context and thereby be implicitly granted
+;; capabilities to whatever port is then current. This is compounded by
+;; the fact that most Scheme i/o primitives allow the port to be omitted
+;; and thereby default to whatever's current. For now, sadly, we avoid
+;; exposing any i/o primitive to the sandbox.
+
+;; Error bindings.
+(define-bindings (guile)
+ error
+ throw
+ with-throw-handler
+ catch
+ ;; false-if-exception can cause i/o if the #:warning arg is passed.
+ ;; false-if-exception
+ strerror
+ scm-error)
+
+;; Sort bindings.
+(define-bindings (guile)
+ sort
+ sorted?
+ stable-sort
+ sort-list)
+
+;; Alist bindings.
+(define-bindings (guile)
+ acons
+ assoc
+ assoc-ref
+ assq
+ assq-ref
+ assv
+ assv-ref
+ sloppy-assoc
+ sloppy-assq
+ sloppy-assv)
+
+;; Number bindings.
+(define-bindings (guile)
+ *
+ +
+ -
+ /
+ 1+
+ 1-
+ <
+ <=
+ =
+ >
+ >=
+ abs
+ acos
+ acosh
+ angle
+ asin
+ asinh
+ atan
+ atanh
+ ceiling
+ ceiling-quotient
+ ceiling-remainder
+ ceiling/
+ centered-quotient
+ centered-remainder
+ centered/
+ complex?
+ cos
+ cosh
+ denominator
+ euclidean-quotient
+ euclidean-remainder
+ euclidean/
+ even?
+ exact->inexact
+ exact-integer-sqrt
+ exact-integer?
+ exact?
+ exp
+ expt
+ finite?
+ floor
+ floor-quotient
+ floor-remainder
+ floor/
+ gcd
+ imag-part
+ inf
+ inf?
+ integer-expt
+ integer-length
+ integer?
+ lcm
+ log
+ log10
+ magnitude
+ make-polar
+ make-rectangular
+ max
+ min
+ modulo
+ modulo-expt
+ most-negative-fixnum
+ most-positive-fixnum
+ nan
+ nan?
+ negative?
+ numerator
+ odd?
+ positive?
+ quotient
+ rational?
+ rationalize
+ real-part
+ real?
+ remainder
+ round
+ round-quotient
+ round-remainder
+ round/
+ sin
+ sinh
+ sqrt
+ tan
+ tanh
+ truncate
+ truncate-quotient
+ truncate-remainder
+ truncate/
+ zero?
+ number?
+ number->string
+ string->number)
+
+;; Charset bindings.
+(define-bindings (guile)
+ ->char-set
+ char-set
+ char-set->list
+ char-set->string
+ char-set-adjoin
+ char-set-any
+ char-set-complement
+ char-set-contains?
+ char-set-copy
+ char-set-count
+ char-set-cursor
+ char-set-cursor-next
+ char-set-delete
+ char-set-diff+intersection
+ char-set-difference
+ char-set-every
+ char-set-filter
+ char-set-fold
+ char-set-for-each
+ char-set-hash
+ char-set-intersection
+ char-set-map
+ char-set-ref
+ char-set-size
+ char-set-unfold
+ char-set-union
+ char-set-xor
+ char-set:ascii
+ char-set:blank
+ char-set:designated
+ char-set:digit
+ char-set:empty
+ char-set:full
+ char-set:graphic
+ char-set:hex-digit
+ char-set:iso-control
+ char-set:letter
+ char-set:letter+digit
+ char-set:lower-case
+ char-set:printing
+ char-set:punctuation
+ char-set:symbol
+ char-set:title-case
+ char-set:upper-case
+ char-set:whitespace
+ char-set<=
+ char-set=
+ char-set?
+ end-of-char-set?
+ list->char-set
+ string->char-set
+ ucs-range->char-set)
+
+;; String bindings.
+(define-bindings (guile)
+ absolute-file-name?
+ file-name-separator-string
+ file-name-separator?
+ in-vicinity
+ basename
+ dirname
+
+ list->string
+ make-string
+ reverse-list->string
+ string
+ string->list
+ string-any
+ string-any-c-code
+ string-append
+ string-append/shared
+ string-capitalize
+ string-ci<
+ string-ci<=
+ string-ci<=?
+ string-ci<>
+ string-ci<?
+ string-ci=
+ string-ci=?
+ string-ci>
+ string-ci>=
+ string-ci>=?
+ string-ci>?
+ string-compare
+ string-compare-ci
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate-reverse/shared
+ string-concatenate/shared
+ string-contains
+ string-contains-ci
+ string-copy
+ string-count
+ string-delete
+ string-downcase
+ string-drop
+ string-drop-right
+ string-every
+ string-filter
+ string-fold
+ string-fold-right
+ string-for-each
+ string-for-each-index
+ string-hash
+ string-hash-ci
+ string-index
+ string-index-right
+ string-join
+ string-length
+ string-map
+ string-normalize-nfc
+ string-normalize-nfd
+ string-normalize-nfkc
+ string-normalize-nfkd
+ string-null?
+ string-pad
+ string-pad-right
+ string-prefix-ci?
+ string-prefix-length
+ string-prefix-length-ci
+ string-prefix?
+ string-ref
+ string-replace
+ string-reverse
+ string-rindex
+ string-skip
+ string-skip-right
+ string-split
+ string-suffix-ci?
+ string-suffix-length
+ string-suffix-length-ci
+ string-suffix?
+ string-tabulate
+ string-take
+ string-take-right
+ string-titlecase
+ string-tokenize
+ string-trim
+ string-trim-both
+ string-trim-right
+ string-unfold
+ string-unfold-right
+ string-upcase
+ string-utf8-length
+ string<
+ string<=
+ string<=?
+ string<>
+ string<?
+ string=
+ string=?
+ string>
+ string>=
+ string>=?
+ string>?
+ string?
+ substring
+ substring/copy
+ substring/read-only
+ substring/shared
+ xsubstring)
+
+;; Symbol bindings.
+(define-bindings (guile)
+ string->symbol
+ string-ci->symbol
+ symbol->string
+ list->symbol
+ make-symbol
+ symbol
+ symbol-append
+ symbol-interned?
+ symbol?)
+
+;; Keyword bindings.
+(define-bindings (guile)
+ keyword?
+ keyword->symbol
+ symbol->keyword)
+
+;; Bit bindings.
+(define-bindings (guile)
+ ash
+ round-ash
+ logand
+ logcount
+ logior
+ lognot
+ logtest
+ logxor
+ logbit?)
+
+;; Char bindings.
+(define-bindings (guile)
+ char-alphabetic?
+ char-ci<=?
+ char-ci<?
+ char-ci=?
+ char-ci>=?
+ char-ci>?
+ char-downcase
+ char-general-category
+ char-is-both?
+ char-lower-case?
+ char-numeric?
+ char-titlecase
+ char-upcase
+ char-upper-case?
+ char-whitespace?
+ char<=?
+ char<?
+ char=?
+ char>=?
+ char>?
+ char?
+ char->integer
+ integer->char)
+
+;; List bindings.
+(define-bindings (guile)
+ list
+ list-cdr-ref
+ list-copy
+ list-head
+ list-index
+ list-ref
+ list-tail
+ list?
+ null?
+ make-list
+ append
+ delete
+ delq
+ delv
+ filter
+ length
+ member
+ memq
+ memv
+ merge
+ reverse)
+
+;; Pair bindings.
+(define-bindings (guile)
+ last-pair
+ pair?
+ caaaar
+ caaadr
+ caaar
+ caadar
+ caaddr
+ caadr
+ caar
+ cadaar
+ cadadr
+ cadar
+ caddar
+ cadddr
+ caddr
+ cadr
+ car
+ cdaaar
+ cdaadr
+ cdaar
+ cdadar
+ cdaddr
+ cdadr
+ cdar
+ cddaar
+ cddadr
+ cddar
+ cdddar
+ cddddr
+ cdddr
+ cddr
+ cdr
+ cons
+ cons*)
+
+;; Promise bindings.
+(define-bindings (guile)
+ force
+ delay
+ make-promise
+ promise?)
+
+;; Finally, the potluck bindings.
+(define-bindings (guix potluck packages)
+ potluck-package
+ potluck-source)
diff --git a/guix/potluck/packages.scm b/guix/potluck/packages.scm
index c7dae37..3bf2d67 100644
--- a/guix/potluck/packages.scm
+++ b/guix/potluck/packages.scm
@@ -62,6 +62,8 @@
pretty-print-potluck-source
pretty-print-potluck-package
+ load-potluck-package
+
validate-potluck-package
lower-potluck-source
@@ -191,6 +193,63 @@
(format port "~a (description ~s)\n" prefix description)
(format port "~a (license '~s))\n" prefix license)))
+;; Safely loading potluck files.
+(define (make-potluck-sandbox-module)
+ "Return a fresh module that only imports the potluck environment."
+ (let ((m (make-fresh-user-module)))
+ (purify-module! m)
+ (module-use! m (resolve-interface '(guix potluck environment)))
+ m))
+
+(define eval-in-sandbox
+ (delay
+ (cond
+ ((false-if-exception (resolve-interface '(ice-9 sandbox)))
+ => (lambda (m)
+ (module-ref m 'eval-in-sandbox)))
+ ((getenv "GUIX_POTLUCK_NO_SANDBOX")
+ (warn "No sandbox available; be warned!!!")
+ (lambda* (exp #:key time-limit allocation-limit module)
+ (eval exp module)))
+ (else
+ (error "sandbox facility unavailable")))))
+
+;; Because potluck package definitions come from untrusted parties, they need
+;; to be sandboxed to prevent them from harming the host system.
+(define* (load-potluck-package file #:key
+ (time-limit 1)
+ (allocation-limit 50e6))
+ "Read a sequence of Scheme expressions from @var{file} and evaluate them in
+a potluck sandbox. The result of evaluating that expression sequence should
+be a potluck package. Any syntax error reading the expressions or run-time
+error evaluating the expressions will throw an exception. The resulting
+potluck package will be validated with @code{validate-potluck-package}."
+ (define (read-expressions port)
+ (match (read port)
+ ((? eof-object?) '())
+ (exp (cons exp (read-expressions port)))))
+ (call-with-input-file file
+ (lambda (port)
+ (let ((exp (match (read-expressions port)
+ (() (error "no expressions in file" file))
+ (exps (cons 'begin exps))))
+ (mod (make-potluck-sandbox-module)))
+ (call-with-values
+ (lambda ()
+ ((force eval-in-sandbox) exp
+ #:time-limit time-limit
+ #:allocation-limit allocation-limit
+ #:module mod))
+ (lambda vals
+ (match vals
+ (() (error "no return values"))
+ ((val)
+ (unless (potluck-package? val)
+ (error "not a potluck package" val))
+ (validate-potluck-package val)
+ val)
+ (_ (error "too many return values" vals)))))))))
+
;; Editing.
(define (potluck-package-field-location package field)
- branch wip-potluck created (now 069e809), Andy Wingo, 2017/04/24
- 02/09: guix hash: Add --git option to hash a git checkout., Andy Wingo, 2017/04/24
- 06/09: gnu: Add find-package-binding., Andy Wingo, 2017/04/24
- 03/09: guix: Add git utility module., Andy Wingo, 2017/04/24
- 07/09: potluck: Add ability to lower potluck package to guix package., Andy Wingo, 2017/04/24
- 04/09: guix: Add "potluck" command., Andy Wingo, 2017/04/24
- 05/09: potluck: Add ability to load potluck package in sandbox.,
Andy Wingo <=
- 01/09: guix: Add "potluck" packages., Andy Wingo, 2017/04/24
- 09/09: doc: Document guix potluck., Andy Wingo, 2017/04/24
- 08/09: potluck: Add host-channel subcommand., Andy Wingo, 2017/04/24