[jackhill/guix/guix.git] / guix-package.in

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code

prefix="@prefix@"
datarootdir="@datarootdir@"

GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
export GUILE_LOAD_COMPILED_PATH

main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
         -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix-package)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix config)
  #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-37)
  #:use-module (gnu packages)
  #:use-module ((gnu packages base) #:select (guile-final))
  #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
  #:export (guix-package))

(define %store
  (make-parameter #f))

\f
;;;
;;; User environment.
;;;

(define %user-environment-directory
  (and=> (getenv "HOME")
         (cut string-append <> "/.guix-profile")))

(define %profile-directory
  (string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
                 (or (and=> (getenv "USER")
                            (cut string-append "per-user/" <>))
                     "default")))

(define %current-profile
  ;; Call it `guix-profile', not `profile', to allow Guix profiles to
  ;; coexist with Nix profiles.
  (string-append %profile-directory "/guix-profile"))

(define (profile-manifest profile)
  "Return the PROFILE's manifest."
  (let ((manifest (string-append profile "/manifest")))
    (if (file-exists? manifest)
        (call-with-input-file manifest read)
        '(manifest (version 0) (packages ())))))

(define (manifest-packages manifest)
  "Return the packages listed in MANIFEST."
  (match manifest
    (('manifest ('version 0) ('packages packages))
     packages)
    (_
     (error "unsupported manifest format" manifest))))

(define (profile-regexp profile)
  "Return a regular expression that matches PROFILE's name and number."
  (make-regexp (string-append "^" (regexp-quote (basename profile))
                              "-([0-9]+)")))

(define (profile-numbers profile)
  "Return the list of generation numbers of PROFILE, or '(0) if no
former profiles were found."
  (define* (scandir name #:optional (select? (const #t))
                    (entry<? (@ (ice-9 i18n) string-locale<?)))
    ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
    (define (enter? dir stat result)
      (and stat (string=? dir name)))

    (define (visit basename result)
      (if (select? basename)
          (cons basename result)
          result))

    (define (leaf name stat result)
      (and result
           (visit (basename name) result)))

    (define (down name stat result)
      (visit "." '()))

    (define (up name stat result)
      (visit ".." result))

    (define (skip name stat result)
      ;; All the sub-directories are skipped.
      (visit (basename name) result))

    (define (error name* stat errno result)
      (if (string=? name name*)             ; top-level NAME is unreadable
          result
          (visit (basename name*) result)))

    (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
           (lambda (files)
             (sort files entry<?))))

  (match (scandir (dirname profile)
                  (cute regexp-exec (profile-regexp profile) <>))
    (#f                                         ; no profile directory
     '(0))
    (()                                         ; no profiles
     '(0))
    ((profiles ...)                             ; former profiles around
     (map (compose string->number
                   (cut match:substring <> 1)
                   (cute regexp-exec (profile-regexp profile) <>))
          profiles))))

(define (previous-profile-number profile number)
  "Return the number of the generation before generation NUMBER of
PROFILE, or 0 if none exists.  It could be NUMBER - 1, but it's not the
case when generations have been deleted (there are \"holes\")."
  (fold (lambda (candidate highest)
          (if (and (< candidate number) (> candidate highest))
              candidate
              highest))
        0
        (profile-numbers profile)))

(define (profile-derivation store packages)
  "Return a derivation that builds a profile (a user environment) with
all of PACKAGES, a list of name/version/output/path tuples."
  (define builder
    `(begin
       (use-modules (ice-9 pretty-print)
                    (guix build union))

       (setvbuf (current-output-port) _IOLBF)
       (setvbuf (current-error-port) _IOLBF)

       (let ((output (assoc-ref %outputs "out"))
             (inputs (map cdr %build-inputs)))
         (format #t "building user environment `~a' with ~a packages...~%"
                 output (length inputs))
         (union-build output inputs)
         (call-with-output-file (string-append output "/manifest")
           (lambda (p)
             (pretty-print '(manifest (version 0)
                                      (packages ,packages))
                           p))))))

  (build-expression->derivation store "user-environment"
                                (%current-system)
                                builder
                                (map (match-lambda
                                      ((name version output path)
                                       `(,name ,path)))
                                     packages)
                                #:modules '((guix build union))))

(define (profile-number profile)
  "Return PROFILE's number or 0.  An absolute file name must be used."
  (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
                                              (basename (readlink profile))))
             (compose string->number (cut match:substring <> 1)))
      0))

(define (switch-symlinks link target)
  "Atomically switch LINK, a symbolic link, to point to TARGET.  Works
both when LINK already exists and when it does not."
  (let ((pivot (string-append link ".new")))
    (symlink target pivot)
    (rename-file pivot link)))

(define (roll-back profile)
  "Roll back to the previous generation of PROFILE."
  (let* ((number           (profile-number profile))
         (previous-number  (previous-profile-number profile number))
         (previous-profile (format #f "~a-~a-link"
                                   profile previous-number))
         (manifest         (string-append previous-profile "/manifest")))

    (define (switch-link)
      ;; Atomically switch PROFILE to the previous profile.
      (format #t (_ "switching from generation ~a to ~a~%")
              number previous-number)
      (switch-symlinks profile previous-profile))

    (cond ((not (file-exists? profile))           ; invalid profile
           (format (current-error-port)
                   (_ "error: profile `~a' does not exist~%")
                   profile))
          ((zero? number)                         ; empty profile
           (format (current-error-port)
                   (_ "nothing to do: already at the empty profile~%")))
          ((or (zero? previous-number)            ; going to emptiness
               (not (file-exists? previous-profile)))
           (let*-values (((drv-path drv)
                          (profile-derivation (%store) '()))
                         ((prof)
                          (derivation-output-path
                           (assoc-ref (derivation-outputs drv) "out"))))
             (when (not (build-derivations (%store) (list drv-path)))
               (leave (_ "failed to build the empty profile~%")))

             (switch-symlinks previous-profile prof)
             (switch-link)))
          (else (switch-link)))))                 ; anything else

\f
;;;
;;; Command-line options.
;;;

(define %default-options
  ;; Alist of default option values.
  `((profile . ,%current-profile)))

(define (show-help)
  (display (_ "Usage: guix-package [OPTION]... PACKAGES...
Install, remove, or upgrade PACKAGES in a single transaction.\n"))
  (display (_ "
  -i, --install=PACKAGE  install PACKAGE"))
  (display (_ "
  -r, --remove=PACKAGE   remove PACKAGE"))
  (display (_ "
  -u, --upgrade=REGEXP   upgrade all the installed packages matching REGEXP"))
  (display (_ "
      --roll-back        roll back to the previous generation"))
  (newline)
  (display (_ "
  -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
  (display (_ "
  -n, --dry-run          show what would be done without actually doing it"))
  (display (_ "
      --bootstrap        use the bootstrap Guile to build the profile"))
  (display (_ "
      --verbose          produce verbose output"))
  (newline)
  (display (_ "
  -I, --list-installed[=REGEXP]
                         list installed packages matching REGEXP"))
  (display (_ "
  -A, --list-available[=REGEXP]
                         list available packages matching REGEXP"))
  (newline)
  (display (_ "
  -h, --help             display this help and exit"))
  (display (_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specification of the command-line options.
  (list (option '(#\h "help") #f #f
                (lambda args
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda args
                  (show-version-and-exit "guix-package")))

        (option '(#\i "install") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'install arg result)))
        (option '(#\r "remove") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'remove arg result)))
        (option '("roll-back") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'roll-back? #t result)))
        (option '(#\p "profile") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'profile arg
                              (alist-delete 'profile result))))
        (option '(#\n "dry-run") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'dry-run? #t result)))
        (option '("bootstrap") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'bootstrap? #t result)))
        (option '("verbose") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'verbose? #t result)))
        (option '(#\I "list-installed") #f #t
                (lambda (opt name arg result)
                  (cons `(query list-installed ,(or arg ""))
                        result)))
        (option '(#\A "list-available") #f #t
                (lambda (opt name arg result)
                  (cons `(query list-available ,(or arg ""))
                        result)))))

\f
;;;
;;; Entry point.
;;;

(define (guix-package . args)
  (define (parse-options)
    ;; Return the alist of option values.
    (args-fold args %options
               (lambda (opt name arg result)
                 (leave (_ "~A: unrecognized option~%") name))
               (lambda (arg result)
                 (leave (_ "~A: extraneous argument~%") arg))
               %default-options))

  (define (guile-missing?)
    ;; Return #t if %GUILE-FOR-BUILD is not available yet.
    (let ((out (derivation-path->output-path (%guile-for-build))))
      (not (valid-path? (%store) out))))

  (define (show-what-to-build drv dry-run?)
    ;; Show what will/would be built in realizing the derivations listed
    ;; in DRV.
    (let* ((req  (append-map (lambda (drv-path)
                               (let ((d (call-with-input-file drv-path
                                          read-derivation)))
                                 (derivation-prerequisites-to-build
                                  (%store) d)))
                             drv))
           (req* (delete-duplicates
                  (append (remove (compose (cute valid-path? (%store) <>)
                                           derivation-path->output-path)
                                  drv)
                          (map derivation-input-path req)))))
      (if dry-run?
          (format (current-error-port)
                  (N_ "~:[the following derivation would be built:~%~{   ~a~%~}~;~]"
                      "~:[the following derivations would be built:~%~{    ~a~%~}~;~]"
                      (length req*))
                  (null? req*) req*)
          (format (current-error-port)
                  (N_ "~:[the following derivation will be built:~%~{   ~a~%~}~;~]"
                      "~:[the following derivations will be built:~%~{    ~a~%~}~;~]"
                      (length req*))
                  (null? req*) req*))))

  (define (find-package name)
    ;; Find the package NAME; NAME may contain a version number and a
    ;; sub-derivation name.
    (define request name)

    (let*-values (((name sub-drv)
                   (match (string-rindex name #\:)
                     (#f    (values name "out"))
                     (colon (values (substring name 0 colon)
                                    (substring name (+ 1 colon))))))
                  ((name version)
                   (package-name->name+version name)))
      (match (find-packages-by-name name version)
        ((p)
         (list name (package-version p) sub-drv p))
        ((p p* ...)
         (format (current-error-port)
                 (_ "warning: ambiguous package specification `~a'~%")
                 request)
         (format (current-error-port)
                 (_ "warning: choosing ~a from ~a~%")
                 (package-full-name p)
                 (location->string (package-location p)))
         (list name (package-version p) sub-drv p))
        (()
         (leave (_ "~a: package not found~%") request)))))

  (define (ensure-default-profile)
    ;; Ensure the default profile symlink and directory exist.

    ;; Create ~/.guix-profile if it doesn't exist yet.
    (when (and %user-environment-directory
               %current-profile
               (not (false-if-exception
                     (lstat %user-environment-directory))))
      (symlink %current-profile %user-environment-directory))

    ;; Attempt to create /…/profiles/per-user/$USER if needed.
    (unless (directory-exists? %profile-directory)
      (catch 'system-error
        (lambda ()
          (mkdir-p %profile-directory))
        (lambda args
          ;; Often, we cannot create %PROFILE-DIRECTORY because its
          ;; parent directory is root-owned and we're running
          ;; unprivileged.
          (format (current-error-port)
                  (_ "error: while creating directory `~a': ~a~%")
                  %profile-directory
                  (strerror (system-error-errno args)))
          (format (current-error-port)
                  (_ "Please create the `~a' directory, with you as the owner.~%")
                  %profile-directory)
          (exit 1)))))

  (define (process-actions opts)
    ;; Process any install/remove/upgrade action from OPTS.

    (define dry-run? (assoc-ref opts 'dry-run?))
    (define verbose? (assoc-ref opts 'verbose?))
    (define profile  (assoc-ref opts 'profile))

    ;; First roll back if asked to.
    (if (and (assoc-ref opts 'roll-back?) (not dry-run?))
        (begin
          (roll-back profile)
          (process-actions (alist-delete 'roll-back? opts)))
        (let* ((install  (filter-map (match-lambda
                                      (('install . (? store-path?))
                                       #f)
                                      (('install . package)
                                       (find-package package))
                                      (_ #f))
                                     opts))
               (drv      (filter-map (match-lambda
                                      ((name version sub-drv
                                             (? package? package))
                                       (package-derivation (%store) package))
                                      (_ #f))
                                     install))
               (install* (append
                          (filter-map (match-lambda
                                       (('install . (? store-path? path))
                                        (let-values (((name version)
                                                      (package-name->name+version
                                                       (store-path-package-name
                                                        path))))
                                          `(,name ,version #f ,path)))
                                       (_ #f))
                                      opts)
                          (map (lambda (tuple drv)
                                 (match tuple
                                   ((name version sub-drv _)
                                    (let ((output-path
                                           (derivation-path->output-path
                                            drv sub-drv)))
                                      `(,name ,version ,sub-drv ,output-path)))))
                               install drv)))
               (remove   (filter-map (match-lambda
                                      (('remove . package)
                                       package)
                                      (_ #f))
                                     opts))
               (packages (append install*
                                 (fold (lambda (package result)
                                         (match package
                                           ((name _ ...)
                                            (alist-delete name result))))
                                       (fold alist-delete
                                             (manifest-packages
                                              (profile-manifest profile))
                                             remove)
                                       install*))))

          (when (equal? profile %current-profile)
            (ensure-default-profile))

          (show-what-to-build drv dry-run?)

          (or dry-run?
              (and (build-derivations (%store) drv)
                   (let* ((prof-drv (profile-derivation (%store) packages))
                          (prof     (derivation-path->output-path prof-drv))
                          (old-drv  (profile-derivation
                                     (%store) (manifest-packages
                                               (profile-manifest profile))))
                          (old-prof (derivation-path->output-path old-drv))
                          (number   (profile-number profile))

                          ;; Always use NUMBER + 1 for the new profile,
                          ;; possibly overwriting a "previous future
                          ;; generation".
                          (name     (format #f "~a-~a-link"
                                            profile (+ 1 number))))
                     (if (string=? old-prof prof)
                         (when (or (pair? install) (pair? remove))
                           (format (current-error-port)
                                   (_ "nothing to be done~%")))
                         (and (parameterize ((current-build-output-port
                                              ;; Output something when Guile
                                              ;; needs to be built.
                                              (if (or verbose? (guile-missing?))
                                                  (current-error-port)
                                                  (%make-void-port "w"))))
                                (build-derivations (%store) (list prof-drv)))
                              (begin
                                (switch-symlinks name prof)
                                (switch-symlinks profile name))))))))))

  (define (process-query opts)
    ;; Process any query specified by OPTS.  Return #t when a query was
    ;; actually processed, #f otherwise.
    (let ((profile  (assoc-ref opts 'profile)))
      (match (assoc-ref opts 'query)
        (('list-installed regexp)
         (let* ((regexp    (and regexp (make-regexp regexp)))
                (manifest  (profile-manifest profile))
                (installed (manifest-packages manifest)))
           (for-each (match-lambda
                      ((name version output path)
                       (when (or (not regexp)
                                 (regexp-exec regexp name))
                         (format #t "~a\t~a\t~a\t~a~%"
                                 name (or version "?") output path))))
                     installed)
           #t))
        (('list-available regexp)
         (let* ((regexp    (and regexp (make-regexp regexp)))
                (available (fold-packages
                            (lambda (p r)
                              (let ((n (package-name p)))
                                (if regexp
                                    (if (regexp-exec regexp n)
                                        (cons p r)
                                        r)
                                    (cons p r))))
                            '())))
           (for-each (lambda (p)
                       (format #t "~a\t~a\t~a\t~a~%"
                               (package-name p)
                               (package-version p)
                               (string-join (package-outputs p) ",")
                               (location->string (package-location p))))
                     (sort available
                           (lambda (p1 p2)
                             (string<? (package-name p1)
                                       (package-name p2)))))
           #t))
        (_ #f))))

  (setlocale LC_ALL "")
  (textdomain "guix")
  (setvbuf (current-output-port) _IOLBF)
  (setvbuf (current-error-port) _IOLBF)

  (let ((opts (parse-options)))
    (parameterize ((%store (open-connection)))
      (with-error-handling
        (or (process-query opts)
            (parameterize ((%guile-for-build
                            (package-derivation (%store)
                                                (if (assoc-ref opts 'bootstrap?)
                                                    %bootstrap-guile
                                                    guile-final))))
              (process-actions opts)))))))
Commit	Line	Data
0afdc485 LC	1	#!/bin/sh
	2	# aside from this initial boilerplate, this is actually -- scheme -- code
	3
	4	prefix="@prefix@"
	5	datarootdir="@datarootdir@"
	6
	7	GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
	8	export GUILE_LOAD_COMPILED_PATH
	9
	10	main='(module-ref (resolve-interface '\''(guix-package)) '\'guix-package')'
	11	exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
	12	-c "(apply $main (cdr (command-line)))" "$@"
	13	!#
233e7676 LC	14	;;; GNU Guix --- Functional package management for GNU
233e7676 LC	15	;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
24e262f0	16	;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
0afdc485	17	;;;
233e7676	18	;;; This file is part of GNU Guix.
0afdc485	19	;;;
233e7676	20	;;; GNU Guix is free software; you can redistribute it and/or modify it
0afdc485 LC	21	;;; under the terms of the GNU General Public License as published by
	22	;;; the Free Software Foundation; either version 3 of the License, or (at
	23	;;; your option) any later version.
	24	;;;
233e7676	25	;;; GNU Guix is distributed in the hope that it will be useful, but
0afdc485 LC	26	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	27	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	28	;;; GNU General Public License for more details.
	29	;;;
	30	;;; You should have received a copy of the GNU General Public License
233e7676	31	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
0afdc485 LC	32
0afdc485 LC	33	(define-module (guix-package)
cdd5d6f9	34	#:use-module (guix ui)
0afdc485 LC	35	#:use-module (guix store)
	36	#:use-module (guix derivations)
	37	#:use-module (guix packages)
	38	#:use-module (guix utils)
a020d2a9	39	#:use-module (guix config)
0ec1af59	40	#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
0afdc485 LC	41	#:use-module (ice-9 ftw)
	42	#:use-module (ice-9 format)
	43	#:use-module (ice-9 match)
	44	#:use-module (ice-9 regex)
	45	#:use-module (srfi srfi-1)
	46	#:use-module (srfi srfi-11)
	47	#:use-module (srfi srfi-26)
	48	#:use-module (srfi srfi-34)
	49	#:use-module (srfi srfi-37)
59a43334	50	#:use-module (gnu packages)
1ffa7090 LC	51	#:use-module ((gnu packages base) #:select (guile-final))
1ffa7090 LC	52	#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
0afdc485 LC	53	#:export (guix-package))
0afdc485 LC	54
0afdc485	55	(define %store
c4d64534	56	(make-parameter #f))
0afdc485 LC	57
	58	\f
	59	;;;
	60	;;; User environment.
	61	;;;
	62
	63	(define %user-environment-directory
	64	(and=> (getenv "HOME")
	65	(cut string-append <> "/.guix-profile")))
	66
	67	(define %profile-directory
0ec1af59	68	(string-append (or (getenv "NIX_STATE_DIR") %state-directory) "/profiles/"
0afdc485 LC	69	(or (and=> (getenv "USER")
	70	(cut string-append "per-user/" <>))
	71	"default")))
	72
	73	(define %current-profile
4aa52039 LC	74	;; Call it `guix-profile', not `profile', to allow Guix profiles to
	75	;; coexist with Nix profiles.
	76	(string-append %profile-directory "/guix-profile"))
0afdc485 LC	77
	78	(define (profile-manifest profile)
	79	"Return the PROFILE's manifest."
	80	(let ((manifest (string-append profile "/manifest")))
	81	(if (file-exists? manifest)
	82	(call-with-input-file manifest read)
	83	'(manifest (version 0) (packages ())))))
	84
	85	(define (manifest-packages manifest)
	86	"Return the packages listed in MANIFEST."
	87	(match manifest
	88	(('manifest ('version 0) ('packages packages))
	89	packages)
	90	(_
	91	(error "unsupported manifest format" manifest))))
	92
24e262f0 LC	93	(define (profile-regexp profile)
	94	"Return a regular expression that matches PROFILE's name and number."
	95	(make-regexp (string-append "^" (regexp-quote (basename profile))
	96	"-([0-9]+)")))
	97
9241172c LC	98	(define (profile-numbers profile)
	99	"Return the list of generation numbers of PROFILE, or '(0) if no
	100	former profiles were found."
0afdc485 LC	101	(define* (scandir name #:optional (select? (const #t))
	102	(entry<? (@ (ice-9 i18n) string-locale<?)))
	103	;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
	104	(define (enter? dir stat result)
	105	(and stat (string=? dir name)))
	106
	107	(define (visit basename result)
	108	(if (select? basename)
	109	(cons basename result)
	110	result))
	111
	112	(define (leaf name stat result)
	113	(and result
	114	(visit (basename name) result)))
	115
	116	(define (down name stat result)
	117	(visit "." '()))
	118
	119	(define (up name stat result)
	120	(visit ".." result))
	121
	122	(define (skip name stat result)
	123	;; All the sub-directories are skipped.
	124	(visit (basename name) result))
	125
	126	(define (error name* stat errno result)
	127	(if (string=? name name*) ; top-level NAME is unreadable
	128	result
	129	(visit (basename name*) result)))
	130
	131	(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
	132	(lambda (files)
	133	(sort files entry<?))))
	134
	135	(match (scandir (dirname profile)
24e262f0	136	(cute regexp-exec (profile-regexp profile) <>))
0afdc485	137	(#f ; no profile directory
9241172c	138	'(0))
0afdc485	139	(() ; no profiles
9241172c	140	'(0))
0afdc485	141	((profiles ...) ; former profiles around
9241172c LC	142	(map (compose string->number
	143	(cut match:substring <> 1)
	144	(cute regexp-exec (profile-regexp profile) <>))
	145	profiles))))
	146
9241172c LC	147	(define (previous-profile-number profile number)
	148	"Return the number of the generation before generation NUMBER of
	149	PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
	150	case when generations have been deleted (there are \"holes\")."
	151	(fold (lambda (candidate highest)
	152	(if (and (< candidate number) (> candidate highest))
	153	candidate
	154	highest))
	155	0
	156	(profile-numbers profile)))
0afdc485 LC	157
	158	(define (profile-derivation store packages)
	159	"Return a derivation that builds a profile (a user environment) with
	160	all of PACKAGES, a list of name/version/output/path tuples."
	161	(define builder
	162	`(begin
	163	(use-modules (ice-9 pretty-print)
	164	(guix build union))
	165
	166	(setvbuf (current-output-port) _IOLBF)
	167	(setvbuf (current-error-port) _IOLBF)
	168
	169	(let ((output (assoc-ref %outputs "out"))
	170	(inputs (map cdr %build-inputs)))
	171	(format #t "building user environment `~a' with ~a packages...~%"
	172	output (length inputs))
	173	(union-build output inputs)
	174	(call-with-output-file (string-append output "/manifest")
	175	(lambda (p)
	176	(pretty-print '(manifest (version 0)
	177	(packages ,packages))
	178	p))))))
	179
	180	(build-expression->derivation store "user-environment"
	181	(%current-system)
	182	builder
	183	(map (match-lambda
	184	((name version output path)
	185	`(,name ,path)))
	186	packages)
	187	#:modules '((guix build union))))
	188
24e262f0 LC	189	(define (profile-number profile)
	190	"Return PROFILE's number or 0. An absolute file name must be used."
	191	(or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
	192	(basename (readlink profile))))
	193	(compose string->number (cut match:substring <> 1)))
	194	0))
	195
82fe08ed LC	196	(define (switch-symlinks link target)
	197	"Atomically switch LINK, a symbolic link, to point to TARGET. Works
	198	both when LINK already exists and when it does not."
	199	(let ((pivot (string-append link ".new")))
	200	(symlink target pivot)
	201	(rename-file pivot link)))
	202
24e262f0 LC	203	(define (roll-back profile)
24e262f0 LC	204	"Roll back to the previous generation of PROFILE."
9241172c LC	205	(let* ((number (profile-number profile))
9241172c LC	206	(previous-number (previous-profile-number profile number))
67668155 LC	207	(previous-profile (format #f "~a-~a-link"
67668155 LC	208	profile previous-number))
9241172c	209	(manifest (string-append previous-profile "/manifest")))
24e262f0 LC	210
	211	(define (switch-link)
	212	;; Atomically switch PROFILE to the previous profile.
82fe08ed LC	213	(format #t (_ "switching from generation ~a to ~a~%")
	214	number previous-number)
	215	(switch-symlinks profile previous-profile))
24e262f0	216
d9307267	217	(cond ((not (file-exists? profile)) ; invalid profile
9241172c	218	(format (current-error-port)
d9307267	219	(_ "error: profile `~a' does not exist~%")
9241172c	220	profile))
d9307267 LC	221	((zero? number) ; empty profile
	222	(format (current-error-port)
	223	(_ "nothing to do: already at the empty profile~%")))
	224	((or (zero? previous-number) ; going to emptiness
9241172c	225	(not (file-exists? previous-profile)))
d9307267 LC	226	(let*-values (((drv-path drv)
	227	(profile-derivation (%store) '()))
	228	((prof)
	229	(derivation-output-path
	230	(assoc-ref (derivation-outputs drv) "out"))))
	231	(when (not (build-derivations (%store) (list drv-path)))
	232	(leave (_ "failed to build the empty profile~%")))
	233
82fe08ed	234	(switch-symlinks previous-profile prof)
d9307267 LC	235	(switch-link)))
d9307267 LC	236	(else (switch-link))))) ; anything else
24e262f0	237
0afdc485 LC	238	\f
	239	;;;
	240	;;; Command-line options.
	241	;;;
	242
	243	(define %default-options
	244	;; Alist of default option values.
	245	`((profile . ,%current-profile)))
	246
0afdc485 LC	247	(define (show-help)
	248	(display (_ "Usage: guix-package [OPTION]... PACKAGES...
	249	Install, remove, or upgrade PACKAGES in a single transaction.\n"))
	250	(display (_ "
	251	-i, --install=PACKAGE install PACKAGE"))
	252	(display (_ "
	253	-r, --remove=PACKAGE remove PACKAGE"))
	254	(display (_ "
	255	-u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
24e262f0 LC	256	(display (_ "
24e262f0 LC	257	--roll-back roll back to the previous generation"))
0afdc485 LC	258	(newline)
	259	(display (_ "
	260	-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
	261	(display (_ "
	262	-n, --dry-run show what would be done without actually doing it"))
	263	(display (_ "
cc57f25d	264	--bootstrap use the bootstrap Guile to build the profile"))
70915c1a LC	265	(display (_ "
70915c1a LC	266	--verbose produce verbose output"))
0afdc485 LC	267	(newline)
0afdc485 LC	268	(display (_ "
733b4130 LC	269	-I, --list-installed[=REGEXP]
733b4130 LC	270	list installed packages matching REGEXP"))
64fc89b6 LC	271	(display (_ "
	272	-A, --list-available[=REGEXP]
	273	list available packages matching REGEXP"))
733b4130 LC	274	(newline)
733b4130 LC	275	(display (_ "
0afdc485 LC	276	-h, --help display this help and exit"))
	277	(display (_ "
	278	-V, --version display version information and exit"))
	279	(newline)
3441e164	280	(show-bug-report-information))
0afdc485 LC	281
	282	(define %options
	283	;; Specification of the command-line options.
	284	(list (option '(#\h "help") #f #f
	285	(lambda args
	286	(show-help)
	287	(exit 0)))
	288	(option '(#\V "version") #f #f
	289	(lambda args
cdd5d6f9	290	(show-version-and-exit "guix-package")))
0afdc485 LC	291
	292	(option '(#\i "install") #t #f
	293	(lambda (opt name arg result)
	294	(alist-cons 'install arg result)))
	295	(option '(#\r "remove") #t #f
	296	(lambda (opt name arg result)
	297	(alist-cons 'remove arg result)))
24e262f0 LC	298	(option '("roll-back") #f #f
	299	(lambda (opt name arg result)
	300	(alist-cons 'roll-back? #t result)))
0afdc485 LC	301	(option '(#\p "profile") #t #f
	302	(lambda (opt name arg result)
	303	(alist-cons 'profile arg
	304	(alist-delete 'profile result))))
	305	(option '(#\n "dry-run") #f #f
	306	(lambda (opt name arg result)
	307	(alist-cons 'dry-run? #t result)))
cc57f25d	308	(option '("bootstrap") #f #f
0afdc485	309	(lambda (opt name arg result)
733b4130	310	(alist-cons 'bootstrap? #t result)))
70915c1a LC	311	(option '("verbose") #f #f
	312	(lambda (opt name arg result)
	313	(alist-cons 'verbose? #t result)))
733b4130 LC	314	(option '(#\I "list-installed") #f #t
	315	(lambda (opt name arg result)
	316	(cons `(query list-installed ,(or arg ""))
64fc89b6 LC	317	result)))
	318	(option '(#\A "list-available") #f #t
	319	(lambda (opt name arg result)
	320	(cons `(query list-available ,(or arg ""))
733b4130	321	result)))))
0afdc485 LC	322
	323	\f
	324	;;;
	325	;;; Entry point.
	326	;;;
	327
	328	(define (guix-package . args)
	329	(define (parse-options)
	330	;; Return the alist of option values.
	331	(args-fold args %options
	332	(lambda (opt name arg result)
	333	(leave (_ "~A: unrecognized option~%") name))
	334	(lambda (arg result)
3b9c0020	335	(leave (_ "~A: extraneous argument~%") arg))
0afdc485 LC	336	%default-options))
0afdc485 LC	337
9762706b LC	338	(define (guile-missing?)
	339	;; Return #t if %GUILE-FOR-BUILD is not available yet.
	340	(let ((out (derivation-path->output-path (%guile-for-build))))
c4d64534	341	(not (valid-path? (%store) out))))
9762706b	342
0afdc485 LC	343	(define (show-what-to-build drv dry-run?)
	344	;; Show what will/would be built in realizing the derivations listed
	345	;; in DRV.
	346	(let* ((req (append-map (lambda (drv-path)
	347	(let ((d (call-with-input-file drv-path
	348	read-derivation)))
c4d64534 LC	349	(derivation-prerequisites-to-build
c4d64534 LC	350	(%store) d)))
0afdc485 LC	351	drv))
0afdc485 LC	352	(req* (delete-duplicates
c4d64534	353	(append (remove (compose (cute valid-path? (%store) <>)
0afdc485 LC	354	derivation-path->output-path)
	355	drv)
	356	(map derivation-input-path req)))))
	357	(if dry-run?
	358	(format (current-error-port)
	359	(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
	360	"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
	361	(length req*))
	362	(null? req) req)
	363	(format (current-error-port)
	364	(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
	365	"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
	366	(length req*))
	367	(null? req) req))))
	368
	369	(define (find-package name)
	370	;; Find the package NAME; NAME may contain a version number and a
	371	;; sub-derivation name.
	372	(define request name)
0afdc485 LC	373
	374	(let*-values (((name sub-drv)
	375	(match (string-rindex name #\:)
	376	(#f (values name "out"))
9518856b LC	377	(colon (values (substring name 0 colon)
9518856b LC	378	(substring name (+ 1 colon))))))
0afdc485	379	((name version)
9b48fb88	380	(package-name->name+version name)))
0afdc485 LC	381	(match (find-packages-by-name name version)
0afdc485 LC	382	((p)
d9d05363	383	(list name (package-version p) sub-drv p))
c6f09dfa	384	((p p* ...)
0afdc485 LC	385	(format (current-error-port)
	386	(_ "warning: ambiguous package specification `~a'~%")
	387	request)
	388	(format (current-error-port)
d9d05363 LC	389	(_ "warning: choosing ~a from ~a~%")
	390	(package-full-name p)
	391	(location->string (package-location p)))
	392	(list name (package-version p) sub-drv p))
0afdc485 LC	393	(()
	394	(leave (_ "~a: package not found~%") request)))))
	395
0ec1af59 LC	396	(define (ensure-default-profile)
	397	;; Ensure the default profile symlink and directory exist.
	398
	399	;; Create ~/.guix-profile if it doesn't exist yet.
	400	(when (and %user-environment-directory
	401	%current-profile
	402	(not (false-if-exception
	403	(lstat %user-environment-directory))))
	404	(symlink %current-profile %user-environment-directory))
	405
	406	;; Attempt to create /…/profiles/per-user/$USER if needed.
	407	(unless (directory-exists? %profile-directory)
	408	(catch 'system-error
	409	(lambda ()
	410	(mkdir-p %profile-directory))
	411	(lambda args
	412	;; Often, we cannot create %PROFILE-DIRECTORY because its
	413	;; parent directory is root-owned and we're running
	414	;; unprivileged.
	415	(format (current-error-port)
	416	(_ "error: while creating directory `~a': ~a~%")
	417	%profile-directory
	418	(strerror (system-error-errno args)))
	419	(format (current-error-port)
	420	(_ "Please create the `~a' directory, with you as the owner.~%")
	421	%profile-directory)
	422	(exit 1)))))
	423
733b4130 LC	424	(define (process-actions opts)
733b4130 LC	425	;; Process any install/remove/upgrade action from OPTS.
24e262f0 LC	426
	427	(define dry-run? (assoc-ref opts 'dry-run?))
	428	(define verbose? (assoc-ref opts 'verbose?))
	429	(define profile (assoc-ref opts 'profile))
	430
	431	;; First roll back if asked to.
	432	(if (and (assoc-ref opts 'roll-back?) (not dry-run?))
	433	(begin
	434	(roll-back profile)
	435	(process-actions (alist-delete 'roll-back? opts)))
	436	(let* ((install (filter-map (match-lambda
	437	(('install . (? store-path?))
	438	#f)
	439	(('install . package)
	440	(find-package package))
	441	(_ #f))
	442	opts))
	443	(drv (filter-map (match-lambda
	444	((name version sub-drv
	445	(? package? package))
	446	(package-derivation (%store) package))
	447	(_ #f))
	448	install))
	449	(install* (append
	450	(filter-map (match-lambda
	451	(('install . (? store-path? path))
	452	(let-values (((name version)
	453	(package-name->name+version
	454	(store-path-package-name
	455	path))))
	456	`(,name ,version #f ,path)))
	457	(_ #f))
	458	opts)
	459	(map (lambda (tuple drv)
	460	(match tuple
	461	((name version sub-drv _)
	462	(let ((output-path
	463	(derivation-path->output-path
	464	drv sub-drv)))
	465	`(,name ,version ,sub-drv ,output-path)))))
	466	install drv)))
	467	(remove (filter-map (match-lambda
	468	(('remove . package)
	469	package)
	470	(_ #f))
	471	opts))
	472	(packages (append install*
	473	(fold (lambda (package result)
	474	(match package
	475	((name _ ...)
	476	(alist-delete name result))))
	477	(fold alist-delete
	478	(manifest-packages
	479	(profile-manifest profile))
	480	remove)
	481	install*))))
	482
	483	(when (equal? profile %current-profile)
	484	(ensure-default-profile))
	485
	486	(show-what-to-build drv dry-run?)
	487
	488	(or dry-run?
	489	(and (build-derivations (%store) drv)
490	(let* ((prof-drv (profile-derivation (%store) packages))
491	(prof (derivation-path->output-path prof-drv))
492	(old-drv (profile-derivation
493	(%store) (manifest-packages
494	(profile-manifest profile))))
495	(old-prof (derivation-path->output-path old-drv))
82fe08ed LC	496	(number (profile-number profile))
	497
	498	;; Always use NUMBER + 1 for the new profile,
	499	;; possibly overwriting a "previous future
	500	;; generation".
	501	(name (format #f "~a-~a-link"
	502	profile (+ 1 number))))
24e262f0 LC	503	(if (string=? old-prof prof)
	504	(when (or (pair? install) (pair? remove))
	505	(format (current-error-port)
	506	(_ "nothing to be done~%")))
	507	(and (parameterize ((current-build-output-port
	508	;; Output something when Guile
	509	;; needs to be built.
	510	(if (or verbose? (guile-missing?))
	511	(current-error-port)
	512	(%make-void-port "w"))))
	513	(build-derivations (%store) (list prof-drv)))
	514	(begin
82fe08ed LC	515	(switch-symlinks name prof)
82fe08ed LC	516	(switch-symlinks profile name))))))))))
733b4130 LC	517
	518	(define (process-query opts)
	519	;; Process any query specified by OPTS. Return #t when a query was
	520	;; actually processed, #f otherwise.
	521	(let ((profile (assoc-ref opts 'profile)))
	522	(match (assoc-ref opts 'query)
	523	(('list-installed regexp)
	524	(let* ((regexp (and regexp (make-regexp regexp)))
	525	(manifest (profile-manifest profile))
	526	(installed (manifest-packages manifest)))
	527	(for-each (match-lambda
	528	((name version output path)
	529	(when (or (not regexp)
	530	(regexp-exec regexp name))
	531	(format #t "~a\t~a\t~a\t~a~%"
	532	name (or version "?") output path))))
64fc89b6 LC	533	installed)
	534	#t))
	535	(('list-available regexp)
	536	(let* ((regexp (and regexp (make-regexp regexp)))
	537	(available (fold-packages
	538	(lambda (p r)
	539	(let ((n (package-name p)))
	540	(if regexp
	541	(if (regexp-exec regexp n)
	542	(cons p r)
	543	r)
	544	(cons p r))))
	545	'())))
	546	(for-each (lambda (p)
44b6be77	547	(format #t "~a\t~a\t~a\t~a~%"
64fc89b6 LC	548	(package-name p)
64fc89b6 LC	549	(package-version p)
44b6be77	550	(string-join (package-outputs p) ",")
64fc89b6 LC	551	(location->string (package-location p))))
	552	(sort available
	553	(lambda (p1 p2)
	554	(string<? (package-name p1)
	555	(package-name p2)))))
	556	#t))
733b4130 LC	557	(_ #f))))
733b4130 LC	558
0afdc485 LC	559	(setlocale LC_ALL "")
	560	(textdomain "guix")
	561	(setvbuf (current-output-port) _IOLBF)
	562	(setvbuf (current-error-port) _IOLBF)
	563
	564	(let ((opts (parse-options)))
c4d64534 LC	565	(parameterize ((%store (open-connection)))
	566	(with-error-handling
	567	(or (process-query opts)
	568	(parameterize ((%guile-for-build
	569	(package-derivation (%store)
	570	(if (assoc-ref opts 'bootstrap?)
	571	%bootstrap-guile
	572	guile-final))))
	573	(process-actions opts)))))))