gnu/packages.scm

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