gnu/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012-2020, 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   7 ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu packages)
  25   #:use-module (guix packages)
  26   #:use-module (guix ui)
  27   #:use-module (guix utils)
  28   #:use-module (guix diagnostics)
  29   #:use-module (guix discovery)
  30   #:use-module (guix memoization)
  31   #:use-module ((guix build utils)
  32                 #:select ((package-name->name+version
  33                            . hyphen-separated-name->name+version)
  34                           mkdir-p))
  35   #:use-module (guix profiles)
  36   #:use-module (guix describe)
  37   #:use-module (guix deprecation)
  38   #:use-module (ice-9 vlist)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 binary-ports)
  41   #:autoload   (system base compile) (compile)
  42   #:use-module (srfi srfi-1)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-34)
  45   #:use-module (srfi srfi-35)
  46   #:use-module (srfi srfi-39)
  47   #:use-module (srfi srfi-71)
  48   #:export (search-patch
  49             search-patches
  50             search-auxiliary-file
  51             %patch-path
  52             %auxiliary-files-path
  53             %package-module-path
  54             %default-package-module-path
  55             cache-is-authoritative?
  56
  57             fold-packages
  58             fold-available-packages
  59
  60             find-newest-available-packages
  61             find-packages-by-name
  62             find-package-locations
  63             find-best-packages-by-name
  64
  65             specification->package
  66             specification->package+output
  67             specification->location
  68             specifications->manifest
  69             specifications->packages
  70
  71             package-unique-version-prefix
  72
  73             generate-package-cache))
  74
  75 ;;; Commentary:
  76 ;;;
  77 ;;; General utilities for the software distribution---i.e., the modules under
  78 ;;; (gnu packages ...).
  79 ;;;
  80 ;;; Code:
  81
  82 ;; By default, we store patches and auxiliary files
  83 ;; alongside Guile modules.  This is so that these extra files can be
  84 ;; found without requiring a special setup, such as a specific
  85 ;; installation directory and an extra environment variable.  One
  86 ;; advantage of this setup is that everything just works in an
  87 ;; auto-compilation setting.
  88
  89 (define %auxiliary-files-path
  90   (make-parameter
  91    (map (cut string-append <> "/gnu/packages/aux-files")
  92         %load-path)))
  93
  94 (define (search-auxiliary-file file-name)
  95   "Search the auxiliary FILE-NAME.  Return #f if not found."
  96   (search-path (%auxiliary-files-path) file-name))
  97
  98 (define (search-patch file-name)
  99   "Search the patch FILE-NAME.  Raise an error if not found."
 100   (or (search-path (%patch-path) file-name)
 101       (raise (formatted-message (G_ "~a: patch not found")
 102                                 file-name))))
 103
 104 (define-syntax-rule (search-patches file-name ...)
 105   "Return the list of absolute file names corresponding to each
 106 FILE-NAME found in %PATCH-PATH."
 107   (list (search-patch file-name) ...))
 108
 109 (define %distro-root-directory
 110   ;; Absolute file name of the module hierarchy.  Since (gnu packages …) might
 111   ;; live in a directory different from (guix), try to get the best match.
 112   (letrec-syntax ((dirname* (syntax-rules ()
 113                               ((_ file)
 114                                (dirname file))
 115                               ((_ file head tail ...)
 116                                (dirname (dirname* file tail ...)))))
 117                   (try      (syntax-rules ()
 118                               ((_ (file things ...) rest ...)
 119                                (match (search-path %load-path file)
 120                                  (#f
 121                                   (try rest ...))
 122                                  (absolute
 123                                   (dirname* absolute things ...))))
 124                               ((_)
 125                                #f))))
 126     (try ("gnu/packages/base.scm" gnu/ packages/)
 127          ("gnu/packages.scm"      gnu/)
 128          ("guix.scm"))))
 129
 130 (define %default-package-module-path
 131   ;; Default search path for package modules.
 132   `((,%distro-root-directory . "gnu/packages")))
 133
 134 (define (cache-is-authoritative?)
 135   "Return true if the pre-computed package cache is authoritative.  It is not
 136 authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L'
 137 flags."
 138   (equal? (%package-module-path)
 139           (append %default-package-module-path
 140                   (package-path-entries))))
 141
 142 (define %package-module-path
 143   ;; Search path for package modules.  Each item must be either a directory
 144   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
 145   ;; to narrow the search.
 146   (let* ((not-colon   (char-set-complement (char-set #\:)))
 147          (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
 148                                        not-colon))
 149          (channels-scm channels-go (package-path-entries)))
 150     ;; Automatically add channels and items from $GUIX_PACKAGE_PATH to Guile's
 151     ;; search path.  For historical reasons, $GUIX_PACKAGE_PATH goes to the
 152     ;; front; channels go to the back so that they don't override Guix' own
 153     ;; modules.
 154     (set! %load-path
 155       (append environment %load-path channels-scm))
 156     (set! %load-compiled-path
 157       (append environment %load-compiled-path channels-go))
 158
 159     (make-parameter
 160      (append environment
 161              %default-package-module-path
 162              channels-scm))))
 163
 164 (define %patch-path
 165   ;; Define it after '%package-module-path' so that '%load-path' contains user
 166   ;; directories, allowing patches in $GUIX_PACKAGE_PATH to be found.
 167   (make-parameter
 168    (map (lambda (directory)
 169           (if (string=? directory %distro-root-directory)
 170               (string-append directory "/gnu/packages/patches")
 171               directory))
 172         %load-path)))
 173
 174 ;; This procedure is used by Emacs-Guix up to 0.5.1.1, so keep it for now.
 175 ;; See <https://github.com/alezost/guix.el/issues/30>.
 176 (define-deprecated find-newest-available-packages
 177   find-packages-by-name
 178   (mlambda ()
 179     "Return a vhash keyed by package names, and with
 180 associated values of the form
 181
 182   (newest-version newest-package ...)
 183
 184 where the preferred package is listed first."
 185     (fold-packages (lambda (p r)
 186                      (let ((name    (package-name p))
 187                            (version (package-version p)))
 188                        (match (vhash-assoc name r)
 189                          ((_ newest-so-far . pkgs)
 190                           (case (version-compare version newest-so-far)
 191                             ((>) (vhash-cons name `(,version ,p) r))
 192                             ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 193                             ((<) r)))
 194                          (#f (vhash-cons name `(,version ,p) r)))))
 195                    vlist-null)))
 196
 197 (define (fold-available-packages proc init)
 198   "Fold PROC over the list of available packages.  For each available package,
 199 PROC is called along these lines:
 200
 201   (PROC NAME VERSION RESULT
 202         #:outputs OUTPUTS
 203         #:location LOCATION
 204         …)
 205
 206 PROC can use #:allow-other-keys to ignore the bits it's not interested in.
 207 When a package cache is available, this procedure does not actually load any
 208 package module."
 209   (define cache
 210     (load-package-cache (current-profile)))
 211
 212   (if (and cache (cache-is-authoritative?))
 213       (vhash-fold (lambda (name vector result)
 214                     (match vector
 215                       (#(name version module symbol outputs
 216                               supported? deprecated?
 217                               file line column)
 218                        (proc name version result
 219                              #:outputs outputs
 220                              #:location (and file
 221                                              (location file line column))
 222                              #:supported? supported?
 223                              #:deprecated? deprecated?))))
 224                   init
 225                   cache)
 226       (fold-packages (lambda (package result)
 227                        (proc (package-name package)
 228                              (package-version package)
 229                              result
 230                              #:outputs (package-outputs package)
 231                              #:location (package-location package)
 232                              #:supported?
 233                              (->bool (supported-package? package))
 234                              #:deprecated?
 235                              (->bool
 236                               (package-superseded package))))
 237                      init)))
 238
 239 (define* (fold-packages proc init
 240                         #:optional
 241                         (modules (all-modules (%package-module-path)
 242                                               #:warn
 243                                               warn-about-load-error))
 244                         #:key (select? (negate hidden-package?)))
 245   "Call (PROC PACKAGE RESULT) for each available package defined in one of
 246 MODULES that matches SELECT?, using INIT as the initial value of RESULT.  It
 247 is guaranteed to never traverse the same package twice."
 248   (fold-module-public-variables (lambda (object result)
 249                                   (if (and (package? object) (select? object))
 250                                       (proc object result)
 251                                       result))
 252                                 init
 253                                 modules))
 254
 255 (define %package-cache-file
 256   ;; Location of the package cache.
 257   "/lib/guix/package.cache")
 258
 259 (define load-package-cache
 260   (mlambda (profile)
 261     "Attempt to load the package cache.  On success return a vhash keyed by
 262 package names.  Return #f on failure."
 263     (match profile
 264       (#f #f)
 265       (profile
 266        (catch 'system-error
 267          (lambda ()
 268            (define lst
 269              (load-compiled (string-append profile %package-cache-file)))
 270            (fold (lambda (item vhash)
 271                    (match item
 272                      (#(name version module symbol outputs
 273                              supported? deprecated?
 274                              file line column)
 275                       (vhash-cons name item vhash))))
 276                  vlist-null
 277                  lst))
 278          (lambda args
 279            (if (= ENOENT (system-error-errno args))
 280                #f
 281                (apply throw args))))))))
 282
 283 (define find-packages-by-name/direct              ;bypass the cache
 284   (let ((packages (delay
 285                     (fold-packages (lambda (p r)
 286                                      (vhash-cons (package-name p) p r))
 287                                    vlist-null)))
 288         (version>? (lambda (p1 p2)
 289                      (version>? (package-version p1) (package-version p2)))))
 290     (lambda* (name #:optional version)
 291       "Return the list of packages with the given NAME.  If VERSION is not #f,
 292 then only return packages whose version is prefixed by VERSION, sorted in
 293 decreasing version order."
 294       (let ((matching (sort (vhash-fold* cons '() name (force packages))
 295                             version>?)))
 296         (if version
 297             (filter (lambda (package)
 298                       (version-prefix? version (package-version package)))
 299                     matching)
 300             matching)))))
 301
 302 (define (cache-lookup cache name)
 303   "Lookup package NAME in CACHE.  Return a list sorted in increasing version
 304 order."
 305   (define (package-version<? v1 v2)
 306     (version>? (vector-ref v2 1) (vector-ref v1 1)))
 307
 308   (sort (vhash-fold* cons '() name cache)
 309         package-version<?))
 310
 311 (define* (find-packages-by-name name #:optional version)
 312   "Return the list of packages with the given NAME.  If VERSION is not #f,
 313 then only return packages whose version is prefixed by VERSION, sorted in
 314 decreasing version order."
 315   (define cache
 316     (load-package-cache (current-profile)))
 317
 318   (if (and (cache-is-authoritative?) cache)
 319       (match (cache-lookup cache name)
 320         (#f #f)
 321         ((#(_ versions modules symbols _ _ _ _ _ _) ...)
 322          (fold (lambda (version* module symbol result)
 323                  (if (or (not version)
 324                          (version-prefix? version version*))
 325                      (cons (module-ref (resolve-interface module)
 326                                        symbol)
 327                            result)
 328                      result))
 329                '()
 330                versions modules symbols)))
 331       (find-packages-by-name/direct name version)))
 332
 333 (define* (find-package-locations name #:optional version)
 334   "Return a list of version/location pairs corresponding to each package
 335 matching NAME and VERSION."
 336   (define cache
 337     (load-package-cache (current-profile)))
 338
 339   (if (and cache (cache-is-authoritative?))
 340       (match (cache-lookup cache name)
 341         (#f '())
 342         ((#(name versions modules symbols outputs
 343                  supported? deprecated?
 344                  files lines columns) ...)
 345          (fold (lambda (version* file line column result)
 346                  (if (and file
 347                           (or (not version)
 348                               (version-prefix? version version*)))
 349                      (alist-cons version* (location file line column)
 350                                  result)
 351                      result))
 352                '()
 353                versions files lines columns)))
 354       (map (lambda (package)
 355              (cons (package-version package) (package-location package)))
 356            (find-packages-by-name/direct name version))))
 357
 358 (define (find-best-packages-by-name name version)
 359   "If version is #f, return the list of packages named NAME with the highest
 360 version numbers; otherwise, return the list of packages named NAME and at
 361 VERSION."
 362   (if version
 363       (find-packages-by-name name version)
 364       (match (find-packages-by-name name)
 365         (()
 366          '())
 367         ((matches ...)
 368          ;; Return the subset of MATCHES with the higher version number.
 369          (let ((highest (package-version (first matches))))
 370            (take-while (lambda (p)
 371                          (string=? (package-version p) highest))
 372                        matches))))))
 373
 374 ;; Prevent Guile 3 from inlining this procedure so we can mock it in tests.
 375 (set! find-best-packages-by-name find-best-packages-by-name)
 376
 377 (define (generate-package-cache directory)
 378   "Generate under DIRECTORY a cache of all the available packages.
 379
 380 The primary purpose of the cache is to speed up package lookup by name such
 381 that we don't have to traverse and load all the package modules, thereby also
 382 reducing the memory footprint."
 383   (define cache-file
 384     (string-append directory %package-cache-file))
 385
 386   (define expand-cache
 387     (match-lambda*
 388       (((module symbol variable) (result . seen))
 389        (let ((package (variable-ref variable)))
 390          (if (or (vhash-assq package seen)
 391                  (hidden-package? package))
 392              (cons result seen)
 393              (cons (cons `#(,(package-name package)
 394                             ,(package-version package)
 395                             ,(module-name module)
 396                             ,symbol
 397                             ,(package-outputs package)
 398                             ,(->bool (supported-package? package))
 399                             ,(->bool (package-superseded package))
 400                             ,@(let ((loc (package-location package)))
 401                                 (if loc
 402                                     `(,(location-file loc)
 403                                       ,(location-line loc)
 404                                       ,(location-column loc))
 405                                     '(#f #f #f))))
 406                          result)
 407                    (vhash-consq package #t seen)))))))
 408
 409   (define entry-key
 410     (match-lambda
 411       ((module symbol variable)
 412        (let ((value (variable-ref variable)))
 413          (string-append (package-name value) (package-version value)
 414                         (object->string module)
 415                         (symbol->string symbol))))))
 416
 417   (define (entry<? a b)
 418     (string<? (entry-key a) (entry-key b)))
 419
 420   (define variables
 421     ;; First sort variables so that 'expand-cache' later dismisses
 422     ;; already-seen package objects in a deterministic fashion.
 423     (sort
 424      (fold-module-public-variables* (lambda (module symbol variable lst)
 425                                       (let ((value (false-if-exception
 426                                                     (variable-ref variable))))
 427                                         (if (package? value)
 428                                             (cons (list module symbol variable)
 429                                                   lst)
 430                                             lst)))
 431                                     '()
 432                                     (all-modules (%package-module-path)
 433                                                  #:warn
 434                                                  warn-about-load-error))
 435      entry<?))
 436
 437   (define exp
 438     (first (fold expand-cache (cons '() vlist-null) variables)))
 439
 440   (mkdir-p (dirname cache-file))
 441   (call-with-output-file cache-file
 442     (lambda (port)
 443       ;; Store the cache as a '.go' file.  This makes loading fast and reduces
 444       ;; heap usage since some of the static data is directly mmapped.
 445       (put-bytevector port
 446                       (compile `'(,@exp)
 447                                #:to 'bytecode
 448                                #:opts '(#:to-file? #t)))))
 449   cache-file)
 450
 451 \f
 452 (define %sigint-prompt
 453   ;; The prompt to jump to upon SIGINT.
 454   (make-prompt-tag "interruptible"))
 455
 456 (define (call-with-sigint-handler thunk handler)
 457   "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
 458 number in the context of the continuation of the call to this function, and
 459 return its return value."
 460   (call-with-prompt %sigint-prompt
 461                     (lambda ()
 462                       (sigaction SIGINT
 463                         (lambda (signum)
 464                           (sigaction SIGINT SIG_DFL)
 465                           (abort-to-prompt %sigint-prompt signum)))
 466                       (dynamic-wind
 467                         (const #t)
 468                         thunk
 469                         (cut sigaction SIGINT SIG_DFL)))
 470                     (lambda (k signum)
 471                       (handler signum))))
 472
 473 \f
 474 ;;;
 475 ;;; Package specification.
 476 ;;;
 477
 478 (define* (%find-package spec name version)
 479   (match (find-best-packages-by-name name version)
 480     ((pkg . pkg*)
 481      (unless (null? pkg*)
 482        (warning (G_ "ambiguous package specification `~a'~%") spec)
 483        (warning (G_ "choosing ~a@~a from ~a~%")
 484                 (package-name pkg) (package-version pkg)
 485                 (location->string (package-location pkg))))
 486      (match (package-superseded pkg)
 487        ((? package? new)
 488         (info (G_ "package '~a' has been superseded by '~a'~%")
 489               (package-name pkg) (package-name new))
 490         new)
 491        (#f
 492         pkg)))
 493     (x
 494      (if version
 495          (leave (G_ "~A: package not found for version ~a~%") name version)
 496          (leave (G_ "~A: unknown package~%") name)))))
 497
 498 (define (specification->package spec)
 499   "Return a package matching SPEC.  SPEC may be a package name, or a package
 500 name followed by an at-sign and a version number.  If the version number is not
 501 present, return the preferred newest version."
 502   (let ((name version (package-name->name+version spec)))
 503     (%find-package spec name version)))
 504
 505 (define (specification->location spec)
 506   "Return the location of the highest-numbered package matching SPEC, a
 507 specification such as \"guile@2\" or \"emacs\"."
 508   (let ((name version (package-name->name+version spec)))
 509     (match (find-package-locations name version)
 510       (()
 511        (if version
 512            (leave (G_ "~A: package not found for version ~a~%") name version)
 513            (leave (G_ "~A: unknown package~%") name)))
 514       (lst
 515        (let* ((highest   (match lst (((version . _) _ ...) version)))
 516               (locations (take-while (match-lambda
 517                                        ((version . location)
 518                                         (string=? version highest)))
 519                                      lst)))
 520          (match locations
 521            (((version . location) . rest)
 522             (unless (null? rest)
 523               (warning (G_ "ambiguous package specification `~a'~%") spec)
 524               (warning (G_ "choosing ~a@~a from ~a~%")
 525                        name version
 526                        (location->string location)))
 527             location)))))))
 528
 529 (define* (specification->package+output spec #:optional (output "out"))
 530   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 531 optionally contain a version number and an output name, as in these examples:
 532
 533   guile
 534   guile@2.0.9
 535   guile:debug
 536   guile@2.0.9:debug
 537
 538 If SPEC does not specify a version number, return the preferred newest
 539 version; if SPEC does not specify an output, return OUTPUT.
 540
 541 When OUTPUT is false and SPEC does not specify any output, return #f as the
 542 output."
 543   (let ((name version sub-drv
 544               (package-specification->name+version+output spec output)))
 545     (match (%find-package spec name version)
 546       (#f
 547        (values #f #f))
 548       (package
 549        (if (or (and (not output) (not sub-drv))
 550                (member sub-drv (package-outputs package)))
 551            (values package sub-drv)
 552            (leave (G_ "package `~a' lacks output `~a'~%")
 553                   (package-full-name package)
 554                   sub-drv))))))
 555
 556 (define (specifications->packages specs)
 557   "Given SPECS, a list of specifications such as \"emacs@25.2\" or
 558 \"guile:debug\", return a list of package/output tuples."
 559   ;; This procedure exists so users of 'guix home' don't have to write out the
 560   ;; (map (compose list specification->package+output)... boilerplate.
 561   (map (compose list specification->package+output) specs))
 562
 563 (define (specifications->manifest specs)
 564   "Given SPECS, a list of specifications such as \"emacs@25.2\" or
 565 \"guile:debug\", return a profile manifest."
 566   ;; This procedure exists mostly so users of 'guix package -m' don't have to
 567   ;; fiddle with multiple-value returns.
 568   (packages->manifest
 569    (specifications->packages specs)))
 570
 571 (define (package-unique-version-prefix name version)
 572   "Search among all the versions of package NAME that are available, and
 573 return the shortest unambiguous version prefix to designate VERSION.  If only
 574 one version of the package is available, return the empty string."
 575   (match (map package-version (find-packages-by-name name))
 576     ((_)
 577      ;; A single version of NAME is available, so do not specify the version
 578      ;; number, even if the available version doesn't match VERSION.
 579      "")
 580     (versions
 581      ;; If VERSION is the latest version, don't specify any version.
 582      ;; Otherwise return the shortest unique version prefix.  Note that this
 583      ;; is based on the currently available packages so the result may vary
 584      ;; over time.
 585      (if (every (cut version>? version <>)
 586                 (delete version versions))
 587          ""
 588          (version-unique-prefix version versions)))))