From mboxrd@z Thu Jan 1 00:00:00 1970 From: ludo@gnu.org (Ludovic =?utf-8?Q?Court=C3=A8s?=) Subject: Re: Running IceCat in a container Date: Mon, 29 Jan 2018 17:48:31 +0100 Message-ID: <87fu6olig0.fsf@gnu.org> References: <87vag2wopo.fsf@gnu.org> <877esh3gwd.fsf@gnu.org> <87tvvlrzlc.fsf@gnu.org> <87efmeuhvb.fsf@gnu.org> <87zi51r3cg.fsf@gnu.org> <87po5xgtue.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:53565) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1egCbl-0008GA-UG for help-guix@gnu.org; Mon, 29 Jan 2018 11:48:39 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1egCbi-0003m8-QX for help-guix@gnu.org; Mon, 29 Jan 2018 11:48:37 -0500 In-Reply-To: <87po5xgtue.fsf@gnu.org> (Mike Gerwitz's message of "Thu, 25 Jan 2018 22:52:09 -0500") List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: help-guix-bounces+gcggh-help-guix=m.gmane.org@gnu.org Sender: "Help-Guix" To: Mike Gerwitz Cc: help-guix@gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: base64 QW5kIHRoZSBhdHRhY2htZW504oCmDQoNCkx1ZG/igJkuDQoNCg== --=-=-= Content-Type: text/plain; charset=utf-8 Content-Disposition: inline; filename=run.scm Content-Transfer-Encoding: quoted-printable Content-Description: the 'guix run' command ;;; GNU Guix --- Functional package management for GNU ;;; Copyright =C2=A9 2018 Ludovic Court=C3=A8s ;;; ;;; 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 . (define-module (guix scripts run) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix packages) #:use-module (guix derivations) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (gnu build linux-container) #:use-module (gnu system file-systems) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (guix-run)) (define %options (list (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix run"))))) (define (show-help) (display (G_ "Usage: guix run PACKAGE COMMAND... Run COMMAND from PACKAGE in a container.\n")) (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) (define (bind-mount-spec/ro item) (and (file-exists? item) (file-system (device item) (mount-point item) (title 'device) (type "none") (flags '(bind-mount read-only)) (check? #f)))) (define (bind-mount-spec/rw item) (and (file-exists? item) (file-system (inherit (bind-mount-spec/ro item)) (flags '(bind-mount))))) (define (application-file-system-mappings items) "Return the list of objects corresponding to bind mounts required by the applications whose dependencies are listed in ITEMS." (define packages (map (compose (cut package-name->name+version <> #\-) store-path-package-name) items)) (define x11? (member "libx11" packages)) (define dbus? (member "dbus" packages)) (define alsa? (member "alsa-lib" packages)) (define pulseaudio? (member "pulseaudio" packages)) (let-syntax ((if (syntax-rules () ((_ condition body) (if condition (list body) '())))) (ro (identifier-syntax bind-mount-spec/ro)) (rw (identifier-syntax bind-mount-spec/rw))) `(,(rw "/var/run/nscd/socket") ,@(if x11? (rw (string-append (getenv "HOME") "/.Xauthority"))) ,@(if x11? (rw "/tmp/.X11-unix")) ,@(if dbus? (ro "/etc/machine-id")) ,@(if alsa? (rw "/dev/snd")) ,@(if pulseaudio? (rw (string-append (getenv "HOME") "/.pulse")))))) (define %not-colon (char-set-complement (char-set #\:))) (define (guix-run . args) (define (parse-options) ;; Return the alist of option values. With this hack, the first ;; non-option argument is considered to be the beginning of the command. (let-values (((args command) (span (cut string-prefix? "-" <>) args))) (args-fold* args %options (lambda (opt name arg result) (leave (G_ "~A: unrecognized option~%") name)) (lambda (arg result) (pk 'arg arg) (alist-cons 'argument arg result)) '()) command)) (with-error-handling (match (parse-options) ((command args ...) (with-store store (let* ((full (search-path (string-tokenize (getenv "PATH") %no= t-colon) command)) (resolved (and=3D> full readlink*)) (prefix (and=3D> resolved (lambda (file) (and (store-path? file) (direct-store-path file)))= ))) (unless full (leave (G_ "command '~a' not found~%") command)) (unless prefix (leave (G_ "command '~a' is not in '~a'~%") command (%store-prefix))) (let ((items (requisites store (list prefix))) (env (environ))) (call-with-container (append (map bind-mount-spec/ro items) (application-file-system-mappings items)) (lambda () (environ env) ;TODO: filter ENV (mkdir-p (getenv "HOME")) (chdir (getenv "HOME")) (newline) (catch #t (lambda () (apply execl resolved command args)) (lambda (key . args) (print-exception (current-error-port) #f key args) (exit 1)))) #:namespaces (delq 'net %namespaces))))))))) --=-=-=--