From: ludo@gnu.org (Ludovic Courtès)
To: Mike Gerwitz <mtg@gnu.org>
Cc: help-guix@gnu.org
Subject: Re: Running IceCat in a container
Date: Mon, 29 Jan 2018 17:48:31 +0100 [thread overview]
Message-ID: <87fu6olig0.fsf@gnu.org> (raw)
In-Reply-To: <87po5xgtue.fsf@gnu.org> (Mike Gerwitz's message of "Thu, 25 Jan 2018 22:52:09 -0500")
[-- Attachment #1: Type: text/plain, Size: 37 bytes --]
And the attachment…
Ludo’.
[-- Attachment #2: the 'guix run' command --]
[-- Type: text/plain, Size: 5709 bytes --]
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 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))
\f
(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 <file-system> 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") %not-colon)
command))
(resolved (and=> full readlink*))
(prefix (and=> 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)))))))))
next prev parent reply other threads:[~2018-01-29 16:48 UTC|newest]
Thread overview: 36+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-16 1:56 Running IceCat in a container Mike Gerwitz
2018-01-16 16:30 ` Ludovic Courtès
2018-01-17 2:25 ` Mike Gerwitz
2018-01-17 19:05 ` Mike Gerwitz
2018-01-17 23:20 ` Leo Famulari
2018-01-18 1:53 ` Mike Gerwitz
2018-01-25 14:34 ` Ludovic Courtès
2018-01-25 22:16 ` Ludovic Courtès
2018-01-26 3:52 ` Mike Gerwitz
2018-01-29 16:47 ` Ludovic Courtès
2018-01-30 2:19 ` Ricardo Wurmus
2018-01-30 17:21 ` Running code from packs in containers Ludovic Courtès
2018-03-19 17:42 ` Running IceCat in a container ng0
2018-01-29 16:48 ` Ludovic Courtès [this message]
2018-01-26 3:29 ` [bug#30254] [PATCH 0/3] guix environment --user, --link-profile, --no-cwd Mike Gerwitz
2018-01-26 3:29 ` [bug#30255] [PATCH 1/3] scripts: environment: Add --link-profile Mike Gerwitz
2018-03-02 10:20 ` bug#30255: " Ludovic Courtès
2018-01-26 3:29 ` [bug#30257] [PATCH 2/3] scripts: environment: Add --user Mike Gerwitz
2018-03-02 10:33 ` Ludovic Courtès
2018-01-26 3:29 ` [bug#30256] [PATCH 3/3] scripts: environment: Add --no-cwd Mike Gerwitz
2018-03-02 10:54 ` Ludovic Courtès
2018-03-02 18:00 ` Mike Gerwitz
2018-03-03 14:44 ` Ludovic Courtès
2018-03-04 18:03 ` Mike Gerwitz
2018-03-04 22:24 ` Ludovic Courtès
2018-03-05 18:03 ` Mike Gerwitz
2018-03-06 10:20 ` Ludovic Courtès
2018-03-06 18:07 ` Mike Gerwitz
2018-10-17 12:19 ` [bug#30254] " Ludovic Courtès
2018-11-08 1:56 ` Mike Gerwitz
2019-06-29 23:27 ` Carl Dong
2019-07-07 13:18 ` [bug#30254] " Ludovic Courtès
2019-07-07 14:24 ` Carl Dong
2019-07-08 9:41 ` Ludovic Courtès
2021-07-14 13:18 ` [bug#30256] bug#30254: [PATCH 0/3] guix environment --user, --link-profile, --no-cwd Maxim Cournoyer
2019-07-07 13:45 ` [bug#30256] [PATCH 3/3] scripts: environment: Add --no-cwd Mike Gerwitz
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87fu6olig0.fsf@gnu.org \
--to=ludo@gnu.org \
--cc=help-guix@gnu.org \
--cc=mtg@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.