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