[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 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 (_ "
  -b, --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 '(#\b "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 (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
                                          (if verbose?
                                              (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~%"
                               (package-name p)
                               (package-version 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)))
    (with-error-handling
      (or (process-query opts)
          (parameterize ((%guile-for-build
                          (package-derivation %store
                                              (if (assoc-ref opts 'bootstrap?)
                                                  (@@ (distro packages base)
                                                      %bootstrap-guile)
                                                  guile-2.0))))
            (process-actions opts))))))

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