guix/build/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build profiles)
  20   #:use-module (guix build union)
  21   #:use-module (guix build utils)
  22   #:use-module (guix search-paths)
  23   #:use-module (srfi srfi-26)
  24   #:use-module (ice-9 ftw)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 pretty-print)
  27   #:re-export (symlink-relative)                  ;for convenience
  28   #:export (ensure-writable-directory
  29             build-profile))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; Build a user profile (essentially the union of all the installed packages)
  34 ;;; with its associated meta-data.
  35 ;;;
  36 ;;; Code:
  37
  38 (define (abstract-profile profile)
  39   "Return a procedure that replaces PROFILE in VALUE with a reference to the
  40 'GUIX_PROFILE' environment variable.  This allows users to specify what the
  41 user-friendly name of the profile is, for instance ~/.guix-profile rather than
  42 /gnu/store/...-profile."
  43   (let ((replacement (string-append "${GUIX_PROFILE:-" profile "}"))
  44         (crop        (cute string-drop <> (string-length profile))))
  45     (match-lambda
  46       ((search-path . value)
  47        (match (search-path-specification-separator search-path)
  48          (#f
  49           (cons search-path
  50                 (string-append replacement (crop value))))
  51          ((? string? separator)
  52           (let ((items (string-tokenize* value separator)))
  53             (cons search-path
  54                   (string-join (map (lambda (str)
  55                                       (string-append replacement (crop str)))
  56                                     items)
  57                                separator)))))))))
  58
  59 (define (write-environment-variable-definition port)
  60   "Write the given environment variable definition to PORT."
  61   (match-lambda
  62     ((search-path . value)
  63      (display (search-path-definition search-path value #:kind 'prefix)
  64               port)
  65      (newline port))))
  66
  67 (define (build-etc/profile output search-paths)
  68   "Build the 'OUTPUT/etc/profile' shell file containing environment variable
  69 definitions for all the SEARCH-PATHS."
  70   (define file
  71     (string-append output "/etc/profile"))
  72
  73   (mkdir-p (dirname file))
  74   (when (file-exists? file)
  75     (delete-file file))
  76
  77   (call-with-output-file file
  78     (lambda (port)
  79       ;; The use of $GUIX_PROFILE described below is not great.  Another
  80       ;; option would have been to use "$1" and have users run:
  81       ;;
  82       ;;   source ~/.guix-profile/etc/profile ~/.guix-profile
  83       ;;
  84       ;; However, when 'source' is used with no arguments, $1 refers to the
  85       ;; first positional parameter of the calling script, so we cannot rely
  86       ;; on it.
  87       (display "\
  88 # Source this file to define all the relevant environment variables in Bash
  89 # for this profile.  You may want to define the 'GUIX_PROFILE' environment
  90 # variable to point to the \"visible\" name of the profile, like this:
  91 #
  92 #  GUIX_PROFILE=/path/to/profile ; \\
  93 #  source /path/to/profile/etc/profile
  94 #
  95 # When GUIX_PROFILE is undefined, the various environment variables refer
  96 # to this specific profile generation.
  97 \n" port)
  98       (let ((variables (evaluate-search-paths search-paths
  99                                               (list output))))
 100         (for-each (write-environment-variable-definition port)
 101                   (map (abstract-profile output) variables))))))
 102
 103 (define* (ensure-writable-directory directory
 104                                     #:key (symlink symlink))
 105   "Ensure DIRECTORY exists and is writable.  If DIRECTORY is currently a
 106 symlink (to a read-only directory in the store), then delete the symlink and
 107 instead make DIRECTORY a \"real\" directory containing symlinks."
 108   (define (absolute? file)
 109     (string-prefix? "/" file))
 110
 111   (define (unsymlink link)
 112     (let* ((target (match (readlink link)
 113                      ((? absolute? target)
 114                       target)
 115                      ((? string? relative)
 116                       (string-append (dirname link) "/" relative))))
 117            ;; TARGET might itself be a symlink, so append "/" to make sure
 118            ;; 'scandir' enters it.
 119            (files  (scandir (string-append target "/")
 120                             (negate (cut member <> '("." ".."))))))
 121       (delete-file link)
 122       (mkdir link)
 123       (for-each (lambda (file)
 124                   (symlink (string-append target "/" file)
 125                            (string-append link "/" file)))
 126                 files)))
 127
 128   (catch 'system-error
 129     (lambda ()
 130       (mkdir directory))
 131     (lambda args
 132       (let ((errno (system-error-errno args)))
 133         (if (= errno EEXIST)
 134             (let ((stat (lstat directory)))
 135               (case (stat:type stat)
 136                 ((symlink)
 137                  ;; "Unsymlink" DIRECTORY so that it is writable.
 138                  (unsymlink directory))
 139                 ((directory)
 140                  #t)
 141                 (else
 142                  (error "cannot mkdir because a same-named file exists"
 143                         directory))))
 144             (apply throw args))))))
 145
 146 (define* (build-profile output inputs
 147                         #:key manifest search-paths
 148                         (symlink symlink))
 149   "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to
 150 create symlinks.  Write MANIFEST, an sexp, to OUTPUT/manifest.  Create
 151 OUTPUT/etc/profile with Bash definitions for -all the variables listed in
 152 SEARCH-PATHS."
 153   (define manifest-file
 154     (string-append output "/manifest"))
 155
 156   ;; Make the symlinks.
 157   (union-build output inputs
 158                #:symlink symlink
 159                #:log-port (%make-void-port "w"))
 160
 161   ;; If one of the INPUTS provides a '/manifest' file, delete it.  That can
 162   ;; happen if MANIFEST contains something such as a Guix instance, which is
 163   ;; ultimately built as a profile.
 164   (when (file-exists? manifest-file)
 165     (delete-file manifest-file))
 166
 167   ;; Store meta-data.
 168   (call-with-output-file manifest-file
 169     (lambda (p)
 170       (pretty-print manifest p)))
 171
 172   ;; Make sure we can write to 'OUTPUT/etc'.  'union-build' above could have
 173   ;; made 'etc' a symlink to a read-only sub-directory in the store so we need
 174   ;; to work around that.
 175   (ensure-writable-directory (string-append output "/etc")
 176                              #:symlink symlink)
 177
 178   ;; Write 'OUTPUT/etc/profile'.
 179   (build-etc/profile output search-paths))
 180
 181 ;;; profile.scm ends here