guix/scripts/environment.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
   3 ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts environment)
  21   #:use-module (guix ui)
  22   #:use-module (guix store)
  23   #:use-module (guix derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix profiles)
  26   #:use-module (guix search-paths)
  27   #:use-module (guix utils)
  28   #:use-module (guix monads)
  29   #:use-module ((guix gexp) #:select (lower-inputs))
  30   #:use-module (guix scripts build)
  31   #:use-module (gnu packages)
  32   #:use-module (ice-9 format)
  33   #:use-module (ice-9 match)
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-26)
  36   #:use-module (srfi srfi-37)
  37   #:use-module (srfi srfi-98)
  38   #:export (guix-environment))
  39
  40 (define (evaluate-input-search-paths inputs search-paths)
  41   "Evaluate SEARCH-PATHS, a list of search-path specifications, for the
  42 directories corresponding to INPUTS, a list of (DERIVATION) or (DERIVATION
  43 OUTPUT) tuples."
  44   (let ((directories (map (match-lambda
  45                             (((? derivation? drv))
  46                              (derivation->output-path drv))
  47                             (((? derivation? drv) output)
  48                              (derivation->output-path drv output))
  49                             (((? string? item))
  50                              item))
  51                           inputs)))
  52     (evaluate-search-paths search-paths directories)))
  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 (purify-environment)
  59   "Unset almost all environment variables.  A small number of variables such
  60 as 'HOME' and 'USER' are left untouched."
  61   (for-each unsetenv
  62             (remove (cut member <> %precious-variables)
  63                     (match (get-environment-variables)
  64                       (((names . _) ...)
  65                        names)))))
  66
  67 (define (create-environment inputs paths pure?)
  68   "Set the environment variables specified by PATHS for all the packages
  69 within INPUTS.  When PURE? is #t, unset the variables in the current
  70 environment.  Otherwise, augment existing enviroment variables with additional
  71 search paths."
  72   (when pure? (purify-environment))
  73   (for-each (match-lambda
  74               ((($ <search-path-specification> variable _ separator) . value)
  75                (let ((current (getenv variable)))
  76                  (setenv variable
  77                          (if (and current (not pure?))
  78                              (string-append value separator current)
  79                              value)))))
  80             (evaluate-input-search-paths inputs paths)))
  81
  82 (define (show-search-paths inputs search-paths pure?)
  83   "Display SEARCH-PATHS applied to the packages specified by INPUTS, a list of
  84  (DERIVATION) or (DERIVATION OUTPUT) tuples.  When PURE? is #t, do not augment
  85 existing environment variables with additional search paths."
  86   (for-each (match-lambda
  87               ((search-path . value)
  88                (display
  89                 (search-path-definition search-path value
  90                                         #:kind (if pure? 'exact 'prefix)))
  91                (newline)))
  92             (evaluate-input-search-paths inputs search-paths)))
  93
  94 (define (package+propagated-inputs package)
  95   "Return the union of PACKAGE and its transitive propagated inputs."
  96   `((,(package-name package) ,package)
  97     ,@(package-transitive-propagated-inputs package)))
  98
  99 (define (show-help)
 100   (display (_ "Usage: guix environment [OPTION]... PACKAGE...
 101 Build an environment that includes the dependencies of PACKAGE and execute a
 102 shell command in that environment.\n"))
 103   (display (_ "
 104   -e, --expression=EXPR  create environment for the package that EXPR
 105                          evaluates to"))
 106   (display (_ "
 107   -l, --load=FILE        create environment for the package that the code within
 108                          FILE evaluates to"))
 109   (display (_ "
 110   -E, --exec=COMMAND     execute COMMAND in new environment"))
 111   (display (_ "
 112       --ad-hoc           include all specified packages in the environment instead
 113                          of only their inputs"))
 114   (display (_ "
 115       --pure             unset existing environment variables"))
 116   (display (_ "
 117       --search-paths     display needed environment variable definitions"))
 118   (newline)
 119   (show-build-options-help)
 120   (newline)
 121   (display (_ "
 122   -h, --help             display this help and exit"))
 123   (display (_ "
 124   -V, --version          display version information and exit"))
 125   (newline)
 126   (show-bug-report-information))
 127
 128 (define %default-options
 129   ;; Default to opening a new shell.
 130   `((exec . ,(or (getenv "SHELL") "/bin/sh"))
 131     (substitutes? . #t)
 132     (max-silent-time . 3600)
 133     (verbosity . 0)))
 134
 135 (define %options
 136   ;; Specification of the command-line options.
 137   (cons* (option '(#\h "help") #f #f
 138                  (lambda args
 139                    (show-help)
 140                    (exit 0)))
 141          (option '(#\V "version") #f #f
 142                  (lambda args
 143                    (show-version-and-exit "guix environment")))
 144          (option '("pure") #f #f
 145                  (lambda (opt name arg result)
 146                    (alist-cons 'pure #t result)))
 147          (option '(#\E "exec") #t #f
 148                  (lambda (opt name arg result)
 149                    (alist-cons 'exec arg result)))
 150          (option '("search-paths") #f #f
 151                  (lambda (opt name arg result)
 152                    (alist-cons 'search-paths #t result)))
 153          (option '(#\l "load") #t #f
 154                  (lambda (opt name arg result)
 155                    (alist-cons 'load arg result)))
 156          (option '(#\e "expression") #t #f
 157                  (lambda (opt name arg result)
 158                    (alist-cons 'expression arg result)))
 159          (option '("ad-hoc") #f #f
 160                  (lambda (opt name arg result)
 161                    (alist-cons 'ad-hoc? #t result)))
 162          (option '(#\n "dry-run") #f #f
 163                  (lambda (opt name arg result)
 164                    (alist-cons 'dry-run? #t result)))
 165          %standard-build-options))
 166
 167 (define (pick-all alist key)
 168   "Return a list of values in ALIST associated with KEY."
 169   (define same-key? (cut eq? key <>))
 170
 171   (fold (lambda (pair memo)
 172           (match pair
 173             (((? same-key? k) . v)
 174              (cons v memo))
 175             (_ memo)))
 176         '() alist))
 177
 178 (define (options/resolve-packages opts)
 179   "Return OPTS with package specification strings replaced by actual
 180 packages."
 181   (map (match-lambda
 182         (('package . (? string? spec))
 183          `(package . ,(specification->package spec)))
 184         (('expression . str)
 185          (match (read/eval str)
 186            ((? package? p)
 187             `(package . ,p))))
 188         (('load . file)
 189          `(package . ,(load (string-append (getcwd) "/" file))))
 190         (opt opt))
 191        opts))
 192
 193 (define (build-inputs inputs opts)
 194   "Build the derivations in INPUTS, a list of (DERIVATION) or (DERIVATION
 195 OUTPUT) tuples, using the build options in OPTS."
 196   (let ((substitutes? (assoc-ref opts 'substitutes?))
 197         (dry-run?     (assoc-ref opts 'dry-run?)))
 198     (match inputs
 199       (((derivations _ ...) ...)
 200        (mbegin %store-monad
 201          (show-what-to-build* derivations
 202                               #:use-substitutes? substitutes?
 203                               #:dry-run? dry-run?)
 204          (if dry-run?
 205              (return #f)
 206              (mbegin %store-monad
 207                (set-build-options-from-command-line* opts)
 208                (built-derivations derivations)
 209                (return derivations))))))))
 210
 211 ;; Entry point.
 212 (define (guix-environment . args)
 213   (define (handle-argument arg result)
 214     (alist-cons 'package arg result))
 215
 216   (with-error-handling
 217     (let* ((opts     (parse-command-line args %options (list %default-options)
 218                                          #:argument-handler handle-argument))
 219            (pure?    (assoc-ref opts 'pure))
 220            (ad-hoc?  (assoc-ref opts 'ad-hoc?))
 221            (command  (assoc-ref opts 'exec))
 222            (packages (pick-all (options/resolve-packages opts) 'package))
 223            (inputs   (if ad-hoc?
 224                          (append-map package+propagated-inputs packages)
 225                          (append-map (compose bag-transitive-inputs
 226                                               package->bag)
 227                                      packages)))
 228            (paths    (delete-duplicates
 229                       (cons $PATH
 230                             (append-map (match-lambda
 231                                           ((label (? package? p) _ ...)
 232                                            (package-native-search-paths p))
 233                                           (_
 234                                            '()))
 235                                         inputs))
 236                       eq?)))
 237       (with-store store
 238         (run-with-store store
 239           (mlet %store-monad ((inputs (lower-inputs
 240                                        (map (match-lambda
 241                                               ((label item)
 242                                                (list item))
 243                                               ((label item output)
 244                                                (list item output)))
 245                                             inputs)
 246                                        #:system (%current-system))))
 247             (mbegin %store-monad
 248               ;; First build INPUTS.  This is necessary even for
 249               ;; --search-paths.
 250               (build-inputs inputs opts)
 251               (cond ((assoc-ref opts 'dry-run?)
 252                      (return #t))
 253                     ((assoc-ref opts 'search-paths)
 254                      (show-search-paths inputs paths pure?)
 255                      (return #t))
 256                     (else
 257                      (create-environment inputs paths pure?)
 258                      (return (system command)))))))))))