[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)))" "$@"
!#
;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
;;; 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.
;;;
;;; 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 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)
  (format #t (_ "
Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))

(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	!#
	14	;;; Guix --- Nix package management from Guile. -- coding: utf-8 --
	15	;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
	16	;;;
	17	;;; This file is part of Guix.
	18	;;;
	19	;;; Guix is free software; you can redistribute it and/or modify it
	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	;;;
	24	;;; Guix is distributed in the hope that it will be useful, but
	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
	30	;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
	31
	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)
	220	(format #t (_ "
	221	Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
	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)))
	246	(option '(#\b "bootstrap") #f #f
	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
	276	(define (show-what-to-build drv dry-run?)
	277	;; Show what will/would be built in realizing the derivations listed
	278	;; in DRV.
	279	(let* ((req (append-map (lambda (drv-path)
	280	(let ((d (call-with-input-file drv-path
	281	read-derivation)))
	282	(derivation-prerequisites-to-build %store d)))
	283	drv))
	284	(req* (delete-duplicates
	285	(append (remove (compose (cut valid-path? %store <>)
	286	derivation-path->output-path)
	287	drv)
	288	(map derivation-input-path req)))))
	289	(if dry-run?
	290	(format (current-error-port)
	291	(N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
	292	"~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
	293	(length req*))
	294	(null? req) req)
	295	(format (current-error-port)
	296	(N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
	297	"~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
	298	(length req*))
	299	(null? req) req))))
	300
	301	(define (find-package name)
	302	;; Find the package NAME; NAME may contain a version number and a
	303	;; sub-derivation name.
	304	(define request name)
0afdc485 LC	305
	306	(let*-values (((name sub-drv)
	307	(match (string-rindex name #\:)
	308	(#f (values name "out"))
9518856b LC	309	(colon (values (substring name 0 colon)
9518856b LC	310	(substring name (+ 1 colon))))))
0afdc485	311	((name version)
9b48fb88	312	(package-name->name+version name)))
0afdc485 LC	313	(match (find-packages-by-name name version)
0afdc485 LC	314	((p)
d9d05363	315	(list name (package-version p) sub-drv p))
c6f09dfa	316	((p p* ...)
0afdc485 LC	317	(format (current-error-port)
	318	(_ "warning: ambiguous package specification `~a'~%")
	319	request)
	320	(format (current-error-port)
d9d05363 LC	321	(_ "warning: choosing ~a from ~a~%")
	322	(package-full-name p)
	323	(location->string (package-location p)))
	324	(list name (package-version p) sub-drv p))
0afdc485 LC	325	(()
	326	(leave (_ "~a: package not found~%") request)))))
	327
733b4130 LC	328	(define (process-actions opts)
	329	;; Process any install/remove/upgrade action from OPTS.
	330	(let* ((dry-run? (assoc-ref opts 'dry-run?))
70915c1a	331	(verbose? (assoc-ref opts 'verbose?))
733b4130 LC	332	(profile (assoc-ref opts 'profile))
	333	(install (filter-map (match-lambda
	334	(('install . (? store-path?))
	335	#f)
	336	(('install . package)
	337	(find-package package))
	338	(_ #f))
	339	opts))
	340	(drv (filter-map (match-lambda
	341	((name version sub-drv
	342	(? package? package))
	343	(package-derivation %store package))
	344	(_ #f))
	345	install))
	346	(install* (append
	347	(filter-map (match-lambda
	348	(('install . (? store-path? path))
5075e283 LC	349	(let-values (((name version)
	350	(package-name->name+version
	351	(store-path-package-name
	352	path))))
	353	`(,name ,version #f ,path)))
733b4130 LC	354	(_ #f))
	355	opts)
	356	(map (lambda (tuple drv)
	357	(match tuple
	358	((name version sub-drv _)
	359	(let ((output-path
	360	(derivation-path->output-path
	361	drv sub-drv)))
	362	`(,name ,version ,sub-drv ,output-path)))))
	363	install drv)))
	364	(remove (filter-map (match-lambda
	365	(('remove . package)
	366	package)
	367	(_ #f))
	368	opts))
	369	(packages (append install*
1c67d639 LC	370	(fold (lambda (package result)
	371	(match package
	372	((name _ ...)
	373	(alist-delete name result))))
	374	(fold alist-delete
	375	(manifest-packages
	376	(profile-manifest profile))
	377	remove)
	378	install*))))
733b4130 LC	379
	380	(show-what-to-build drv dry-run?)
	381
	382	(or dry-run?
	383	(and (build-derivations %store drv)
	384	(let* ((prof-drv (profile-derivation %store packages))
	385	(prof (derivation-path->output-path prof-drv))
1c67d639 LC	386	(old-drv (profile-derivation
	387	%store (manifest-packages
	388	(profile-manifest profile))))
	389	(old-prof (derivation-path->output-path old-drv))
733b4130 LC	390	(number (latest-profile-number profile))
	391	(name (format #f "~a/~a-~a-link"
	392	(dirname profile)
	393	(basename profile) (+ 1 number))))
1c67d639 LC	394	(if (string=? old-prof prof)
1c67d639 LC	395	(format (current-error-port) (_ "nothing to be done~%"))
70915c1a LC	396	(and (parameterize ((current-build-output-port
	397	(if verbose?
	398	(current-error-port)
	399	(%make-void-port "w"))))
	400	(build-derivations %store (list prof-drv)))
1c67d639 LC	401	(begin
	402	(symlink prof name)
	403	(when (file-exists? profile)
	404	(delete-file profile))
	405	(symlink name profile)))))))))
733b4130 LC	406
	407	(define (process-query opts)
	408	;; Process any query specified by OPTS. Return #t when a query was
	409	;; actually processed, #f otherwise.
	410	(let ((profile (assoc-ref opts 'profile)))
	411	(match (assoc-ref opts 'query)
	412	(('list-installed regexp)
	413	(let* ((regexp (and regexp (make-regexp regexp)))
	414	(manifest (profile-manifest profile))
	415	(installed (manifest-packages manifest)))
	416	(for-each (match-lambda
	417	((name version output path)
	418	(when (or (not regexp)
	419	(regexp-exec regexp name))
	420	(format #t "~a\t~a\t~a\t~a~%"
	421	name (or version "?") output path))))
64fc89b6 LC	422	installed)
	423	#t))
	424	(('list-available regexp)
	425	(let* ((regexp (and regexp (make-regexp regexp)))
	426	(available (fold-packages
	427	(lambda (p r)
	428	(let ((n (package-name p)))
	429	(if regexp
	430	(if (regexp-exec regexp n)
	431	(cons p r)
	432	r)
	433	(cons p r))))
	434	'())))
	435	(for-each (lambda (p)
	436	(format #t "~a\t~a\t~a~%"
	437	(package-name p)
	438	(package-version p)
	439	(location->string (package-location p))))
	440	(sort available
	441	(lambda (p1 p2)
	442	(string<? (package-name p1)
	443	(package-name p2)))))
	444	#t))
733b4130 LC	445	(_ #f))))
733b4130 LC	446
0afdc485 LC	447	(setlocale LC_ALL "")
	448	(textdomain "guix")
	449	(setvbuf (current-output-port) _IOLBF)
	450	(setvbuf (current-error-port) _IOLBF)
	451
	452	(let ((opts (parse-options)))
1275baeb	453	(with-error-handling
733b4130 LC	454	(or (process-query opts)
	455	(parameterize ((%guile-for-build
	456	(package-derivation %store
	457	(if (assoc-ref opts 'bootstrap?)
	458	(@@ (distro packages base)
	459	%bootstrap-guile)
	460	guile-2.0))))
	461	(process-actions opts))))))
0afdc485 LC	462
	463	;; Local Variables:
	464	;; eval: (put 'guard 'scheme-indent-function 1)
	465	;; End: