guix-package.in

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