emacs/guix-main.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; Commentary:
  20
  21 ;; Information about packages and generations is passed to the elisp
  22 ;; side in the form of alists of parameters (such as ‘name’ or
  23 ;; ‘version’) and their values.
  24
  25 ;; ‘entries’ procedure is the “entry point” for the elisp side to get
  26 ;; information about packages and generations.
  27
  28 ;; Since name/version pair is not necessarily unique, we use
  29 ;; `object-address' to identify a package (for ‘id’ parameter), if
  30 ;; possible.  However for the obsolete packages (that can be found in
  31 ;; installed manifest but not in a package directory), ‘id’ parameter is
  32 ;; still "name-version" string.  So ‘id’ package parameter in the code
  33 ;; below is either an object-address number or a full-name string.
  34
  35 ;; To speed-up the process of getting information, the following
  36 ;; auxiliary variables are used:
  37 ;;
  38 ;; - `%packages' - VHash of "package address"/"package" pairs.
  39 ;;
  40 ;; - `%package-table' - Hash table of
  41 ;;   "name+version key"/"list of packages" pairs.
  42
  43 ;;; Code:
  44
  45 (use-modules
  46  (ice-9 vlist)
  47  (ice-9 match)
  48  (srfi srfi-1)
  49  (srfi srfi-2)
  50  (srfi srfi-11)
  51  (srfi srfi-19)
  52  (srfi srfi-26)
  53  (guix)
  54  (guix git-download)
  55  (guix packages)
  56  (guix profiles)
  57  (guix licenses)
  58  (guix utils)
  59  (guix ui)
  60  (guix scripts package)
  61  (guix scripts pull)
  62  (gnu packages))
  63
  64 (define-syntax-rule (first-or-false lst)
  65   (and (not (null? lst))
  66        (first lst)))
  67
  68 (define (list-maybe obj)
  69   (if (list? obj) obj (list obj)))
  70
  71 (define full-name->name+version package-name->name+version)
  72 (define (name+version->full-name name version)
  73   (string-append name "-" version))
  74
  75 (define* (make-package-specification name #:optional version output)
  76   (let ((full-name (if version
  77                        (name+version->full-name name version)
  78                        name)))
  79     (if output
  80         (string-append full-name ":" output)
  81         full-name)))
  82
  83 (define name+version->key cons)
  84 (define key->name+version car+cdr)
  85
  86 (define %packages
  87   (fold-packages (lambda (pkg res)
  88                    (vhash-consq (object-address pkg) pkg res))
  89                  vlist-null))
  90
  91 (define %package-table
  92   (let ((table (make-hash-table (vlist-length %packages))))
  93     (vlist-for-each
  94      (lambda (elem)
  95        (match elem
  96          ((address . pkg)
  97           (let* ((key (name+version->key (package-name pkg)
  98                                          (package-version pkg)))
  99                  (ref (hash-ref table key)))
 100             (hash-set! table key
 101                        (if ref (cons pkg ref) (list pkg)))))))
 102      %packages)
 103     table))
 104
 105 (define (manifest-entry->name+version+output entry)
 106   (values
 107    (manifest-entry-name    entry)
 108    (manifest-entry-version entry)
 109    (manifest-entry-output  entry)))
 110
 111 (define (manifest-entry->package-specification entry)
 112   (call-with-values
 113       (lambda () (manifest-entry->name+version+output entry))
 114     make-package-specification))
 115
 116 (define (manifest-entries->package-specifications entries)
 117   (map manifest-entry->package-specification entries))
 118
 119 (define (generation-package-specifications profile number)
 120   "Return a list of package specifications for generation NUMBER."
 121   (let ((manifest (profile-manifest
 122                    (generation-file-name profile number))))
 123     (manifest-entries->package-specifications
 124      (manifest-entries manifest))))
 125
 126 (define (generation-package-specifications+paths profile number)
 127   "Return a list of package specifications and paths for generation NUMBER.
 128 Each element of the list is a list of the package specification and its path."
 129   (let ((manifest (profile-manifest
 130                    (generation-file-name profile number))))
 131     (map (lambda (entry)
 132            (list (manifest-entry->package-specification entry)
 133                  (manifest-entry-item entry)))
 134          (manifest-entries manifest))))
 135
 136 (define (generation-difference profile number1 number2)
 137   "Return a list of package specifications for outputs installed in generation
 138 NUMBER1 and not installed in generation NUMBER2."
 139   (let ((specs1 (generation-package-specifications profile number1))
 140         (specs2 (generation-package-specifications profile number2)))
 141     (lset-difference string=? specs1 specs2)))
 142
 143 (define (manifest-entries->hash-table entries)
 144   "Return a hash table of name keys and lists of matching manifest ENTRIES."
 145   (let ((table (make-hash-table (length entries))))
 146     (for-each (lambda (entry)
 147                 (let* ((key (manifest-entry-name entry))
 148                        (ref (hash-ref table key)))
 149                   (hash-set! table key
 150                              (if ref (cons entry ref) (list entry)))))
 151               entries)
 152     table))
 153
 154 (define (manifest=? m1 m2)
 155   (or (eq? m1 m2)
 156       (equal? m1 m2)))
 157
 158 (define manifest->hash-table
 159   (let ((current-manifest #f)
 160         (current-table #f))
 161     (lambda (manifest)
 162       "Return a hash table of name keys and matching MANIFEST entries."
 163       (unless (manifest=? manifest current-manifest)
 164         (set! current-manifest manifest)
 165         (set! current-table (manifest-entries->hash-table
 166                              (manifest-entries manifest))))
 167       current-table)))
 168
 169 (define* (manifest-entries-by-name manifest name #:optional version output)
 170   "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT."
 171   (let ((entries (or (hash-ref (manifest->hash-table manifest) name)
 172                      '())))
 173     (if (or version output)
 174         (filter (lambda (entry)
 175                   (and (or (not version)
 176                            (equal? version (manifest-entry-version entry)))
 177                        (or (not output)
 178                            (equal? output  (manifest-entry-output entry)))))
 179                 entries)
 180         entries)))
 181
 182 (define (manifest-entry-by-output entries output)
 183   "Return a manifest entry from ENTRIES matching OUTPUT."
 184   (find (lambda (entry)
 185           (string= output (manifest-entry-output entry)))
 186         entries))
 187
 188 (define (fold-manifest-by-name manifest proc init)
 189   "Fold over MANIFEST entries.
 190 Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value
 191 of RESULT.  ENTRIES is a list of manifest entries with NAME/VERSION."
 192   (hash-fold (lambda (name entries res)
 193                (proc name (manifest-entry-version (car entries))
 194                      entries res))
 195              init
 196              (manifest->hash-table manifest)))
 197
 198 (define* (object-transformer param-alist #:optional (params '()))
 199   "Return procedure transforming objects into alist of parameter/value pairs.
 200
 201 PARAM-ALIST is alist of available parameters (symbols) and procedures
 202 returning values of these parameters.  Each procedure is applied to
 203 objects.
 204
 205 PARAMS is list of parameters from PARAM-ALIST that should be returned by
 206 a resulting procedure.  If PARAMS is not specified or is an empty list,
 207 use all available parameters.
 208
 209 Example:
 210
 211   (let* ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
 212          (number->alist (object-transformer alist '(plus1 mul2))))
 213     (number->alist 8))
 214   =>
 215   ((plus1 . 9) (mul2 . 16))
 216 "
 217   (let* ((use-all-params (null? params))
 218          (alist (filter-map (match-lambda
 219                              ((param . proc)
 220                               (and (or use-all-params
 221                                        (memq param params))
 222                                    (cons param proc)))
 223                              (_ #f))
 224                             param-alist)))
 225     (lambda objects
 226       (map (match-lambda
 227             ((param . proc)
 228              (cons param (apply proc objects))))
 229            alist))))
 230
 231 (define %manifest-entry-param-alist
 232   `((output       . ,manifest-entry-output)
 233     (path         . ,manifest-entry-item)
 234     (dependencies . ,manifest-entry-dependencies)))
 235
 236 (define manifest-entry->sexp
 237   (object-transformer %manifest-entry-param-alist))
 238
 239 (define (manifest-entries->sexps entries)
 240   (map manifest-entry->sexp entries))
 241
 242 (define (package-inputs-names inputs)
 243   "Return a list of full names of the packages from package INPUTS."
 244   (filter-map (match-lambda
 245                ((_ (? package? package))
 246                 (package-full-name package))
 247                (_ #f))
 248               inputs))
 249
 250 (define (package-license-names package)
 251   "Return a list of license names of the PACKAGE."
 252   (filter-map (lambda (license)
 253                 (and (license? license)
 254                      (license-name license)))
 255               (list-maybe (package-license package))))
 256
 257 (define (package-source-names package)
 258   "Return a list of source names (URLs) of the PACKAGE."
 259   (let ((source (package-source package)))
 260     (and (origin? source)
 261          (filter-map (lambda (uri)
 262                        (cond ((string? uri)
 263                               uri)
 264                              ((git-reference? uri)
 265                               (git-reference-url uri))
 266                              (else "Unknown source type")))
 267                      (list-maybe (origin-uri source))))))
 268
 269 (define (package-unique? package)
 270   "Return #t if PACKAGE is a single package with such name/version."
 271   (null? (cdr (packages-by-name (package-name package)
 272                                 (package-version package)))))
 273
 274 (define %package-param-alist
 275   `((id                . ,object-address)
 276     (package-id        . ,object-address)
 277     (name              . ,package-name)
 278     (version           . ,package-version)
 279     (license           . ,package-license-names)
 280     (source            . ,package-source-names)
 281     (synopsis          . ,package-synopsis)
 282     (description       . ,package-description)
 283     (home-url          . ,package-home-page)
 284     (outputs           . ,package-outputs)
 285     (non-unique        . ,(negate package-unique?))
 286     (inputs            . ,(lambda (pkg)
 287                             (package-inputs-names
 288                              (package-inputs pkg))))
 289     (native-inputs     . ,(lambda (pkg)
 290                             (package-inputs-names
 291                              (package-native-inputs pkg))))
 292     (propagated-inputs . ,(lambda (pkg)
 293                             (package-inputs-names
 294                              (package-propagated-inputs pkg))))
 295     (location          . ,(lambda (pkg)
 296                             (location->string (package-location pkg))))))
 297
 298 (define (package-param package param)
 299   "Return a value of a PACKAGE PARAM."
 300   (and=> (assq-ref %package-param-alist param)
 301          (cut <> package)))
 302
 303 \f
 304 ;;; Finding packages.
 305
 306 (define (package-by-address address)
 307   (and=> (vhash-assq address %packages)
 308          cdr))
 309
 310 (define (packages-by-name+version name version)
 311   (or (hash-ref %package-table
 312                 (name+version->key name version))
 313       '()))
 314
 315 (define (packages-by-full-name full-name)
 316   (call-with-values
 317       (lambda () (full-name->name+version full-name))
 318     packages-by-name+version))
 319
 320 (define (packages-by-id id)
 321   (if (integer? id)
 322       (let ((pkg (package-by-address id)))
 323         (if pkg (list pkg) '()))
 324       (packages-by-full-name id)))
 325
 326 (define (id->name+version id)
 327   (if (integer? id)
 328       (and=> (package-by-address id)
 329              (lambda (pkg)
 330                (values (package-name pkg)
 331                        (package-version pkg))))
 332       (full-name->name+version id)))
 333
 334 (define (package-by-id id)
 335   (first-or-false (packages-by-id id)))
 336
 337 (define (newest-package-by-id id)
 338   (and=> (id->name+version id)
 339          (lambda (name)
 340            (first-or-false (find-best-packages-by-name name #f)))))
 341
 342 (define (matching-packages predicate)
 343   (fold-packages (lambda (pkg res)
 344                    (if (predicate pkg)
 345                        (cons pkg res)
 346                        res))
 347                  '()))
 348
 349 (define (filter-packages-by-output packages output)
 350   (filter (lambda (package)
 351             (member output (package-outputs package)))
 352           packages))
 353
 354 (define* (packages-by-name name #:optional version output)
 355   "Return a list of packages matching NAME, VERSION and OUTPUT."
 356   (let ((packages (if version
 357                       (packages-by-name+version name version)
 358                       (matching-packages
 359                        (lambda (pkg) (string=? name (package-name pkg)))))))
 360     (if output
 361         (filter-packages-by-output packages output)
 362         packages)))
 363
 364 (define (manifest-entry->packages entry)
 365   (call-with-values
 366       (lambda () (manifest-entry->name+version+output entry))
 367     packages-by-name))
 368
 369 (define (packages-by-regexp regexp match-params)
 370   "Return a list of packages matching REGEXP string.
 371 MATCH-PARAMS is a list of parameters that REGEXP can match."
 372   (define (package-match? package regexp)
 373     (any (lambda (param)
 374            (let ((val (package-param package param)))
 375              (and (string? val) (regexp-exec regexp val))))
 376          match-params))
 377
 378   (let ((re (make-regexp regexp regexp/icase)))
 379     (matching-packages (cut package-match? <> re))))
 380
 381 (define (all-available-packages)
 382   "Return a list of all available packages."
 383   (matching-packages (const #t)))
 384
 385 (define (newest-available-packages)
 386   "Return a list of the newest available packages."
 387   (vhash-fold (lambda (name elem res)
 388                 (match elem
 389                   ((_ newest pkgs ...)
 390                    (cons newest res))))
 391               '()
 392               (find-newest-available-packages)))
 393
 394 \f
 395 ;;; Making package/output patterns.
 396
 397 (define (specification->package-pattern specification)
 398   (call-with-values
 399       (lambda ()
 400         (full-name->name+version specification))
 401     list))
 402
 403 (define (specification->output-pattern specification)
 404   (call-with-values
 405       (lambda ()
 406         (package-specification->name+version+output specification #f))
 407     list))
 408
 409 (define (id->package-pattern id)
 410   (if (integer? id)
 411       (package-by-address id)
 412       (specification->package-pattern id)))
 413
 414 (define (id->output-pattern id)
 415   "Return an output pattern by output ID.
 416 ID should be '<package-address>:<output>' or '<name>-<version>:<output>'."
 417   (let-values (((name version output)
 418                 (package-specification->name+version+output id)))
 419     (if version
 420         (list name version output)
 421         (list (package-by-address (string->number name))
 422               output))))
 423
 424 (define (specifications->package-patterns . specifications)
 425   (map specification->package-pattern specifications))
 426
 427 (define (specifications->output-patterns . specifications)
 428   (map specification->output-pattern specifications))
 429
 430 (define (ids->package-patterns . ids)
 431   (map id->package-pattern ids))
 432
 433 (define (ids->output-patterns . ids)
 434   (map id->output-pattern ids))
 435
 436 (define* (manifest-patterns-result packages res obsolete-pattern
 437                                    #:optional installed-pattern)
 438   "Auxiliary procedure for 'manifest-package-patterns' and
 439 'manifest-output-patterns'."
 440   (if (null? packages)
 441       (cons (obsolete-pattern) res)
 442       (if installed-pattern
 443           ;; We don't need duplicates for a list of installed packages,
 444           ;; so just take any (car) package.
 445           (cons (installed-pattern (car packages)) res)
 446           res)))
 447
 448 (define* (manifest-package-patterns manifest #:optional obsolete-only?)
 449   "Return a list of package patterns for MANIFEST entries.
 450 If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
 451 for obsolete packages."
 452   (fold-manifest-by-name
 453    manifest
 454    (lambda (name version entries res)
 455      (manifest-patterns-result (packages-by-name name version)
 456                                res
 457                                (lambda () (list name version entries))
 458                                (and (not obsolete-only?)
 459                                     (cut list <> entries))))
 460    '()))
 461
 462 (define* (manifest-output-patterns manifest #:optional obsolete-only?)
 463   "Return a list of output patterns for MANIFEST entries.
 464 If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
 465 for obsolete packages."
 466   (fold (lambda (entry res)
 467           (manifest-patterns-result (manifest-entry->packages entry)
 468                                     res
 469                                     (lambda () entry)
 470                                     (and (not obsolete-only?)
 471                                          (cut list <> entry))))
 472         '()
 473         (manifest-entries manifest)))
 474
 475 (define (obsolete-package-patterns manifest)
 476   (manifest-package-patterns manifest #t))
 477
 478 (define (obsolete-output-patterns manifest)
 479   (manifest-output-patterns manifest #t))
 480
 481 \f
 482 ;;; Transforming package/output patterns into alists.
 483
 484 (define (obsolete-package-sexp name version entries)
 485   "Return an alist with information about obsolete package.
 486 ENTRIES is a list of installed manifest entries."
 487   `((id        . ,(name+version->full-name name version))
 488     (name      . ,name)
 489     (version   . ,version)
 490     (outputs   . ,(map manifest-entry-output entries))
 491     (obsolete  . #t)
 492     (installed . ,(manifest-entries->sexps entries))))
 493
 494 (define (package-pattern-transformer manifest params)
 495   "Return 'package-pattern->package-sexps' procedure."
 496   (define package->sexp
 497     (object-transformer %package-param-alist params))
 498
 499   (define* (sexp-by-package package #:optional
 500                             (entries (manifest-entries-by-name
 501                                       manifest
 502                                       (package-name package)
 503                                       (package-version package))))
 504     (cons (cons 'installed (manifest-entries->sexps entries))
 505           (package->sexp package)))
 506
 507   (define (->sexps pattern)
 508     (match pattern
 509       ((? package? package)
 510        (list (sexp-by-package package)))
 511       (((? package? package) entries)
 512        (list (sexp-by-package package entries)))
 513       ((name version entries)
 514        (list (obsolete-package-sexp
 515               name version entries)))
 516       ((name version)
 517        (let ((packages (packages-by-name name version)))
 518          (if (null? packages)
 519              (let ((entries (manifest-entries-by-name
 520                              manifest name version)))
 521                (if (null? entries)
 522                    '()
 523                    (list (obsolete-package-sexp
 524                           name version entries))))
 525              (map sexp-by-package packages))))
 526       (_ '())))
 527
 528   ->sexps)
 529
 530 (define (output-pattern-transformer manifest params)
 531   "Return 'output-pattern->output-sexps' procedure."
 532   (define package->sexp
 533     (object-transformer (alist-delete 'id %package-param-alist)
 534                         params))
 535
 536   (define manifest-entry->sexp
 537     (object-transformer (alist-delete 'output %manifest-entry-param-alist)
 538                         params))
 539
 540   (define* (output-sexp pkg-alist pkg-address output
 541                         #:optional entry)
 542     (let ((entry-alist (if entry
 543                            (manifest-entry->sexp entry)
 544                            '()))
 545           (base `((id        . ,(string-append
 546                                  (number->string pkg-address)
 547                                  ":" output))
 548                   (output    . ,output)
 549                   (installed . ,(->bool entry)))))
 550       (append entry-alist base pkg-alist)))
 551
 552   (define (obsolete-output-sexp entry)
 553     (let-values (((name version output)
 554                   (manifest-entry->name+version+output entry)))
 555       (let ((base `((id         . ,(make-package-specification
 556                                     name version output))
 557                     (package-id . ,(name+version->full-name name version))
 558                     (name       . ,name)
 559                     (version    . ,version)
 560                     (output     . ,output)
 561                     (obsolete   . #t)
 562                     (installed  . #t))))
 563         (append (manifest-entry->sexp entry) base))))
 564
 565   (define* (sexps-by-package package #:optional output
 566                              (entries (manifest-entries-by-name
 567                                        manifest
 568                                        (package-name package)
 569                                        (package-version package))))
 570     ;; Assuming that PACKAGE has this OUTPUT.
 571     (let ((pkg-alist (package->sexp package))
 572           (address (object-address package))
 573           (outputs (if output
 574                        (list output)
 575                        (package-outputs package))))
 576       (map (lambda (output)
 577              (output-sexp pkg-alist address output
 578                           (manifest-entry-by-output entries output)))
 579            outputs)))
 580
 581   (define* (sexps-by-manifest-entry entry #:optional
 582                                     (packages (manifest-entry->packages
 583                                                entry)))
 584     (if (null? packages)
 585         (list (obsolete-output-sexp entry))
 586         (map (lambda (package)
 587                (output-sexp (package->sexp package)
 588                             (object-address package)
 589                             (manifest-entry-output entry)
 590                             entry))
 591              packages)))
 592
 593   (define (->sexps pattern)
 594     (match pattern
 595       ((? package? package)
 596        (sexps-by-package package))
 597       ((package (? string? output))
 598        (sexps-by-package package output))
 599       ((? manifest-entry? entry)
 600        (list (obsolete-output-sexp entry)))
 601       ((package entry)
 602        (sexps-by-manifest-entry entry (list package)))
 603       ((name version output)
 604        (let ((packages (packages-by-name name version output)))
 605          (if (null? packages)
 606              (let ((entries (manifest-entries-by-name
 607                              manifest name version output)))
 608                (append-map (cut sexps-by-manifest-entry <>)
 609                            entries))
 610              (append-map (cut sexps-by-package <> output)
 611                          packages))))
 612       (_ '())))
 613
 614   ->sexps)
 615
 616 (define (entry-type-error entry-type)
 617   (error (format #f "Wrong entry-type '~a'" entry-type)))
 618
 619 (define (search-type-error entry-type search-type)
 620   (error (format #f "Wrong search type '~a' for entry-type '~a'"
 621                  search-type entry-type)))
 622
 623 (define %pattern-transformers
 624   `((package . ,package-pattern-transformer)
 625     (output  . ,output-pattern-transformer)))
 626
 627 (define (pattern-transformer entry-type)
 628   (assq-ref %pattern-transformers entry-type))
 629
 630 ;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS)
 631 ;; as arguments; see `package/output-sexps'.
 632 (define %patterns-makers
 633   (let* ((apply-to-rest         (lambda (proc)
 634                                   (lambda (_ . rest) (apply proc rest))))
 635          (apply-to-first        (lambda (proc)
 636                                   (lambda (first . _) (proc first))))
 637          (manifest-package-proc (apply-to-first manifest-package-patterns))
 638          (manifest-output-proc  (apply-to-first manifest-output-patterns))
 639          (regexp-proc           (lambda (_ regexp params . __)
 640                                   (packages-by-regexp regexp params)))
 641          (all-proc              (lambda _ (all-available-packages)))
 642          (newest-proc           (lambda _ (newest-available-packages))))
 643     `((package
 644        (id               . ,(apply-to-rest ids->package-patterns))
 645        (name             . ,(apply-to-rest specifications->package-patterns))
 646        (installed        . ,manifest-package-proc)
 647        (generation       . ,manifest-package-proc)
 648        (obsolete         . ,(apply-to-first obsolete-package-patterns))
 649        (regexp           . ,regexp-proc)
 650        (all-available    . ,all-proc)
 651        (newest-available . ,newest-proc))
 652       (output
 653        (id               . ,(apply-to-rest ids->output-patterns))
 654        (name             . ,(apply-to-rest specifications->output-patterns))
 655        (installed        . ,manifest-output-proc)
 656        (generation       . ,manifest-output-proc)
 657        (obsolete         . ,(apply-to-first obsolete-output-patterns))
 658        (regexp           . ,regexp-proc)
 659        (all-available    . ,all-proc)
 660        (newest-available . ,newest-proc)))))
 661
 662 (define (patterns-maker entry-type search-type)
 663   (or (and=> (assq-ref %patterns-makers entry-type)
 664              (cut assq-ref <> search-type))
 665       (search-type-error entry-type search-type)))
 666
 667 (define (package/output-sexps profile params entry-type
 668                               search-type search-vals)
 669   "Return information about packages or package outputs.
 670 See 'entry-sexps' for details."
 671   (let* ((profile (if (eq? search-type 'generation)
 672                       (generation-file-name profile (car search-vals))
 673                       profile))
 674          (manifest (profile-manifest profile))
 675          (patterns (if (and (eq? entry-type 'output)
 676                             (eq? search-type 'generation-diff))
 677                        (match search-vals
 678                          ((g1 g2)
 679                           (map specification->output-pattern
 680                                (generation-difference profile g1 g2)))
 681                          (_ '()))
 682                        (apply (patterns-maker entry-type search-type)
 683                               manifest search-vals)))
 684          (->sexps ((pattern-transformer entry-type) manifest params)))
 685     (append-map ->sexps patterns)))
 686
 687 \f
 688 ;;; Getting information about generations.
 689
 690 (define (generation-param-alist profile)
 691   "Return an alist of generation parameters and procedures for PROFILE."
 692   (let ((current (generation-number profile)))
 693     `((id          . ,identity)
 694       (number      . ,identity)
 695       (prev-number . ,(cut previous-generation-number profile <>))
 696       (current     . ,(cut = current <>))
 697       (path        . ,(cut generation-file-name profile <>))
 698       (time        . ,(lambda (gen)
 699                         (time-second (generation-time profile gen)))))))
 700
 701 (define (matching-generations profile predicate)
 702   "Return a list of PROFILE generations matching PREDICATE."
 703   (filter predicate (profile-generations profile)))
 704
 705 (define (last-generations profile number)
 706   "Return a list of last NUMBER generations.
 707 If NUMBER is 0 or less, return all generations."
 708   (let ((generations (profile-generations profile))
 709         (number (if (<= number 0) +inf.0 number)))
 710     (if (> (length generations) number)
 711         (list-head  (reverse generations) number)
 712         generations)))
 713
 714 (define (find-generations profile search-type search-vals)
 715   "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS."
 716   (case search-type
 717     ((id)
 718      (matching-generations profile (cut memq <> search-vals)))
 719     ((last)
 720      (last-generations profile (car search-vals)))
 721     ((all)
 722      (last-generations profile +inf.0))
 723     ((time)
 724      (match search-vals
 725        ((from to)
 726         (matching-generations
 727          profile
 728          (lambda (gen)
 729            (let ((time (time-second (generation-time profile gen))))
 730              (< from time to)))))
 731        (_ '())))
 732     (else (search-type-error "generation" search-type))))
 733
 734 (define (generation-sexps profile params search-type search-vals)
 735   "Return information about generations.
 736 See 'entry-sexps' for details."
 737   (let ((generations (find-generations profile search-type search-vals))
 738         (->sexp (object-transformer (generation-param-alist profile)
 739                                     params)))
 740     (map ->sexp generations)))
 741
 742 \f
 743 ;;; Getting package/output/generation entries (alists).
 744
 745 (define (entries profile params entry-type search-type search-vals)
 746   "Return information about entries.
 747
 748 ENTRY-TYPE is a symbol defining a type of returning information.  Should
 749 be: 'package', 'output' or 'generation'.
 750
 751 SEARCH-TYPE and SEARCH-VALS define how to get the information.
 752 SEARCH-TYPE should be one of the following symbols:
 753
 754 - If ENTRY-TYPE is 'package' or 'output':
 755   'id', 'name', 'regexp', 'all-available', 'newest-available',
 756   'installed', 'obsolete', 'generation'.
 757
 758 - If ENTRY-TYPE is 'generation':
 759   'id', 'last', 'all', 'time'.
 760
 761 PARAMS is a list of parameters for receiving.  If it is an empty list,
 762 get information with all available parameters, which are:
 763
 764 - If ENTRY-TYPE is 'package':
 765   'id', 'name', 'version', 'outputs', 'license', 'synopsis',
 766   'description', 'home-url', 'inputs', 'native-inputs',
 767   'propagated-inputs', 'location', 'installed'.
 768
 769 - If ENTRY-TYPE is 'output':
 770   'id', 'package-id', 'name', 'version', 'output', 'license',
 771   'synopsis', 'description', 'home-url', 'inputs', 'native-inputs',
 772   'propagated-inputs', 'location', 'installed', 'path', 'dependencies'.
 773
 774 - If ENTRY-TYPE is 'generation':
 775   'id', 'number', 'prev-number', 'path', 'time'.
 776
 777 Returning value is a list of alists.  Each alist consists of
 778 parameter/value pairs."
 779   (case entry-type
 780     ((package output)
 781      (package/output-sexps profile params entry-type
 782                            search-type search-vals))
 783     ((generation)
 784      (generation-sexps profile params
 785                        search-type search-vals))
 786     (else (entry-type-error entry-type))))
 787
 788 \f
 789 ;;; Package actions.
 790
 791 (define* (package->manifest-entry* package #:optional output)
 792   (and package
 793        (begin
 794          (check-package-freshness package)
 795          (package->manifest-entry package output))))
 796
 797 (define* (make-install-manifest-entries id #:optional output)
 798   (package->manifest-entry* (package-by-id id) output))
 799
 800 (define* (make-upgrade-manifest-entries id #:optional output)
 801   (package->manifest-entry* (newest-package-by-id id) output))
 802
 803 (define* (make-manifest-pattern id #:optional output)
 804   "Make manifest pattern from a package ID and OUTPUT."
 805   (let-values (((name version)
 806                 (id->name+version id)))
 807     (and name version
 808          (manifest-pattern
 809           (name name)
 810           (version version)
 811           (output output)))))
 812
 813 (define (convert-action-pattern pattern proc)
 814   "Convert action PATTERN into a list of objects returned by PROC.
 815 PROC is called: (PROC ID) or (PROC ID OUTPUT)."
 816   (match pattern
 817     ((id . outputs)
 818      (if (null? outputs)
 819          (let ((obj (proc id)))
 820            (if obj (list obj) '()))
 821          (filter-map (cut proc id <>)
 822                      outputs)))
 823     (_ '())))
 824
 825 (define (convert-action-patterns patterns proc)
 826   (append-map (cut convert-action-pattern <> proc)
 827               patterns))
 828
 829 (define* (process-package-actions
 830           profile #:key (install '()) (upgrade '()) (remove '())
 831           (use-substitutes? #t) dry-run?)
 832   "Perform package actions.
 833
 834 INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
 835 Each pattern should have the following form:
 836
 837   (ID . OUTPUTS)
 838
 839 ID is an object address or a full-name of a package.
 840 OUTPUTS is a list of package outputs (may be an empty list)."
 841   (format #t "The process begins ...~%")
 842   (let* ((install (append
 843                    (convert-action-patterns
 844                     install make-install-manifest-entries)
 845                    (convert-action-patterns
 846                     upgrade make-upgrade-manifest-entries)))
 847          (remove (convert-action-patterns remove make-manifest-pattern))
 848          (transaction (manifest-transaction (install install)
 849                                             (remove remove)))
 850          (manifest (profile-manifest profile))
 851          (new-manifest (manifest-perform-transaction
 852                         manifest transaction)))
 853     (unless (and (null? install) (null? remove))
 854       (with-store store
 855         (let* ((derivation (run-with-store store
 856                              (mbegin %store-monad
 857                                (set-guile-for-build (default-guile))
 858                                (profile-derivation new-manifest))))
 859                (derivations (list derivation))
 860                (new-profile (derivation->output-path derivation)))
 861           (set-build-options store
 862                              #:print-build-trace #f
 863                              #:use-substitutes? use-substitutes?)
 864           (show-manifest-transaction store manifest transaction
 865                                      #:dry-run? dry-run?)
 866           (show-what-to-build store derivations
 867                               #:use-substitutes? use-substitutes?
 868                               #:dry-run? dry-run?)
 869           (unless dry-run?
 870             (let ((name (generation-file-name
 871                          profile
 872                          (+ 1 (generation-number profile)))))
 873               (and (build-derivations store derivations)
 874                    (let* ((entries (manifest-entries new-manifest))
 875                           (count   (length entries)))
 876                      (switch-symlinks name new-profile)
 877                      (switch-symlinks profile name)
 878                      (format #t (N_ "~a package in profile~%"
 879                                     "~a packages in profile~%"
 880                                     count)
 881                              count)
 882                      (display-search-paths entries profile))))))))))
 883
 884 (define (delete-generations* profile generations)
 885   "Delete GENERATIONS from PROFILE.
 886 GENERATIONS is a list of generation numbers."
 887   (with-store store
 888     (delete-generations store profile generations)))
 889
 890 (define (package-source-derivation->store-path derivation)
 891   "Return a store path of the package source DERIVATION."
 892   (match (derivation-outputs derivation)
 893     ;; Source derivation is always (("out" . derivation)).
 894     (((_ . output-drv))
 895      (derivation-output-path output-drv))
 896     (_ #f)))
 897
 898 (define (package-source-path package-id)
 899   "Return a store file path to a source of a package PACKAGE-ID."
 900   (and-let* ((package (package-by-id package-id))
 901              (source  (package-source package)))
 902     (with-store store
 903       (package-source-derivation->store-path
 904        (package-source-derivation store source)))))
 905
 906 (define* (package-source-build-derivation package-id #:key dry-run?
 907                                           (use-substitutes? #t))
 908   "Build source derivation of a package PACKAGE-ID."
 909   (and-let* ((package (package-by-id package-id))
 910              (source  (package-source package)))
 911     (with-store store
 912       (let* ((derivation  (package-source-derivation store source))
 913              (derivations (list derivation)))
 914         (set-build-options store
 915                            #:print-build-trace #f
 916                            #:use-substitutes? use-substitutes?)
 917         (show-what-to-build store derivations
 918                             #:use-substitutes? use-substitutes?
 919                             #:dry-run? dry-run?)
 920         (unless dry-run?
 921           (build-derivations store derivations))
 922         (format #t "The source store path: ~a~%"
 923                 (package-source-derivation->store-path derivation))))))