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