guix/scripts/environment.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix scripts environment)
  22   #:use-module (guix ui)
  23   #:use-module (guix store)
  24   #:use-module ((guix status) #:select (with-status-verbosity))
  25   #:use-module (guix grafts)
  26   #:use-module (guix derivations)
  27   #:use-module (guix packages)
  28   #:use-module (guix profiles)
  29   #:use-module (guix search-paths)
  30   #:use-module (guix build utils)
  31   #:use-module (guix monads)
  32   #:use-module ((guix gexp) #:select (lower-object))
  33   #:use-module (guix scripts)
  34   #:use-module (guix scripts build)
  35   #:use-module (gnu build linux-container)
  36   #:use-module (gnu build accounts)
  37   #:use-module (gnu system linux-container)
  38   #:use-module (gnu system file-systems)
  39   #:use-module (gnu packages)
  40   #:use-module (gnu packages bash)
  41   #:use-module ((gnu packages bootstrap)
  42                 #:select (bootstrap-executable %bootstrap-guile))
  43   #:use-module (ice-9 format)
  44   #:use-module (ice-9 match)
  45   #:use-module (ice-9 rdelim)
  46   #:use-module (srfi srfi-1)
  47   #:use-module (srfi srfi-11)
  48   #:use-module (srfi srfi-26)
  49   #:use-module (srfi srfi-37)
  50   #:use-module (srfi srfi-98)
  51   #:export (assert-container-features
  52             guix-environment))
  53
  54 ;; Protect some env vars from purification.  Borrowed from nix-shell.
  55 (define %precious-variables
  56   '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
  57
  58 (define %default-shell
  59   (or (getenv "SHELL") "/bin/sh"))
  60
  61 (define (purify-environment white-list)
  62   "Unset all environment variables except those that match the regexps in
  63 WHITE-LIST and those listed in %PRECIOUS-VARIABLES.  A small number of
  64 variables such as 'HOME' and 'USER' are left untouched."
  65   (for-each unsetenv
  66             (remove (lambda (variable)
  67                       (or (member variable %precious-variables)
  68                           (find (cut regexp-exec <> variable)
  69                                 white-list)))
  70                     (match (get-environment-variables)
  71                       (((names . _) ...)
  72                        names)))))
  73
  74 (define* (create-environment profile manifest
  75                              #:key pure? (white-list '()))
  76   "Set the environment variables specified by MANIFEST for PROFILE.  When
  77 PURE?  is #t, unset the variables in the current environment except those that
  78 match the regexps in WHITE-LIST.  Otherwise, augment existing environment
  79 variables with additional search paths."
  80   (when pure?
  81     (purify-environment white-list))
  82   (for-each (match-lambda
  83               ((($ <search-path-specification> variable _ separator) . value)
  84                (let ((current (getenv variable)))
  85                  (setenv variable
  86                          (if (and current (not pure?))
  87                              (if separator
  88                                  (string-append value separator current)
  89                                  value)
  90                              value)))))
  91             (profile-search-paths profile manifest))
  92
  93   ;; Give users a way to know that they're in 'guix environment', so they can
  94   ;; adjust 'PS1' accordingly, for instance.  Set it to PROFILE so users can
  95   ;; conveniently access its contents.
  96   (setenv "GUIX_ENVIRONMENT" profile))
  97
  98 (define* (show-search-paths profile manifest #:key pure?)
  99   "Display the search paths of MANIFEST applied to PROFILE.  When PURE? is #t,
 100 do not augment existing environment variables with additional search paths."
 101   (for-each (match-lambda
 102               ((search-path . value)
 103                (display
 104                 (search-path-definition search-path value
 105                                         #:kind (if pure? 'exact 'prefix)))
 106                (newline)))
 107             (profile-search-paths profile manifest)))
 108
 109 (define (input->manifest-entry input)
 110   "Return a manifest entry for INPUT, or #f if INPUT does not correspond to a
 111 package."
 112   (match input
 113     ((_ (? package? package))
 114      (package->manifest-entry package))
 115     ((_ (? package? package) output)
 116      (package->manifest-entry package output))
 117     (_
 118      #f)))
 119
 120 (define (package-environment-inputs package)
 121   "Return a list of manifest entries corresponding to the transitive input
 122 packages for PACKAGE."
 123   ;; Remove non-package inputs such as origin records.
 124   (filter-map input->manifest-entry
 125               (bag-transitive-inputs (package->bag package))))
 126
 127 (define (show-help)
 128   (display (G_ "Usage: guix environment [OPTION]... PACKAGE... [-- COMMAND...]
 129 Build an environment that includes the dependencies of PACKAGE and execute
 130 COMMAND or an interactive shell in that environment.\n"))
 131   (display (G_ "
 132   -e, --expression=EXPR  create environment for the package that EXPR
 133                          evaluates to"))
 134   (display (G_ "
 135   -l, --load=FILE        create environment for the package that the code within
 136                          FILE evaluates to"))
 137   (display (G_ "
 138   -m, --manifest=FILE    create environment with the manifest from FILE"))
 139   (display (G_ "
 140       --ad-hoc           include all specified packages in the environment instead
 141                          of only their inputs"))
 142   (display (G_ "
 143       --pure             unset existing environment variables"))
 144   (display (G_ "
 145   -E, --preserve=REGEXP  preserve environment variables that match REGEXP"))
 146   (display (G_ "
 147       --search-paths     display needed environment variable definitions"))
 148   (display (G_ "
 149   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
 150   (display (G_ "
 151   -r, --root=FILE        make FILE a symlink to the result, and register it
 152                          as a garbage collector root"))
 153   (display (G_ "
 154   -C, --container        run command within an isolated container"))
 155   (display (G_ "
 156   -N, --network          allow containers to access the network"))
 157   (display (G_ "
 158   -P, --link-profile     link environment profile to ~/.guix-profile within
 159                          an isolated container"))
 160   (display (G_ "
 161   -u, --user=USER        instead of copying the name and home of the current
 162                          user into an isolated container, use the name USER
 163                          with home directory /home/USER"))
 164   (display (G_ "
 165       --no-cwd           do not share current working directory with an
 166                          isolated container"))
 167
 168   (display (G_ "
 169       --share=SPEC       for containers, share writable host file system
 170                          according to SPEC"))
 171   (display (G_ "
 172       --expose=SPEC      for containers, expose read-only host file system
 173                          according to SPEC"))
 174   (display (G_ "
 175   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 176   (display (G_ "
 177       --bootstrap        use bootstrap binaries to build the environment"))
 178   (newline)
 179   (show-build-options-help)
 180   (newline)
 181   (show-transformation-options-help)
 182   (newline)
 183   (display (G_ "
 184   -h, --help             display this help and exit"))
 185   (display (G_ "
 186   -V, --version          display version information and exit"))
 187   (newline)
 188   (show-bug-report-information))
 189
 190 (define %default-options
 191   `((system . ,(%current-system))
 192     (substitutes? . #t)
 193     (offload? . #t)
 194     (graft? . #t)
 195     (print-build-trace? . #t)
 196     (print-extended-build-trace? . #t)
 197     (multiplexed-build-output? . #t)
 198     (debug . 0)
 199     (verbosity . 1)))
 200
 201 (define (tag-package-arg opts arg)
 202   "Return a two-element list with the form (TAG ARG) that tags ARG with either
 203 'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
 204   ;; Normally, the transitive inputs to a package are added to an environment,
 205   ;; but the ad-hoc? flag changes the meaning of a package argument such that
 206   ;; the package itself is added to the environment instead.
 207   (if (assoc-ref opts 'ad-hoc?)
 208       `(ad-hoc-package ,arg)
 209       `(package ,arg)))
 210
 211 (define %options
 212   ;; Specification of the command-line options.
 213   (cons* (option '(#\h "help") #f #f
 214                  (lambda args
 215                    (show-help)
 216                    (exit 0)))
 217          (option '(#\V "version") #f #f
 218                  (lambda args
 219                    (show-version-and-exit "guix environment")))
 220          (option '("pure") #f #f
 221                  (lambda (opt name arg result)
 222                    (alist-cons 'pure #t result)))
 223          (option '(#\E "preserve") #t #f
 224                  (lambda (opt name arg result)
 225                    (alist-cons 'inherit-regexp
 226                                (make-regexp* arg)
 227                                result)))
 228          (option '("inherit") #t #f               ;deprecated
 229                  (lambda (opt name arg result)
 230                    (warning (G_ "'--inherit' is deprecated, \
 231 use '--preserve' instead~%"))
 232                    (alist-cons 'inherit-regexp
 233                                (make-regexp* arg)
 234                                result)))
 235          (option '("search-paths") #f #f
 236                  (lambda (opt name arg result)
 237                    (alist-cons 'search-paths #t result)))
 238          (option '(#\l "load") #t #f
 239                  (lambda (opt name arg result)
 240                    (alist-cons 'load
 241                                (tag-package-arg result arg)
 242                                result)))
 243          (option '(#\e "expression") #t #f
 244                  (lambda (opt name arg result)
 245                    (alist-cons 'expression
 246                                (tag-package-arg result arg)
 247                                result)))
 248          (option '(#\m "manifest") #t #f
 249                  (lambda (opt name arg result)
 250                    (alist-cons 'manifest
 251                                arg
 252                                result)))
 253          (option '("ad-hoc") #f #f
 254                  (lambda (opt name arg result)
 255                    (alist-cons 'ad-hoc? #t result)))
 256          (option '(#\n "dry-run") #f #f
 257                  (lambda (opt name arg result)
 258                    (alist-cons 'dry-run? #t result)))
 259          (option '(#\s "system") #t #f
 260                  (lambda (opt name arg result)
 261                    (alist-cons 'system arg
 262                                (alist-delete 'system result eq?))))
 263          (option '(#\C "container") #f #f
 264                  (lambda (opt name arg result)
 265                    (alist-cons 'container? #t result)))
 266          (option '(#\N "network") #f #f
 267                  (lambda (opt name arg result)
 268                    (alist-cons 'network? #t result)))
 269          (option '(#\P "link-profile") #f #f
 270                  (lambda (opt name arg result)
 271                    (alist-cons 'link-profile? #t result)))
 272          (option '(#\u "user") #t #f
 273                  (lambda (opt name arg result)
 274                    (alist-cons 'user arg
 275                                (alist-delete 'user result eq?))))
 276          (option '("no-cwd") #f #f
 277                  (lambda (opt name arg result)
 278                    (alist-cons 'no-cwd? #t result)))
 279          (option '("share") #t #f
 280                  (lambda (opt name arg result)
 281                    (alist-cons 'file-system-mapping
 282                                (specification->file-system-mapping arg #t)
 283                                result)))
 284          (option '("expose") #t #f
 285                  (lambda (opt name arg result)
 286                    (alist-cons 'file-system-mapping
 287                                (specification->file-system-mapping arg #f)
 288                                result)))
 289          (option '(#\r "root") #t #f
 290                  (lambda (opt name arg result)
 291                    (alist-cons 'gc-root arg result)))
 292          (option '(#\v "verbosity") #t #f
 293                  (lambda (opt name arg result)
 294                    (let ((level (string->number* arg)))
 295                      (alist-cons 'verbosity level
 296                                  (alist-delete 'verbosity result)))))
 297          (option '("bootstrap") #f #f
 298                  (lambda (opt name arg result)
 299                    (alist-cons 'bootstrap? #t result)))
 300
 301          (append %transformation-options
 302                  %standard-build-options)))
 303
 304 (define (pick-all alist key)
 305   "Return a list of values in ALIST associated with KEY."
 306   (define same-key? (cut eq? key <>))
 307
 308   (fold (lambda (pair memo)
 309           (match pair
 310             (((? same-key? k) . v)
 311              (cons v memo))
 312             (_ memo)))
 313         '() alist))
 314
 315 (define (options/resolve-packages store opts)
 316   "Return OPTS with package specification strings replaced by manifest entries
 317 for the corresponding packages."
 318   (define (manifest-entry=? e1 e2)
 319     (and (eq? (manifest-entry-item e1) (manifest-entry-item e2))
 320          (string=? (manifest-entry-output e1)
 321                    (manifest-entry-output e2))))
 322
 323   (define transform
 324     (cut (options->transformation opts) store <>))
 325
 326   (define* (package->manifest-entry* package #:optional (output "out"))
 327     (package->manifest-entry (transform package) output))
 328
 329   (define (packages->outputs packages mode)
 330     (match packages
 331       ((? package? package)
 332        (if (eq? mode 'ad-hoc-package)
 333            (list (package->manifest-entry* package))
 334            (package-environment-inputs package)))
 335       (((? package? package) (? string? output))
 336        (if (eq? mode 'ad-hoc-package)
 337            (list (package->manifest-entry* package output))
 338            (package-environment-inputs package)))
 339       ((lst ...)
 340        (append-map (cut packages->outputs <> mode) lst))))
 341
 342   (manifest
 343    (delete-duplicates
 344     (append-map (match-lambda
 345                   (('package 'ad-hoc-package (? string? spec))
 346                    (let-values (((package output)
 347                                  (specification->package+output spec)))
 348                      (list (package->manifest-entry* package output))))
 349                   (('package 'package (? string? spec))
 350                    (package-environment-inputs
 351                     (transform (specification->package+output spec))))
 352                   (('expression mode str)
 353                    ;; Add all the outputs of the package STR evaluates to.
 354                    (packages->outputs (read/eval str) mode))
 355                   (('load mode file)
 356                    ;; Add all the outputs of the package defined in FILE.
 357                    (let ((module (make-user-module '())))
 358                      (packages->outputs (load* file module) mode)))
 359                   (('manifest . file)
 360                    (let ((module (make-user-module '((guix profiles) (gnu)))))
 361                      (manifest-entries (load* file module))))
 362                   (_ '()))
 363                 opts)
 364     manifest-entry=?)))
 365
 366 (define (manifest->derivation manifest system bootstrap?)
 367   "Return the derivation for a profile of MANIFEST.
 368 BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
 369   (profile-derivation manifest
 370                       #:system system
 371
 372                       ;; Packages can have conflicting inputs, or explicit
 373                       ;; inputs that conflict with implicit inputs (e.g., gcc,
 374                       ;; gzip, etc.).  Thus, do not error out when we
 375                       ;; encounter collision.
 376                       #:allow-collisions? #t
 377
 378                       #:hooks (if bootstrap?
 379                                   '()
 380                                   %default-profile-hooks)
 381                       #:locales? (not bootstrap?)))
 382
 383 (define requisites* (store-lift requisites))
 384
 385 (define (inputs->requisites inputs)
 386   "Convert INPUTS, a list of input tuples or store path strings, into a set of
 387 requisite store items i.e. the union closure of all the inputs."
 388   (define (input->requisites input)
 389     (requisites*
 390      (match input
 391        ((drv output)
 392         (list (derivation->output-path drv output)))
 393        ((drv)
 394         (list (derivation->output-path drv)))
 395        ((? direct-store-path? path)
 396         (list path)))))
 397
 398   (mlet %store-monad ((reqs (mapm %store-monad
 399                                   input->requisites inputs)))
 400     (return (delete-duplicates (concatenate reqs)))))
 401
 402 (define (status->exit-code status)
 403   "Compute the exit code made from STATUS, a value as returned by 'waitpid',
 404 and suitable for 'exit'."
 405   ;; See <bits/waitstatus.h>.
 406   (or (status:exit-val status)
 407       (logior #x80 (status:term-sig status))))
 408
 409 (define exit/status (compose exit status->exit-code))
 410 (define primitive-exit/status (compose primitive-exit status->exit-code))
 411
 412 (define* (launch-environment command profile manifest
 413                              #:key pure? (white-list '()))
 414   "Run COMMAND in a new environment containing INPUTS, using the native search
 415 paths defined by the list PATHS.  When PURE?, pre-existing environment
 416 variables are cleared before setting the new ones, except those matching the
 417 regexps in WHITE-LIST."
 418   ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
 419   ;; application works.
 420   (sigaction SIGINT SIG_DFL)
 421   (create-environment profile manifest
 422                       #:pure? pure? #:white-list white-list)
 423   (match command
 424     ((program . args)
 425      (apply execlp program program args))))
 426
 427 (define* (launch-environment/fork command profile manifest
 428                                   #:key pure? (white-list '()))
 429   "Run COMMAND in a new process with an environment containing PROFILE, with
 430 the search paths specified by MANIFEST.  When PURE?, pre-existing environment
 431 variables are cleared before setting the new ones, except those matching the
 432 regexps in WHITE-LIST."
 433   (match (primitive-fork)
 434     (0 (launch-environment command profile manifest
 435                            #:pure? pure?
 436                            #:white-list white-list))
 437     (pid (match (waitpid pid)
 438            ((_ . status) status)))))
 439
 440 (define* (launch-environment/container #:key command bash user user-mappings
 441                                        profile manifest link-profile? network?
 442                                        map-cwd? (white-list '()))
 443   "Run COMMAND within a container that features the software in PROFILE.
 444 Environment variables are set according to the search paths of MANIFEST.
 445 The global shell is BASH, a file name for a GNU Bash binary in the
 446 store.  When NETWORK?, access to the host system network is permitted.
 447 USER-MAPPINGS, a list of file system mappings, contains the user-specified
 448 host file systems to mount inside the container.  If USER is not #f, each
 449 target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
 450 will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
 451 ~/.guix-profile to the environment profile.
 452
 453 Preserve environment variables whose name matches the one of the regexps in
 454 WHILE-LIST."
 455   (define (optional-mapping->fs mapping)
 456     (and (file-exists? (file-system-mapping-source mapping))
 457          (file-system-mapping->bind-mount mapping)))
 458
 459   (mlet %store-monad ((reqs (inputs->requisites
 460                              (list (direct-store-path bash) profile))))
 461     (return
 462      (let* ((cwd      (getcwd))
 463             (home     (getenv "HOME"))
 464             (uid      (if user 1000 (getuid)))
 465             (gid      (if user 1000 (getgid)))
 466             (passwd   (let ((pwd (getpwuid (getuid))))
 467                         (password-entry
 468                          (name (or user (passwd:name pwd)))
 469                          (real-name (if user
 470                                         ""
 471                                         (passwd:gecos pwd)))
 472                          (uid uid) (gid gid) (shell bash)
 473                          (directory (if user
 474                                         (string-append "/home/" user)
 475                                         (passwd:dir pwd))))))
 476             (groups   (list (group-entry (name "users") (gid gid))
 477                             (group-entry (gid 65534) ;the overflow GID
 478                                          (name "overflow"))))
 479             (home-dir (password-entry-directory passwd))
 480             (logname  (password-entry-name passwd))
 481             (environ  (filter (match-lambda
 482                                 ((variable . value)
 483                                  (find (cut regexp-exec <> variable)
 484                                        white-list)))
 485                               (get-environment-variables)))
 486             ;; Bind-mount all requisite store items, user-specified mappings,
 487             ;; /bin/sh, the current working directory, and possibly networking
 488             ;; configuration files within the container.
 489             (mappings
 490              (append
 491               (override-user-mappings
 492                user home
 493                (append user-mappings
 494                        ;; Share current working directory, unless asked not to.
 495                        (if map-cwd?
 496                            (list (file-system-mapping
 497                                   (source cwd)
 498                                   (target cwd)
 499                                   (writable? #t)))
 500                            '())))
 501               ;; Mappings for the union closure of all inputs.
 502               (map (lambda (dir)
 503                      (file-system-mapping
 504                       (source dir)
 505                       (target dir)
 506                       (writable? #f)))
 507                    reqs)))
 508             (file-systems (append %container-file-systems
 509                                   (if network?
 510                                       (filter-map optional-mapping->fs
 511                                                   %network-file-mappings)
 512                                       '())
 513                                   (map file-system-mapping->bind-mount
 514                                        mappings))))
 515        (exit/status
 516         (call-with-container file-systems
 517           (lambda ()
 518             ;; Setup global shell.
 519             (mkdir-p "/bin")
 520             (symlink bash "/bin/sh")
 521
 522             ;; Set a reasonable default PS1.
 523             (setenv "PS1" "\\u@\\h \\w [env]\\$ ")
 524
 525             ;; Setup directory for temporary files.
 526             (mkdir-p "/tmp")
 527             (for-each (lambda (var)
 528                         (setenv var "/tmp"))
 529                       ;; The same variables as in Nix's 'build.cc'.
 530                       '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
 531
 532             ;; Some programs expect USER and/or LOGNAME to be set.
 533             (setenv "LOGNAME" logname)
 534             (setenv "USER" logname)
 535
 536             ;; Create a dummy home directory.
 537             (mkdir-p home-dir)
 538             (setenv "HOME" home-dir)
 539
 540             ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
 541             ;; this allows programs expecting that path to continue working as
 542             ;; expected within a container.
 543             (when link-profile? (link-environment profile home-dir))
 544
 545             ;; Create a dummy /etc/passwd to satisfy applications that demand
 546             ;; to read it, such as 'git clone' over SSH, a valid use-case when
 547             ;; sharing the host's network namespace.
 548             (mkdir-p "/etc")
 549             (write-passwd (list passwd))
 550             (write-group groups)
 551
 552             ;; For convenience, start in the user's current working
 553             ;; directory or, if unmapped, the home directory.
 554             (chdir (if map-cwd?
 555                        (override-user-dir user home cwd)
 556                        home-dir))
 557
 558             ;; Set environment variables that match WHITE-LIST.
 559             (for-each (match-lambda
 560                         ((variable . value)
 561                          (setenv variable value)))
 562                       environ)
 563
 564             (primitive-exit/status
 565              ;; A container's environment is already purified, so no need to
 566              ;; request it be purified again.
 567              (launch-environment command profile manifest #:pure? #f)))
 568           #:guest-uid uid
 569           #:guest-gid gid
 570           #:namespaces (if network?
 571                            (delq 'net %namespaces) ; share host network
 572                            %namespaces)))))))
 573
 574 (define (user-override-home user)
 575   "Return home directory for override user USER."
 576   (string-append "/home/" user))
 577
 578 (define (override-user-mappings user home mappings)
 579   "If a username USER is provided, rewrite each HOME prefix in file system
 580 mappings MAPPINGS to a home directory determined by 'override-user-dir';
 581 otherwise, return MAPPINGS."
 582   (if (not user)
 583       mappings
 584       (map (lambda (mapping)
 585              (let ((target (file-system-mapping-target mapping)))
 586                (if (string-prefix? home target)
 587                    (file-system-mapping
 588                     (source    (file-system-mapping-source mapping))
 589                     (target    (override-user-dir user home target))
 590                     (writable? (file-system-mapping-writable? mapping)))
 591                    mapping)))
 592            mappings)))
 593
 594 (define (override-user-dir user home dir)
 595   "If username USER is provided, overwrite string prefix HOME in DIR with a
 596 directory determined by 'user-override-home'; otherwise, return DIR."
 597   (if (and user (string-prefix? home dir))
 598       (string-append (user-override-home user)
 599                      (substring dir (string-length home)))
 600       dir))
 601
 602 (define (link-environment profile home-dir)
 603   "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE."
 604   (let ((profile-dir (string-append home-dir "/.guix-profile")))
 605     (catch 'system-error
 606       (lambda ()
 607         (symlink profile profile-dir))
 608       (lambda args
 609         (if (= EEXIST (system-error-errno args))
 610             (leave (G_ "cannot link profile: '~a' already exists within container~%")
 611                    profile-dir)
 612             (apply throw args))))))
 613
 614 (define (environment-bash container? bootstrap? system)
 615   "Return a monadic value in the store monad for the version of GNU Bash
 616 needed in the environment for SYSTEM, if any.  If CONTAINER? is #f, return #f.
 617 If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
 618 Otherwise, return the derivation for the Bash package."
 619   (with-monad %store-monad
 620     (cond
 621      ((and container? (not bootstrap?))
 622       (package->derivation bash))
 623      ;; Use the bootstrap Bash instead.
 624      ((and container? bootstrap?)
 625       (lower-object (bootstrap-executable "bash" system)))
 626      (else
 627       (return #f)))))
 628
 629 (define (parse-args args)
 630   "Parse the list of command line arguments ARGS."
 631   (define (handle-argument arg result)
 632     (alist-cons 'package (tag-package-arg result arg) result))
 633
 634   ;; The '--' token is used to separate the command to run from the rest of
 635   ;; the operands.
 636   (let-values (((args command) (break (cut string=? "--" <>) args)))
 637     (let ((opts (parse-command-line args %options (list %default-options)
 638                                     #:argument-handler handle-argument)))
 639       (match command
 640         (() opts)
 641         (("--") opts)
 642         (("--" command ...) (alist-cons 'exec command opts))))))
 643
 644 (define (assert-container-features)
 645   "Check if containers can be created and exit with an informative error
 646 message if any test fails."
 647   (unless (user-namespace-supported?)
 648     (report-error (G_ "cannot create container: user namespaces unavailable\n"))
 649     (leave (G_ "is your kernel version < 3.10?\n")))
 650
 651   (unless (unprivileged-user-namespace-supported?)
 652     (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n"))
 653     (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n")))
 654
 655   (unless (setgroups-supported?)
 656     (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n"))
 657     (leave (G_ "is your kernel version < 3.19?\n"))))
 658
 659 (define (register-gc-root target root)
 660   "Make ROOT an indirect root to TARGET.  This is procedure is idempotent."
 661   (let* ((root (if (string-prefix? "/" root)
 662                    root
 663                    (string-append (canonicalize-path (dirname root))
 664                                   "/" root))))
 665     (catch 'system-error
 666       (lambda ()
 667         (symlink target root)
 668         ((store-lift add-indirect-root) root))
 669       (lambda args
 670         (if (and (= EEXIST (system-error-errno args))
 671                  (equal? (false-if-exception (readlink root)) target))
 672             (with-monad %store-monad
 673               (return #t))
 674             (apply throw args))))))
 675
 676 \f
 677 ;;;
 678 ;;; Entry point.
 679 ;;;
 680
 681 (define-command (guix-environment . args)
 682   (category development)
 683   (synopsis "spawn one-off software environments")
 684
 685   (with-error-handling
 686     (let* ((opts       (parse-args args))
 687            (pure?      (assoc-ref opts 'pure))
 688            (container? (assoc-ref opts 'container?))
 689            (link-prof? (assoc-ref opts 'link-profile?))
 690            (network?   (assoc-ref opts 'network?))
 691            (no-cwd?    (assoc-ref opts 'no-cwd?))
 692            (user       (assoc-ref opts 'user))
 693            (bootstrap? (assoc-ref opts 'bootstrap?))
 694            (system     (assoc-ref opts 'system))
 695            (command    (or (assoc-ref opts 'exec)
 696                            ;; Spawn a shell if the user didn't specify
 697                            ;; anything in particular.
 698                            (if container?
 699                                ;; The user's shell is likely not available
 700                                ;; within the container.
 701                                '("/bin/sh")
 702                                (list %default-shell))))
 703            (mappings   (pick-all opts 'file-system-mapping))
 704            (white-list (pick-all opts 'inherit-regexp)))
 705
 706       (when container? (assert-container-features))
 707
 708       (when (and (not container?) link-prof?)
 709         (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
 710       (when (and (not container?) user)
 711         (leave (G_ "'--user' cannot be used without '--container'~%")))
 712       (when (and (not container?) no-cwd?)
 713         (leave (G_ "--no-cwd cannot be used without --container~%")))
 714
 715
 716       (with-store store
 717         (with-build-handler (build-notifier #:use-substitutes?
 718                                             (assoc-ref opts 'substitutes?)
 719                                             #:verbosity
 720                                             (assoc-ref opts 'verbosity)
 721                                             #:dry-run?
 722                                             (assoc-ref opts 'dry-run?))
 723           (with-status-verbosity (assoc-ref opts 'verbosity)
 724             (define manifest
 725               (options/resolve-packages store opts))
 726
 727             (set-build-options-from-command-line store opts)
 728
 729             ;; Use the bootstrap Guile when requested.
 730             (parameterize ((%graft? (assoc-ref opts 'graft?))
 731                            (%guile-for-build
 732                             (package-derivation
 733                              store
 734                              (if bootstrap?
 735                                  %bootstrap-guile
 736                                  (default-guile)))))
 737               (run-with-store store
 738                 ;; Containers need a Bourne shell at /bin/sh.
 739                 (mlet* %store-monad ((bash       (environment-bash container?
 740                                                                    bootstrap?
 741                                                                    system))
 742                                      (prof-drv   (manifest->derivation
 743                                                   manifest system bootstrap?))
 744                                      (profile -> (derivation->output-path prof-drv))
 745                                      (gc-root -> (assoc-ref opts 'gc-root)))
 746
 747                   ;; First build the inputs.  This is necessary even for
 748                   ;; --search-paths.  Additionally, we might need to build bash for
 749                   ;; a container.
 750                   (mbegin %store-monad
 751                     (built-derivations (if (derivation? bash)
 752                                            (list prof-drv bash)
 753                                            (list prof-drv)))
 754                     (mwhen gc-root
 755                       (register-gc-root profile gc-root))
 756
 757                     (cond
 758                      ((assoc-ref opts 'search-paths)
 759                       (show-search-paths profile manifest #:pure? pure?)
 760                       (return #t))
 761                      (container?
 762                       (let ((bash-binary
 763                              (if bootstrap?
 764                                  (derivation->output-path bash)
 765                                  (string-append (derivation->output-path bash)
 766                                                 "/bin/sh"))))
 767                         (launch-environment/container #:command command
 768                                                       #:bash bash-binary
 769                                                       #:user user
 770                                                       #:user-mappings mappings
 771                                                       #:profile profile
 772                                                       #:manifest manifest
 773                                                       #:white-list white-list
 774                                                       #:link-profile? link-prof?
 775                                                       #:network? network?
 776                                                       #:map-cwd? (not no-cwd?))))
 777
 778                      (else
 779                       (return
 780                        (exit/status
 781                         (launch-environment/fork command profile manifest
 782                                                  #:white-list white-list
 783                                                  #:pure? pure?)))))))))))))))