guix/scripts/environment.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 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 scripts build)
  30   #:use-module (gnu packages)
  31   #:use-module (ice-9 format)
  32   #:use-module (ice-9 match)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-37)
  36   #:use-module (srfi srfi-98)
  37   #:export (guix-environment))
  38
  39 (define (for-each-search-path proc inputs derivations pure?)
  40   "Apply PROC for each native search path in INPUTS in addition to 'PATH'.
  41 Use the output paths of DERIVATIONS to build each search path.  When PURE? is
  42 #t, the existing search path value is ignored.  Otherwise, the existing search
  43 path value is appended."
  44   (let ((directories (append-map (lambda (drv)
  45                                    (map (match-lambda
  46                                           ((_ . output)
  47                                            (derivation-output-path output)))
  48                                         (derivation-outputs drv)))
  49                                  derivations))
  50         (paths       (cons $PATH
  51                            (delete-duplicates
  52                             (append-map package-native-search-paths
  53                                         inputs)))))
  54     (for-each (match-lambda
  55                 ((($ <search-path-specification> variable _ sep) . value)
  56                  (let ((current  (getenv variable)))
  57                    (proc variable
  58                          (if (and current (not pure?))
  59                              (string-append value sep current)
  60                              value)))))
  61               (evaluate-search-paths paths directories))))
  62
  63 ;; Protect some env vars from purification.  Borrowed from nix-shell.
  64 (define %precious-variables
  65   '("HOME" "USER" "LOGNAME" "DISPLAY" "TERM" "TZ" "PAGER"))
  66
  67 (define (purify-environment)
  68   "Unset almost all environment variables.  A small number of variables such
  69 as 'HOME' and 'USER' are left untouched."
  70   (for-each unsetenv
  71             (remove (cut member <> %precious-variables)
  72                     (match (get-environment-variables)
  73                       (((names . _) ...)
  74                        names)))))
  75
  76 (define (create-environment inputs derivations pure?)
  77   "Set the needed environment variables for all packages within INPUTS.  When
  78 PURE? is #t, unset the variables in the current environment.  Otherwise,
  79 augment existing enviroment variables with additional search paths."
  80   (when pure? (purify-environment))
  81   (for-each-search-path setenv inputs derivations pure?))
  82
  83 (define (show-search-paths inputs derivations pure?)
  84   "Display the needed search paths to build an environment that contains the
  85 packages within INPUTS.  When PURE? is #t, do not augment existing environment
  86 variables with additional search paths."
  87   (for-each-search-path (lambda (variable value)
  88                           (format #t "export ~a=\"~a\"~%" variable value))
  89                         inputs derivations pure?))
  90
  91 (define (show-help)
  92   (display (_ "Usage: guix environment [OPTION]... PACKAGE...
  93 Build an environment that includes the dependencies of PACKAGE and execute a
  94 shell command in that environment.\n"))
  95   (display (_ "
  96   -e, --expression=EXPR  create environment for the package that EXPR
  97                          evaluates to"))
  98   (display (_ "
  99   -l, --load=FILE        create environment for the package that the code within
 100                          FILE evaluates to"))
 101   (display (_ "
 102   -E, --exec=COMMAND     execute COMMAND in new environment"))
 103   (display (_ "
 104       --pure             unset existing environment variables"))
 105   (display (_ "
 106       --search-paths     display needed environment variable definitions"))
 107   (newline)
 108   (show-build-options-help)
 109   (newline)
 110   (display (_ "
 111   -h, --help             display this help and exit"))
 112   (display (_ "
 113   -V, --version          display version information and exit"))
 114   (newline)
 115   (show-bug-report-information))
 116
 117 (define %default-options
 118   ;; Default to opening a new shell.
 119   `((exec . ,(or (getenv "SHELL") "/bin/sh"))
 120     (substitutes? . #t)
 121     (max-silent-time . 3600)
 122     (verbosity . 0)))
 123
 124 (define %options
 125   ;; Specification of the command-line options.
 126   (cons* (option '(#\h "help") #f #f
 127                  (lambda args
 128                    (show-help)
 129                    (exit 0)))
 130          (option '(#\V "version") #f #f
 131                  (lambda args
 132                    (show-version-and-exit "guix environment")))
 133          (option '("pure") #f #f
 134                  (lambda (opt name arg result)
 135                    (alist-cons 'pure #t result)))
 136          (option '(#\E "exec") #t #f
 137                  (lambda (opt name arg result)
 138                    (alist-cons 'exec arg result)))
 139          (option '("search-paths") #f #f
 140                  (lambda (opt name arg result)
 141                    (alist-cons 'search-paths #t result)))
 142          (option '(#\l "load") #t #f
 143                  (lambda (opt name arg result)
 144                    (alist-cons 'load arg result)))
 145          (option '(#\e "expression") #t #f
 146                  (lambda (opt name arg result)
 147                    (alist-cons 'expression arg result)))
 148          (option '(#\n "dry-run") #f #f
 149                  (lambda (opt name arg result)
 150                    (alist-cons 'dry-run? #t result)))
 151          %standard-build-options))
 152
 153 (define (pick-all alist key)
 154   "Return a list of values in ALIST associated with KEY."
 155   (define same-key? (cut eq? key <>))
 156
 157   (fold (lambda (pair memo)
 158           (match pair
 159             (((? same-key? k) . v)
 160              (cons v memo))
 161             (_ memo)))
 162         '() alist))
 163
 164 (define (options/resolve-packages opts)
 165   "Return OPTS with package specification strings replaced by actual
 166 packages."
 167   (map (match-lambda
 168         (('package . (? string? spec))
 169          `(package . ,(specification->package spec)))
 170         (('expression . str)
 171          (match (read/eval str)
 172            ((? package? p)
 173             `(package . ,p))))
 174         (('load . file)
 175          `(package . ,(load (string-append (getcwd) "/" file))))
 176         (opt opt))
 177        opts))
 178
 179 (define (packages->transitive-inputs packages)
 180   "Return a list of the transitive inputs for all PACKAGES."
 181   (define (transitive-inputs package)
 182     (filter-map (match-lambda
 183                  ((or (_ (? package? package))
 184                       (_ (? package? package) _))
 185                   package)
 186                  (_ #f))
 187                 (bag-transitive-inputs
 188                  (package->bag package))))
 189   (delete-duplicates
 190    (append-map transitive-inputs packages)))
 191
 192 ;; TODO: Deduplicate these.
 193 (define show-what-to-build*
 194   (store-lift show-what-to-build))
 195
 196 (define set-build-options-from-command-line*
 197   (store-lift set-build-options-from-command-line))
 198
 199 (define (build-inputs inputs opts)
 200   "Build the packages in INPUTS using the build options in OPTS."
 201   (let ((substitutes? (assoc-ref opts 'substitutes?))
 202         (dry-run? (assoc-ref opts 'dry-run?)))
 203     (mlet* %store-monad ((drvs (sequence %store-monad
 204                                          (map package->derivation inputs))))
 205       (mbegin %store-monad
 206         (show-what-to-build* drvs
 207                              #:use-substitutes? substitutes?
 208                              #:dry-run? dry-run?)
 209         (if dry-run?
 210             (return #f)
 211             (mbegin %store-monad
 212               (set-build-options-from-command-line* opts)
 213               (built-derivations drvs)
 214               (return drvs)))))))
 215
 216 ;; Entry point.
 217 (define (guix-environment . args)
 218   (define (handle-argument arg result)
 219     (alist-cons 'package arg result))
 220
 221   (with-error-handling
 222     (with-store store
 223       (let* ((opts  (parse-command-line args %options (list %default-options)
 224                                         #:argument-handler handle-argument))
 225              (pure? (assoc-ref opts 'pure))
 226              (command (assoc-ref opts 'exec))
 227              (inputs (packages->transitive-inputs
 228                       (pick-all (options/resolve-packages opts) 'package)))
 229              (drvs (run-with-store store
 230                      (mbegin %store-monad
 231                        (set-guile-for-build (default-guile))
 232                        (build-inputs inputs opts)))))
 233         (cond ((assoc-ref opts 'dry-run?)
 234                #t)
 235               ((assoc-ref opts 'search-paths)
 236                (show-search-paths inputs drvs pure?))
 237               (else
 238                (create-environment inputs drvs pure?)
 239                (system command)))))))