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 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-inputs))
  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 commencement)
  42   #:use-module (gnu packages guile)
  43   #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
  44   #:use-module (ice-9 format)
  45   #:use-module (ice-9 match)
  46   #:use-module (ice-9 rdelim)
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-11)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (srfi srfi-37)
  51   #:use-module (srfi srfi-98)
  52   #:export (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       --share=SPEC       for containers, share writable host file system
 166                          according to SPEC"))
 167   (display (G_ "
 168       --expose=SPEC      for containers, expose read-only host file system
 169                          according to SPEC"))
 170   (display (G_ "
 171   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
 172   (display (G_ "
 173       --bootstrap        use bootstrap binaries to build the environment"))
 174   (newline)
 175   (show-build-options-help)
 176   (newline)
 177   (show-transformation-options-help)
 178   (newline)
 179   (display (G_ "
 180   -h, --help             display this help and exit"))
 181   (display (G_ "
 182   -V, --version          display version information and exit"))
 183   (newline)
 184   (show-bug-report-information))
 185
 186 (define %default-options
 187   `((system . ,(%current-system))
 188     (substitutes? . #t)
 189     (build-hook? . #t)
 190     (graft? . #t)
 191     (print-build-trace? . #t)
 192     (print-extended-build-trace? . #t)
 193     (multiplexed-build-output? . #t)
 194     (debug . 0)
 195     (verbosity . 1)))
 196
 197 (define (tag-package-arg opts arg)
 198   "Return a two-element list with the form (TAG ARG) that tags ARG with either
 199 'ad-hoc' in OPTS has the 'ad-hoc?' key set to #t, or 'inputs' otherwise."
 200   ;; Normally, the transitive inputs to a package are added to an environment,
 201   ;; but the ad-hoc? flag changes the meaning of a package argument such that
 202   ;; the package itself is added to the environment instead.
 203   (if (assoc-ref opts 'ad-hoc?)
 204       `(ad-hoc-package ,arg)
 205       `(package ,arg)))
 206
 207 (define %options
 208   ;; Specification of the command-line options.
 209   (cons* (option '(#\h "help") #f #f
 210                  (lambda args
 211                    (show-help)
 212                    (exit 0)))
 213          (option '(#\V "version") #f #f
 214                  (lambda args
 215                    (show-version-and-exit "guix environment")))
 216          (option '("pure") #f #f
 217                  (lambda (opt name arg result)
 218                    (alist-cons 'pure #t result)))
 219          (option '(#\E "preserve") #t #f
 220                  (lambda (opt name arg result)
 221                    (alist-cons 'inherit-regexp
 222                                (make-regexp* arg)
 223                                result)))
 224          (option '("inherit") #t #f               ;deprecated
 225                  (lambda (opt name arg result)
 226                    (warning (G_ "'--inherit' is deprecated, \
 227 use '--preserve' instead~%"))
 228                    (alist-cons 'inherit-regexp
 229                                (make-regexp* arg)
 230                                result)))
 231          (option '("search-paths") #f #f
 232                  (lambda (opt name arg result)
 233                    (alist-cons 'search-paths #t result)))
 234          (option '(#\l "load") #t #f
 235                  (lambda (opt name arg result)
 236                    (alist-cons 'load
 237                                (tag-package-arg result arg)
 238                                result)))
 239          (option '(#\e "expression") #t #f
 240                  (lambda (opt name arg result)
 241                    (alist-cons 'expression
 242                                (tag-package-arg result arg)
 243                                result)))
 244          (option '(#\m "manifest") #t #f
 245                  (lambda (opt name arg result)
 246                    (alist-cons 'manifest
 247                                arg
 248                                result)))
 249          (option '("ad-hoc") #f #f
 250                  (lambda (opt name arg result)
 251                    (alist-cons 'ad-hoc? #t result)))
 252          (option '(#\n "dry-run") #f #f
 253                  (lambda (opt name arg result)
 254                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
 255          (option '(#\s "system") #t #f
 256                  (lambda (opt name arg result)
 257                    (alist-cons 'system arg
 258                                (alist-delete 'system result eq?))))
 259          (option '(#\C "container") #f #f
 260                  (lambda (opt name arg result)
 261                    (alist-cons 'container? #t result)))
 262          (option '(#\N "network") #f #f
 263                  (lambda (opt name arg result)
 264                    (alist-cons 'network? #t result)))
 265          (option '(#\P "link-profile") #f #f
 266                  (lambda (opt name arg result)
 267                    (alist-cons 'link-profile? #t result)))
 268          (option '(#\u "user") #t #f
 269                  (lambda (opt name arg result)
 270                    (alist-cons 'user arg
 271                                (alist-delete 'user result eq?))))
 272          (option '("share") #t #f
 273                  (lambda (opt name arg result)
 274                    (alist-cons 'file-system-mapping
 275                                (specification->file-system-mapping arg #t)
 276                                result)))
 277          (option '("expose") #t #f
 278                  (lambda (opt name arg result)
 279                    (alist-cons 'file-system-mapping
 280                                (specification->file-system-mapping arg #f)
 281                                result)))
 282          (option '(#\r "root") #t #f
 283                  (lambda (opt name arg result)
 284                    (alist-cons 'gc-root arg result)))
 285          (option '(#\v "verbosity") #t #f
 286                  (lambda (opt name arg result)
 287                    (let ((level (string->number* arg)))
 288                      (alist-cons 'verbosity level
 289                                  (alist-delete 'verbosity result)))))
 290          (option '("bootstrap") #f #f
 291                  (lambda (opt name arg result)
 292                    (alist-cons 'bootstrap? #t result)))
 293
 294          (append %transformation-options
 295                  %standard-build-options)))
 296
 297 (define (pick-all alist key)
 298   "Return a list of values in ALIST associated with KEY."
 299   (define same-key? (cut eq? key <>))
 300
 301   (fold (lambda (pair memo)
 302           (match pair
 303             (((? same-key? k) . v)
 304              (cons v memo))
 305             (_ memo)))
 306         '() alist))
 307
 308 (define (options/resolve-packages store opts)
 309   "Return OPTS with package specification strings replaced by manifest entries
 310 for the corresponding packages."
 311   (define (manifest-entry=? e1 e2)
 312     (and (eq? (manifest-entry-item e1) (manifest-entry-item e2))
 313          (string=? (manifest-entry-output e1)
 314                    (manifest-entry-output e2))))
 315
 316   (define transform
 317     (cut (options->transformation opts) store <>))
 318
 319   (define* (package->manifest-entry* package #:optional (output "out"))
 320     (package->manifest-entry (transform package) output))
 321
 322   (define (packages->outputs packages mode)
 323     (match packages
 324       ((? package? package)
 325        (if (eq? mode 'ad-hoc-package)
 326            (list (package->manifest-entry* package))
 327            (package-environment-inputs package)))
 328       (((? package? package) (? string? output))
 329        (if (eq? mode 'ad-hoc-package)
 330            (list (package->manifest-entry* package output))
 331            (package-environment-inputs package)))
 332       ((lst ...)
 333        (append-map (cut packages->outputs <> mode) lst))))
 334
 335   (manifest
 336    (delete-duplicates
 337     (append-map (match-lambda
 338                   (('package 'ad-hoc-package (? string? spec))
 339                    (let-values (((package output)
 340                                  (specification->package+output spec)))
 341                      (list (package->manifest-entry* package output))))
 342                   (('package 'package (? string? spec))
 343                    (package-environment-inputs
 344                     (transform (specification->package+output spec))))
 345                   (('expression mode str)
 346                    ;; Add all the outputs of the package STR evaluates to.
 347                    (packages->outputs (read/eval str) mode))
 348                   (('load mode file)
 349                    ;; Add all the outputs of the package defined in FILE.
 350                    (let ((module (make-user-module '())))
 351                      (packages->outputs (load* file module) mode)))
 352                   (('manifest . file)
 353                    (let ((module (make-user-module '((guix profiles) (gnu)))))
 354                      (manifest-entries (load* file module))))
 355                   (_ '()))
 356                 opts)
 357     manifest-entry=?)))
 358
 359 (define* (build-environment derivations opts)
 360   "Build the DERIVATIONS required by the environment using the build options
 361 in OPTS."
 362   (let ((substitutes? (assoc-ref opts 'substitutes?))
 363         (dry-run?     (assoc-ref opts 'dry-run?)))
 364     (mbegin %store-monad
 365       (show-what-to-build* derivations
 366                            #:use-substitutes? substitutes?
 367                            #:dry-run? dry-run?)
 368       (if dry-run?
 369           (return #f)
 370           (built-derivations derivations)))))
 371
 372 (define (manifest->derivation manifest system bootstrap?)
 373   "Return the derivation for a profile of MANIFEST.
 374 BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
 375   (profile-derivation manifest
 376                       #:system system
 377
 378                       ;; Packages can have conflicting inputs, or explicit
 379                       ;; inputs that conflict with implicit inputs (e.g., gcc,
 380                       ;; gzip, etc.).  Thus, do not error out when we
 381                       ;; encounter collision.
 382                       #:allow-collisions? #t
 383
 384                       #:hooks (if bootstrap?
 385                                   '()
 386                                   %default-profile-hooks)
 387                       #:locales? (not bootstrap?)))
 388
 389 (define requisites* (store-lift requisites))
 390
 391 (define (inputs->requisites inputs)
 392   "Convert INPUTS, a list of input tuples or store path strings, into a set of
 393 requisite store items i.e. the union closure of all the inputs."
 394   (define (input->requisites input)
 395     (requisites*
 396      (match input
 397        ((drv output)
 398         (list (derivation->output-path drv output)))
 399        ((drv)
 400         (list (derivation->output-path drv)))
 401        ((? direct-store-path? path)
 402         (list path)))))
 403
 404   (mlet %store-monad ((reqs (mapm %store-monad
 405                                   input->requisites inputs)))
 406     (return (delete-duplicates (concatenate reqs)))))
 407
 408 (define (status->exit-code status)
 409   "Compute the exit code made from STATUS, a value as returned by 'waitpid',
 410 and suitable for 'exit'."
 411   ;; See <bits/waitstatus.h>.
 412   (or (status:exit-val status)
 413       (logior #x80 (status:term-sig status))))
 414
 415 (define exit/status (compose exit status->exit-code))
 416 (define primitive-exit/status (compose primitive-exit status->exit-code))
 417
 418 (define* (launch-environment command profile manifest
 419                              #:key pure? (white-list '()))
 420   "Run COMMAND in a new environment containing INPUTS, using the native search
 421 paths defined by the list PATHS.  When PURE?, pre-existing environment
 422 variables are cleared before setting the new ones, except those matching the
 423 regexps in WHITE-LIST."
 424   ;; Properly handle SIGINT, so pressing C-c in an interactive terminal
 425   ;; application works.
 426   (sigaction SIGINT SIG_DFL)
 427   (create-environment profile manifest
 428                       #:pure? pure? #:white-list white-list)
 429   (match command
 430     ((program . args)
 431      (apply execlp program program args))))
 432
 433 (define* (launch-environment/fork command profile manifest
 434                                   #:key pure? (white-list '()))
 435   "Run COMMAND in a new process with an environment containing PROFILE, with
 436 the search paths specified by MANIFEST.  When PURE?, pre-existing environment
 437 variables are cleared before setting the new ones, except those matching the
 438 regexps in WHITE-LIST."
 439   (match (primitive-fork)
 440     (0 (launch-environment command profile manifest
 441                            #:pure? pure?
 442                            #:white-list white-list))
 443     (pid (match (waitpid pid)
 444            ((_ . status) status)))))
 445
 446 (define* (launch-environment/container #:key command bash user user-mappings
 447                                        profile manifest link-profile? network?)
 448   "Run COMMAND within a container that features the software in PROFILE.
 449 Environment variables are set according to the search paths of MANIFEST.
 450 The global shell is BASH, a file name for a GNU Bash binary in the
 451 store.  When NETWORK?, access to the host system network is permitted.
 452 USER-MAPPINGS, a list of file system mappings, contains the user-specified
 453 host file systems to mount inside the container.  If USER is not #f, each
 454 target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
 455 will be used for the passwd entry.  LINK-PROFILE? creates a symbolic link from
 456 ~/.guix-profile to the environment profile."
 457   (mlet %store-monad ((reqs (inputs->requisites
 458                              (list (direct-store-path bash) profile))))
 459     (return
 460      (let* ((cwd      (getcwd))
 461             (home     (getenv "HOME"))
 462             (uid      (if user 1000 (getuid)))
 463             (gid      (if user 1000 (getgid)))
 464             (passwd   (let ((pwd (getpwuid (getuid))))
 465                         (password-entry
 466                          (name (or user (passwd:name pwd)))
 467                          (real-name (if user
 468                                         ""
 469                                         (passwd:gecos pwd)))
 470                          (uid uid) (gid gid) (shell bash)
 471                          (directory (if user
 472                                         (string-append "/home/" user)
 473                                         (passwd:dir pwd))))))
 474             (groups   (list (group-entry (name "users") (gid gid))
 475                             (group-entry (gid 65534) ;the overflow GID
 476                                          (name "overflow"))))
 477             (home-dir (password-entry-directory passwd))
 478             ;; Bind-mount all requisite store items, user-specified mappings,
 479             ;; /bin/sh, the current working directory, and possibly networking
 480             ;; configuration files within the container.
 481             (mappings
 482              (override-user-mappings
 483               user home
 484               (append user-mappings
 485                       ;; Current working directory.
 486                       (list (file-system-mapping
 487                              (source cwd)
 488                              (target cwd)
 489                              (writable? #t)))
 490                       ;; When in Rome, do as Nix build.cc does: Automagically
 491                       ;; map common network configuration files.
 492                       (if network?
 493                           %network-file-mappings
 494                           '())
 495                       ;; Mappings for the union closure of all inputs.
 496                       (map (lambda (dir)
 497                              (file-system-mapping
 498                               (source dir)
 499                               (target dir)
 500                               (writable? #f)))
 501                            reqs))))
 502             (file-systems (append %container-file-systems
 503                                   (map file-system-mapping->bind-mount
 504                                        mappings))))
 505        (exit/status
 506         (call-with-container file-systems
 507           (lambda ()
 508             ;; Setup global shell.
 509             (mkdir-p "/bin")
 510             (symlink bash "/bin/sh")
 511
 512             ;; Set a reasonable default PS1.
 513             (setenv "PS1" "\\u@\\h \\w [env]\\$ ")
 514
 515             ;; Setup directory for temporary files.
 516             (mkdir-p "/tmp")
 517             (for-each (lambda (var)
 518                         (setenv var "/tmp"))
 519                       ;; The same variables as in Nix's 'build.cc'.
 520                       '("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
 521
 522             ;; Create a dummy home directory.
 523             (mkdir-p home-dir)
 524             (setenv "HOME" home-dir)
 525
 526             ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
 527             ;; this allows programs expecting that path to continue working as
 528             ;; expected within a container.
 529             (when link-profile? (link-environment profile home-dir))
 530
 531             ;; Create a dummy /etc/passwd to satisfy applications that demand
 532             ;; to read it, such as 'git clone' over SSH, a valid use-case when
 533             ;; sharing the host's network namespace.
 534             (mkdir-p "/etc")
 535             (write-passwd (list passwd))
 536             (write-group groups)
 537
 538             ;; For convenience, start in the user's current working
 539             ;; directory rather than the root directory.
 540             (chdir (override-user-dir user home cwd))
 541
 542             (primitive-exit/status
 543              ;; A container's environment is already purified, so no need to
 544              ;; request it be purified again.
 545              (launch-environment command profile manifest #:pure? #f)))
 546           #:guest-uid uid
 547           #:guest-gid gid
 548           #:namespaces (if network?
 549                            (delq 'net %namespaces) ; share host network
 550                            %namespaces)))))))
 551
 552 (define (user-override-home user)
 553   "Return home directory for override user USER."
 554   (string-append "/home/" user))
 555
 556 (define (override-user-mappings user home mappings)
 557   "If a username USER is provided, rewrite each HOME prefix in file system
 558 mappings MAPPINGS to a home directory determined by 'override-user-dir';
 559 otherwise, return MAPPINGS."
 560   (if (not user)
 561       mappings
 562       (map (lambda (mapping)
 563              (let ((target (file-system-mapping-target mapping)))
 564                (if (string-prefix? home target)
 565                    (file-system-mapping
 566                     (source    (file-system-mapping-source mapping))
 567                     (target    (override-user-dir user home target))
 568                     (writable? (file-system-mapping-writable? mapping)))
 569                    mapping)))
 570            mappings)))
 571
 572 (define (override-user-dir user home dir)
 573   "If username USER is provided, overwrite string prefix HOME in DIR with a
 574 directory determined by 'user-override-home'; otherwise, return DIR."
 575   (if (and user (string-prefix? home dir))
 576       (string-append (user-override-home user)
 577                      (substring dir (string-length home)))
 578       dir))
 579
 580 (define (link-environment profile home-dir)
 581   "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE."
 582   (let ((profile-dir (string-append home-dir "/.guix-profile")))
 583     (catch 'system-error
 584       (lambda ()
 585         (symlink profile profile-dir))
 586       (lambda args
 587         (if (= EEXIST (system-error-errno args))
 588             (leave (G_ "cannot link profile: '~a' already exists within container~%")
 589                    profile-dir)
 590             (apply throw args))))))
 591
 592 (define (environment-bash container? bootstrap? system)
 593   "Return a monadic value in the store monad for the version of GNU Bash
 594 needed in the environment for SYSTEM, if any.  If CONTAINER? is #f, return #f.
 595 If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash.
 596 Otherwise, return the derivation for the Bash package."
 597   (with-monad %store-monad
 598     (cond
 599      ((and container? (not bootstrap?))
 600       (package->derivation bash))
 601      ;; Use the bootstrap Bash instead.
 602      ((and container? bootstrap?)
 603       (interned-file
 604        (search-bootstrap-binary "bash" system)))
 605      (else
 606       (return #f)))))
 607
 608 (define (parse-args args)
 609   "Parse the list of command line arguments ARGS."
 610   (define (handle-argument arg result)
 611     (alist-cons 'package (tag-package-arg result arg) result))
 612
 613   ;; The '--' token is used to separate the command to run from the rest of
 614   ;; the operands.
 615   (let-values (((args command) (break (cut string=? "--" <>) args)))
 616     (let ((opts (parse-command-line args %options (list %default-options)
 617                                     #:argument-handler handle-argument)))
 618       (match command
 619         (() opts)
 620         (("--") opts)
 621         (("--" command ...) (alist-cons 'exec command opts))))))
 622
 623 (define (assert-container-features)
 624   "Check if containers can be created and exit with an informative error
 625 message if any test fails."
 626   (unless (user-namespace-supported?)
 627     (report-error (G_ "cannot create container: user namespaces unavailable\n"))
 628     (leave (G_ "is your kernel version < 3.10?\n")))
 629
 630   (unless (unprivileged-user-namespace-supported?)
 631     (report-error (G_ "cannot create container: unprivileged user cannot create user namespaces\n"))
 632     (leave (G_ "please set /proc/sys/kernel/unprivileged_userns_clone to \"1\"\n")))
 633
 634   (unless (setgroups-supported?)
 635     (report-error (G_ "cannot create container: /proc/self/setgroups does not exist\n"))
 636     (leave (G_ "is your kernel version < 3.19?\n"))))
 637
 638 (define (register-gc-root target root)
 639   "Make ROOT an indirect root to TARGET.  This is procedure is idempotent."
 640   (let* ((root (if (string-prefix? "/" root)
 641                    root
 642                    (string-append (canonicalize-path (dirname root))
 643                                   "/" root))))
 644     (catch 'system-error
 645       (lambda ()
 646         (symlink target root)
 647         ((store-lift add-indirect-root) root))
 648       (lambda args
 649         (if (and (= EEXIST (system-error-errno args))
 650                  (equal? (false-if-exception (readlink root)) target))
 651             (with-monad %store-monad
 652               (return #t))
 653             (apply throw args))))))
 654
 655 \f
 656 ;;;
 657 ;;; Entry point.
 658 ;;;
 659
 660 (define (guix-environment . args)
 661   (with-error-handling
 662     (let* ((opts       (parse-args args))
 663            (pure?      (assoc-ref opts 'pure))
 664            (container? (assoc-ref opts 'container?))
 665            (link-prof? (assoc-ref opts 'link-profile?))
 666            (network?   (assoc-ref opts 'network?))
 667            (user       (assoc-ref opts 'user))
 668            (bootstrap? (assoc-ref opts 'bootstrap?))
 669            (system     (assoc-ref opts 'system))
 670            (command    (or (assoc-ref opts 'exec)
 671                            ;; Spawn a shell if the user didn't specify
 672                            ;; anything in particular.
 673                            (if container?
 674                                ;; The user's shell is likely not available
 675                                ;; within the container.
 676                                '("/bin/sh")
 677                                (list %default-shell))))
 678            (mappings   (pick-all opts 'file-system-mapping))
 679            (white-list (pick-all opts 'inherit-regexp)))
 680
 681       (when container? (assert-container-features))
 682
 683       (when (and (not container?) link-prof?)
 684         (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
 685       (when (and (not container?) user)
 686         (leave (G_ "'--user' cannot be used without '--container'~%")))
 687
 688       (with-store store
 689         (with-status-verbosity (assoc-ref opts 'verbosity)
 690           (define manifest
 691             (options/resolve-packages store opts))
 692
 693           (set-build-options-from-command-line store opts)
 694
 695           ;; Use the bootstrap Guile when requested.
 696           (parameterize ((%graft? (assoc-ref opts 'graft?))
 697                          (%guile-for-build
 698                           (package-derivation
 699                            store
 700                            (if bootstrap?
 701                                %bootstrap-guile
 702                                (canonical-package guile-2.2)))))
 703             (run-with-store store
 704               ;; Containers need a Bourne shell at /bin/sh.
 705               (mlet* %store-monad ((bash       (environment-bash container?
 706                                                                  bootstrap?
 707                                                                  system))
 708                                    (prof-drv   (manifest->derivation
 709                                                 manifest system bootstrap?))
 710                                    (profile -> (derivation->output-path prof-drv))
 711                                    (gc-root -> (assoc-ref opts 'gc-root)))
 712
 713                 ;; First build the inputs.  This is necessary even for
 714                 ;; --search-paths.  Additionally, we might need to build bash for
 715                 ;; a container.
 716                 (mbegin %store-monad
 717                   (build-environment (if (derivation? bash)
 718                                          (list prof-drv bash)
 719                                          (list prof-drv))
 720                                      opts)
 721                   (mwhen gc-root
 722                     (register-gc-root profile gc-root))
 723
 724                   (cond
 725                    ((assoc-ref opts 'dry-run?)
 726                     (return #t))
 727                    ((assoc-ref opts 'search-paths)
 728                     (show-search-paths profile manifest #:pure? pure?)
 729                     (return #t))
 730                    (container?
 731                     (let ((bash-binary
 732                            (if bootstrap?
 733                                bash
 734                                (string-append (derivation->output-path bash)
 735                                               "/bin/sh"))))
 736                       (launch-environment/container #:command command
 737                                                     #:bash bash-binary
 738                                                     #:user user
 739                                                     #:user-mappings mappings
 740                                                     #:profile profile
 741                                                     #:manifest manifest
 742                                                     #:link-profile? link-prof?
 743                                                     #:network? network?)))
 744                    (else
 745                     (return
 746                      (exit/status
 747                       (launch-environment/fork command profile manifest
 748                                                #:white-list white-list
 749                                                #:pure? pure?))))))))))))))