[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>
;;;
;;; 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 (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 (distro)
  #:use-module ((distro packages base) #:select (guile-final))
  #:use-module ((distro packages bootstrap) #:select (%bootstrap-guile))
  #:export (guix-package))

(define %store
  (open-connection))

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

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

(define %profile-directory
  (string-append %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 (latest-profile-number profile)
  "Return the identifying number of the latest generation of PROFILE.
PROFILE is the name of the symlink to the current generation."
  (define %profile-rx
    (make-regexp (string-append "^" (regexp-quote (basename profile))
                                "-([0-9]+)")))

  (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)
                  (cut regexp-exec %profile-rx <>))
    (#f                                         ; no profile directory
     0)
    (()                                         ; no profiles
     0)
    ((profiles ...)                             ; former profiles around
     (let ((numbers (map (compose string->number
                                  (cut match:substring <> 1)
                                  (cut regexp-exec %profile-rx <>))
                         profiles)))
       (fold (lambda (number highest)
               (if (> number highest)
                   number
                   highest))
             0
             numbers)))))

(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))))

\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"))
  (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 '(#\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)
                 (alist-cons 'argument arg result))
               %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 (cut 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 (process-actions opts)
    ;; Process any install/remove/upgrade action from OPTS.
    (let* ((dry-run? (assoc-ref opts 'dry-run?))
           (verbose? (assoc-ref opts 'verbose?))
           (profile  (assoc-ref opts 'profile))
           (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*))))

      (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   (latest-profile-number profile))
                      (name     (format #f "~a/~a-~a-link"
                                        (dirname profile)
                                        (basename profile) (+ 1 number))))
                 (if (string=? old-prof prof)
                     (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
                            (symlink prof name)
                            (when (file-exists? profile)
                              (delete-file profile))
                            (symlink name profile)))))))))

  (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)))

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

    (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>
0afdc485	16	;;;
233e7676	17	;;; This file is part of GNU Guix.
0afdc485	18	;;;
233e7676	19	;;; GNU Guix is free software; you can redistribute it and/or modify it
0afdc485 LC	20	;;; under the terms of the GNU General Public License as published by
	21	;;; the Free Software Foundation; either version 3 of the License, or (at
	22	;;; your option) any later version.
	23	;;;
233e7676	24	;;; GNU Guix is distributed in the hope that it will be useful, but
0afdc485 LC	25	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	26	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	27	;;; GNU General Public License for more details.
	28	;;;
	29	;;; You should have received a copy of the GNU General Public License
233e7676	30	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
0afdc485 LC	31
0afdc485 LC	32	(define-module (guix-package)
cdd5d6f9	33	#:use-module (guix ui)
0afdc485 LC	34	#:use-module (guix store)
	35	#:use-module (guix derivations)
	36	#:use-module (guix packages)
	37	#:use-module (guix utils)
a020d2a9	38	#:use-module (guix config)
0afdc485 LC	39	#:use-module (ice-9 ftw)
	40	#:use-module (ice-9 format)
	41	#:use-module (ice-9 match)
	42	#:use-module (ice-9 regex)
	43	#:use-module (srfi srfi-1)
	44	#:use-module (srfi srfi-11)
	45	#:use-module (srfi srfi-26)
	46	#:use-module (srfi srfi-34)
	47	#:use-module (srfi srfi-37)
64fc89b6	48	#:use-module (distro)
87009d8a LC	49	#:use-module ((distro packages base) #:select (guile-final))
87009d8a LC	50	#:use-module ((distro packages bootstrap) #:select (%bootstrap-guile))
0afdc485 LC	51	#:export (guix-package))
0afdc485 LC	52
0afdc485 LC	53	(define %store
	54	(open-connection))
	55
	56	\f
	57	;;;
	58	;;; User environment.
	59	;;;
	60
	61	(define %user-environment-directory
	62	(and=> (getenv "HOME")
	63	(cut string-append <> "/.guix-profile")))
	64
	65	(define %profile-directory
a020d2a9	66	(string-append %state-directory "/profiles/"
0afdc485 LC	67	(or (and=> (getenv "USER")
	68	(cut string-append "per-user/" <>))
	69	"default")))
	70
	71	(define %current-profile
4aa52039 LC	72	;; Call it `guix-profile', not `profile', to allow Guix profiles to
	73	;; coexist with Nix profiles.
	74	(string-append %profile-directory "/guix-profile"))
0afdc485 LC	75
	76	(define (profile-manifest profile)
	77	"Return the PROFILE's manifest."
	78	(let ((manifest (string-append profile "/manifest")))
	79	(if (file-exists? manifest)
	80	(call-with-input-file manifest read)
	81	'(manifest (version 0) (packages ())))))
	82
	83	(define (manifest-packages manifest)
	84	"Return the packages listed in MANIFEST."
	85	(match manifest
	86	(('manifest ('version 0) ('packages packages))
	87	packages)
	88	(_
	89	(error "unsupported manifest format" manifest))))
	90
	91	(define (latest-profile-number profile)
	92	"Return the identifying number of the latest generation of PROFILE.
	93	PROFILE is the name of the symlink to the current generation."
	94	(define %profile-rx
	95	(make-regexp (string-append "^" (regexp-quote (basename profile))
	96	"-([0-9]+)")))
	97
	98	(define* (scandir name #:optional (select? (const #t))
	99	(entry<? (@ (ice-9 i18n) string-locale<?)))
	100	;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
	101	(define (enter? dir stat result)
	102	(and stat (string=? dir name)))
	103
	104	(define (visit basename result)
	105	(if (select? basename)
	106	(cons basename result)
	107	result))
	108
	109	(define (leaf name stat result)
	110	(and result
	111	(visit (basename name) result)))
	112
	113	(define (down name stat result)
	114	(visit "." '()))
	115
	116	(define (up name stat result)
	117	(visit ".." result))
	118
	119	(define (skip name stat result)
	120	;; All the sub-directories are skipped.
	121	(visit (basename name) result))
	122
	123	(define (error name* stat errno result)
	124	(if (string=? name name*) ; top-level NAME is unreadable
	125	result
	126	(visit (basename name*) result)))
	127
	128	(and=> (file-system-fold enter? leaf down up skip error #f name lstat)
	129	(lambda (files)
	130	(sort files entry<?))))
	131
	132	(match (scandir (dirname profile)
	133	(cut regexp-exec %profile-rx <>))
	134	(#f ; no profile directory
	135	0)
	136	(() ; no profiles
	137	0)
	138	((profiles ...) ; former profiles around
139	(let ((numbers (map (compose string->number
140	(cut match:substring <> 1)
141	(cut regexp-exec %profile-rx <>))
142	profiles)))
143	(fold (lambda (number highest)
144	(if (> number highest)
145	number
146	highest))
147	0
148	numbers)))))
149
150	(define (profile-derivation store packages)
151	"Return a derivation that builds a profile (a user environment) with
152	all of PACKAGES, a list of name/version/output/path tuples."
153	(define builder
154	`(begin
155	(use-modules (ice-9 pretty-print)
156	(guix build union))
157
158	(setvbuf (current-output-port) _IOLBF)
159	(setvbuf (current-error-port) _IOLBF)
160
161	(let ((output (assoc-ref %outputs "out"))
162	(inputs (map cdr %build-inputs)))
163	(format #t "building user environment `~a' with ~a packages...~%"
164	output (length inputs))
165	(union-build output inputs)
166	(call-with-output-file (string-append output "/manifest")
167	(lambda (p)
168	(pretty-print '(manifest (version 0)
169	(packages ,packages))
170	p))))))
171
172	(build-expression->derivation store "user-environment"
173	(%current-system)
174	builder
175	(map (match-lambda
176	((name version output path)
177	`(,name ,path)))
178	packages)
179	#:modules '((guix build union))))
180
181	\f
182	;;;
183	;;; Command-line options.
184	;;;
185
186	(define %default-options
187	;; Alist of default option values.
188	`((profile . ,%current-profile)))
189
0afdc485 LC	190	(define (show-help)
	191	(display (_ "Usage: guix-package [OPTION]... PACKAGES...
	192	Install, remove, or upgrade PACKAGES in a single transaction.\n"))
	193	(display (_ "
	194	-i, --install=PACKAGE install PACKAGE"))
	195	(display (_ "
	196	-r, --remove=PACKAGE remove PACKAGE"))
	197	(display (_ "
	198	-u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP"))
	199	(newline)
	200	(display (_ "
	201	-p, --profile=PROFILE use PROFILE instead of the user's default profile"))
	202	(display (_ "
	203	-n, --dry-run show what would be done without actually doing it"))
	204	(display (_ "
cc57f25d	205	--bootstrap use the bootstrap Guile to build the profile"))
70915c1a LC	206	(display (_ "
70915c1a LC	207	--verbose produce verbose output"))
0afdc485 LC	208	(newline)
0afdc485 LC	209	(display (_ "
733b4130 LC	210	-I, --list-installed[=REGEXP]
733b4130 LC	211	list installed packages matching REGEXP"))
64fc89b6 LC	212	(display (_ "
	213	-A, --list-available[=REGEXP]
	214	list available packages matching REGEXP"))
733b4130 LC	215	(newline)
733b4130 LC	216	(display (_ "
0afdc485 LC	217	-h, --help display this help and exit"))
	218	(display (_ "
	219	-V, --version display version information and exit"))
	220	(newline)
3441e164	221	(show-bug-report-information))
0afdc485 LC	222
	223	(define %options
	224	;; Specification of the command-line options.
	225	(list (option '(#\h "help") #f #f
	226	(lambda args
	227	(show-help)
	228	(exit 0)))
	229	(option '(#\V "version") #f #f
	230	(lambda args
cdd5d6f9	231	(show-version-and-exit "guix-package")))
0afdc485 LC	232
	233	(option '(#\i "install") #t #f
	234	(lambda (opt name arg result)
	235	(alist-cons 'install arg result)))
	236	(option '(#\r "remove") #t #f
	237	(lambda (opt name arg result)
	238	(alist-cons 'remove arg result)))
	239	(option '(#\p "profile") #t #f
	240	(lambda (opt name arg result)
	241	(alist-cons 'profile arg
	242	(alist-delete 'profile result))))
	243	(option '(#\n "dry-run") #f #f
	244	(lambda (opt name arg result)
	245	(alist-cons 'dry-run? #t result)))
cc57f25d	246	(option '("bootstrap") #f #f
0afdc485	247	(lambda (opt name arg result)
733b4130	248	(alist-cons 'bootstrap? #t result)))
70915c1a LC	249	(option '("verbose") #f #f
	250	(lambda (opt name arg result)
	251	(alist-cons 'verbose? #t result)))
733b4130 LC	252	(option '(#\I "list-installed") #f #t
	253	(lambda (opt name arg result)
	254	(cons `(query list-installed ,(or arg ""))
64fc89b6 LC	255	result)))
	256	(option '(#\A "list-available") #f #t
	257	(lambda (opt name arg result)
	258	(cons `(query list-available ,(or arg ""))
733b4130	259	result)))))
0afdc485 LC	260
	261	\f
	262	;;;
	263	;;; Entry point.
	264	;;;
	265
	266	(define (guix-package . args)
	267	(define (parse-options)
	268	;; Return the alist of option values.
	269	(args-fold args %options
	270	(lambda (opt name arg result)
	271	(leave (_ "~A: unrecognized option~%") name))
	272	(lambda (arg result)
	273	(alist-cons 'argument arg result))
	274	%default-options))
	275
9762706b LC	276	(define (guile-missing?)
	277	;; Return #t if %GUILE-FOR-BUILD is not available yet.
	278	(let ((out (derivation-path->output-path (%guile-for-build))))
	279	(not (valid-path? %store out))))
	280
0afdc485 LC	281	(define (show-what-to-build drv dry-run?)
	282	;; Show what will/would be built in realizing the derivations listed
	283	;; in DRV.
	284	(let* ((req (append-map (lambda (drv-path)
	285	(let ((d (call-with-input-file drv-path
	286	read-derivation)))
	287	(derivation-prerequisites-to-build %store d)))
	288	drv))
	289	(req* (delete-duplicates
	290	(append (remove (compose (cut valid-path? %store <>)
	291	derivation-path->output-path)
	292	drv)
	293	(map derivation-input-path req)))))
	294	(if dry-run?
	295	(format (current-error-port)
	296	(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
	297	"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
	298	(length req*))
	299	(null? req) req)
	300	(format (current-error-port)
	301	(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
	302	"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
	303	(length req*))
	304	(null? req) req))))
	305
	306	(define (find-package name)
	307	;; Find the package NAME; NAME may contain a version number and a
	308	;; sub-derivation name.
	309	(define request name)
0afdc485 LC	310
	311	(let*-values (((name sub-drv)
	312	(match (string-rindex name #\:)
	313	(#f (values name "out"))
9518856b LC	314	(colon (values (substring name 0 colon)
9518856b LC	315	(substring name (+ 1 colon))))))
0afdc485	316	((name version)
9b48fb88	317	(package-name->name+version name)))
0afdc485 LC	318	(match (find-packages-by-name name version)
0afdc485 LC	319	((p)
d9d05363	320	(list name (package-version p) sub-drv p))
c6f09dfa	321	((p p* ...)
0afdc485 LC	322	(format (current-error-port)
	323	(_ "warning: ambiguous package specification `~a'~%")
	324	request)
	325	(format (current-error-port)
d9d05363 LC	326	(_ "warning: choosing ~a from ~a~%")
	327	(package-full-name p)
	328	(location->string (package-location p)))
	329	(list name (package-version p) sub-drv p))
0afdc485 LC	330	(()
	331	(leave (_ "~a: package not found~%") request)))))
	332
733b4130 LC	333	(define (process-actions opts)
	334	;; Process any install/remove/upgrade action from OPTS.
	335	(let* ((dry-run? (assoc-ref opts 'dry-run?))
70915c1a	336	(verbose? (assoc-ref opts 'verbose?))
733b4130 LC	337	(profile (assoc-ref opts 'profile))
	338	(install (filter-map (match-lambda
	339	(('install . (? store-path?))
	340	#f)
	341	(('install . package)
	342	(find-package package))
	343	(_ #f))
	344	opts))
	345	(drv (filter-map (match-lambda
	346	((name version sub-drv
	347	(? package? package))
	348	(package-derivation %store package))
	349	(_ #f))
	350	install))
	351	(install* (append
	352	(filter-map (match-lambda
	353	(('install . (? store-path? path))
5075e283 LC	354	(let-values (((name version)
	355	(package-name->name+version
	356	(store-path-package-name
	357	path))))
	358	`(,name ,version #f ,path)))
733b4130 LC	359	(_ #f))
	360	opts)
	361	(map (lambda (tuple drv)
	362	(match tuple
	363	((name version sub-drv _)
	364	(let ((output-path
	365	(derivation-path->output-path
	366	drv sub-drv)))
	367	`(,name ,version ,sub-drv ,output-path)))))
	368	install drv)))
	369	(remove (filter-map (match-lambda
	370	(('remove . package)
	371	package)
	372	(_ #f))
	373	opts))
	374	(packages (append install*
1c67d639 LC	375	(fold (lambda (package result)
	376	(match package
	377	((name _ ...)
	378	(alist-delete name result))))
	379	(fold alist-delete
	380	(manifest-packages
	381	(profile-manifest profile))
	382	remove)
	383	install*))))
733b4130 LC	384
	385	(show-what-to-build drv dry-run?)
	386
	387	(or dry-run?
	388	(and (build-derivations %store drv)
	389	(let* ((prof-drv (profile-derivation %store packages))
	390	(prof (derivation-path->output-path prof-drv))
1c67d639 LC	391	(old-drv (profile-derivation
	392	%store (manifest-packages
	393	(profile-manifest profile))))
	394	(old-prof (derivation-path->output-path old-drv))
733b4130 LC	395	(number (latest-profile-number profile))
	396	(name (format #f "~a/~a-~a-link"
	397	(dirname profile)
	398	(basename profile) (+ 1 number))))
1c67d639 LC	399	(if (string=? old-prof prof)
1c67d639 LC	400	(format (current-error-port) (_ "nothing to be done~%"))
70915c1a	401	(and (parameterize ((current-build-output-port
9762706b LC	402	;; Output something when Guile
	403	;; needs to be built.
	404	(if (or verbose? (guile-missing?))
70915c1a LC	405	(current-error-port)
	406	(%make-void-port "w"))))
	407	(build-derivations %store (list prof-drv)))
1c67d639 LC	408	(begin
	409	(symlink prof name)
	410	(when (file-exists? profile)
	411	(delete-file profile))
	412	(symlink name profile)))))))))
733b4130 LC	413
	414	(define (process-query opts)
	415	;; Process any query specified by OPTS. Return #t when a query was
	416	;; actually processed, #f otherwise.
	417	(let ((profile (assoc-ref opts 'profile)))
	418	(match (assoc-ref opts 'query)
	419	(('list-installed regexp)
	420	(let* ((regexp (and regexp (make-regexp regexp)))
	421	(manifest (profile-manifest profile))
	422	(installed (manifest-packages manifest)))
	423	(for-each (match-lambda
	424	((name version output path)
	425	(when (or (not regexp)
	426	(regexp-exec regexp name))
	427	(format #t "~a\t~a\t~a\t~a~%"
	428	name (or version "?") output path))))
64fc89b6 LC	429	installed)
	430	#t))
	431	(('list-available regexp)
	432	(let* ((regexp (and regexp (make-regexp regexp)))
	433	(available (fold-packages
	434	(lambda (p r)
	435	(let ((n (package-name p)))
	436	(if regexp
	437	(if (regexp-exec regexp n)
	438	(cons p r)
	439	r)
	440	(cons p r))))
	441	'())))
	442	(for-each (lambda (p)
44b6be77	443	(format #t "~a\t~a\t~a\t~a~%"
64fc89b6 LC	444	(package-name p)
64fc89b6 LC	445	(package-version p)
44b6be77	446	(string-join (package-outputs p) ",")
64fc89b6 LC	447	(location->string (package-location p))))
	448	(sort available
	449	(lambda (p1 p2)
	450	(string<? (package-name p1)
	451	(package-name p2)))))
	452	#t))
733b4130 LC	453	(_ #f))))
733b4130 LC	454
0afdc485 LC	455	(setlocale LC_ALL "")
	456	(textdomain "guix")
	457	(setvbuf (current-output-port) _IOLBF)
	458	(setvbuf (current-error-port) _IOLBF)
	459
	460	(let ((opts (parse-options)))
b9e5c0a9 LC	461
	462	;; Create ~/.guix-profile if it doesn't exist yet.
	463	(when (and %user-environment-directory
	464	%current-profile
	465	(not (file-exists? %user-environment-directory)))
	466	(symlink %current-profile %user-environment-directory))
	467
1275baeb	468	(with-error-handling
733b4130 LC	469	(or (process-query opts)
	470	(parameterize ((%guile-for-build
	471	(package-derivation %store
	472	(if (assoc-ref opts 'bootstrap?)
87009d8a LC	473	%bootstrap-guile
87009d8a LC	474	guile-final))))
733b4130	475	(process-actions opts))))))