From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:43213) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d2l9U-0005N7-1g for guix-patches@gnu.org; Mon, 24 Apr 2017 17:04:11 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d2l9R-0006Gp-7r for guix-patches@gnu.org; Mon, 24 Apr 2017 17:04:08 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40361) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d2l9R-0006GJ-3M for guix-patches@gnu.org; Mon, 24 Apr 2017 17:04:05 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d2l9Q-0004lC-S7 for guix-patches@gnu.org; Mon, 24 Apr 2017 17:04:04 -0400 Subject: bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox. Resent-Message-ID: From: Andy Wingo Date: Mon, 24 Apr 2017 22:59:19 +0200 Message-Id: <20170424205923.27726-5-wingo@igalia.com> In-Reply-To: <20170424205923.27726-1-wingo@igalia.com> References: <20170424205923.27726-1-wingo@igalia.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26645@debbugs.gnu.org * 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(+) create mode 100644 guix/potluck/environment.scm diff --git a/Makefile.am b/Makefile.am index 295d7b3a6..628283b57 100644 --- a/Makefile.am +++ b/Makefile.am @@ -128,6 +128,7 @@ MODULES =3D \ 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 000000000..f28ca11d5 --- /dev/null +++ b/guix/potluck/environment.scm @@ -0,0 +1,538 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2017 Andy Wingo +;;; +;;; 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 (a= t +;;; 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 . + +(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 + =CE=BB) + +;; 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=3D> + 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- + < + <=3D + =3D + > + >=3D + 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<=3D + char-set=3D + 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<=3D + string-ci<=3D? + string-ci<> + string-ci + string-ci>=3D + string-ci>=3D? + 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<=3D + string<=3D? + string<> + string + string>=3D + string>=3D? + 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<=3D? + char-ci=3D? + 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<=3D? + char=3D? + 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 c7dae3791..3bf2d67c1 100644 --- a/guix/potluck/packages.scm +++ b/guix/potluck/packages.scm @@ -62,6 +62,8 @@ pretty-print-potluck-source pretty-print-potluck-package =20 + load-potluck-package + validate-potluck-package =20 lower-potluck-source @@ -191,6 +193,63 @@ (format port "~a (description ~s)\n" prefix description) (format port "~a (license '~s))\n" prefix license))) =20 +;; 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))) + =3D> (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 th= em in +a potluck sandbox. The result of evaluating that expression sequence sh= ould +be a potluck package. Any syntax error reading the expressions or run-t= ime +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. =20 (define (potluck-package-field-location package field) --=20 2.12.2