604 lines
22 KiB
Scheme
604 lines
22 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; Information about packages and generations is passed to the elisp
|
||
;; side in the form of alists of parameters (such as ‘name’ or
|
||
;; ‘version’) and their values. These alists are called "entries" in
|
||
;; this code. So to distinguish, just "package" in the name of a
|
||
;; function means a guile object ("package" record) while
|
||
;; "package entry" means alist of package parameters and values (see
|
||
;; ‘package-param-alist’).
|
||
;;
|
||
;; "Entry" is probably not the best name for such alists, because there
|
||
;; already exists "manifest-entry" which has nothing to do with the
|
||
;; "entry" described above. Do not be confused :)
|
||
|
||
;; ‘get-entries’ function is the “entry point” for the elisp side to get
|
||
;; information about packages and generations.
|
||
|
||
;; Since name/version pair is not necessarily unique, we use
|
||
;; `object-address' to identify a package (for ‘id’ parameter), if
|
||
;; possible. However for the obsolete packages (that can be found in
|
||
;; installed manifest but not in a package directory), ‘id’ parameter is
|
||
;; still "name-version" string. So ‘id’ package parameter in the code
|
||
;; below is either an object-address number or a full-name string.
|
||
;;
|
||
;; Important: as object addresses live only during guile session, elisp
|
||
;; part should take care about updating information after "Guix REPL" is
|
||
;; restarted (TODO!)
|
||
;;
|
||
;; ‘installed’ parameter of a package entry contains information about
|
||
;; installed outputs. It is a list of "installed entries" (see
|
||
;; ‘package-installed-param-alist’).
|
||
|
||
;; To speed-up the process of getting information, the following
|
||
;; auxiliary variables are used:
|
||
;;
|
||
;; - `%packages' - VHash of "package address"/"package" pairs.
|
||
;;
|
||
;; - `%package-table' - Hash table of
|
||
;; "name+version key"/"list of packages" pairs.
|
||
;;
|
||
;; - `%current-manifest-entries-table' - Hash table of
|
||
;; "name+version key"/"list of manifest entries" pairs. This variable
|
||
;; is set by `set-current-manifest-maybe!' when it is needed.
|
||
|
||
;;; Code:
|
||
|
||
(use-modules
|
||
(ice-9 vlist)
|
||
(ice-9 match)
|
||
(srfi srfi-1)
|
||
(srfi srfi-11)
|
||
(srfi srfi-19)
|
||
(srfi srfi-26)
|
||
(guix)
|
||
(guix packages)
|
||
(guix profiles)
|
||
(guix licenses)
|
||
(guix utils)
|
||
(guix ui)
|
||
(guix scripts package)
|
||
(gnu packages))
|
||
|
||
(define-syntax-rule (first-or-false lst)
|
||
(and (not (null? lst))
|
||
(first lst)))
|
||
|
||
(define full-name->name+version package-name->name+version)
|
||
(define (name+version->full-name name version)
|
||
(string-append name "-" version))
|
||
|
||
(define* (make-package-specification name #:optional version output)
|
||
(let ((full-name (if version
|
||
(name+version->full-name name version)
|
||
name)))
|
||
(if output
|
||
(string-append full-name ":" output)
|
||
full-name)))
|
||
|
||
(define name+version->key cons)
|
||
(define key->name+version car+cdr)
|
||
|
||
(define %current-manifest #f)
|
||
(define %current-manifest-entries-table #f)
|
||
|
||
(define %packages
|
||
(fold-packages (lambda (pkg res)
|
||
(vhash-consq (object-address pkg) pkg res))
|
||
vlist-null))
|
||
|
||
(define %package-table
|
||
(let ((table (make-hash-table (vlist-length %packages))))
|
||
(vlist-for-each
|
||
(lambda (elem)
|
||
(match elem
|
||
((address . pkg)
|
||
(let* ((key (name+version->key (package-name pkg)
|
||
(package-version pkg)))
|
||
(ref (hash-ref table key)))
|
||
(hash-set! table key
|
||
(if ref (cons pkg ref) (list pkg)))))))
|
||
%packages)
|
||
table))
|
||
|
||
;; FIXME get rid of this function!
|
||
(define (set-current-manifest-maybe! profile)
|
||
(define (manifest-entries->hash-table entries)
|
||
(let ((entries-table (make-hash-table (length entries))))
|
||
(for-each (lambda (entry)
|
||
(let* ((key (name+version->key
|
||
(manifest-entry-name entry)
|
||
(manifest-entry-version entry)))
|
||
(ref (hash-ref entries-table key)))
|
||
(hash-set! entries-table key
|
||
(if ref (cons entry ref) (list entry)))))
|
||
entries)
|
||
entries-table))
|
||
|
||
(when profile
|
||
(let ((manifest (profile-manifest profile)))
|
||
(unless (and (manifest? %current-manifest)
|
||
(equal? manifest %current-manifest))
|
||
(set! %current-manifest manifest)
|
||
(set! %current-manifest-entries-table
|
||
(manifest-entries->hash-table
|
||
(manifest-entries manifest)))))))
|
||
|
||
(define (manifest-entries-by-name+version name version)
|
||
(or (hash-ref %current-manifest-entries-table
|
||
(name+version->key name version))
|
||
'()))
|
||
|
||
(define (packages-by-name+version name version)
|
||
(or (hash-ref %package-table
|
||
(name+version->key name version))
|
||
'()))
|
||
|
||
(define (packages-by-full-name full-name)
|
||
(call-with-values
|
||
(lambda () (full-name->name+version full-name))
|
||
packages-by-name+version))
|
||
|
||
(define (package-by-address address)
|
||
(and=> (vhash-assq address %packages)
|
||
cdr))
|
||
|
||
(define (packages-by-id id)
|
||
(if (integer? id)
|
||
(let ((pkg (package-by-address id)))
|
||
(if pkg (list pkg) '()))
|
||
(packages-by-full-name id)))
|
||
|
||
(define (package-by-id id)
|
||
(first-or-false (packages-by-id id)))
|
||
|
||
(define (newest-package-by-id id)
|
||
(and=> (id->name+version id)
|
||
(lambda (name)
|
||
(first-or-false (find-best-packages-by-name name #f)))))
|
||
|
||
(define (id->name+version id)
|
||
(if (integer? id)
|
||
(and=> (package-by-address id)
|
||
(lambda (pkg)
|
||
(values (package-name pkg)
|
||
(package-version pkg))))
|
||
(full-name->name+version id)))
|
||
|
||
(define (fold-manifest-entries proc init)
|
||
"Fold over `%current-manifest-entries-table'.
|
||
Call (PROC NAME VERSION ENTRIES RESULT) for each element of the hash
|
||
table, using INIT as the initial value of RESULT."
|
||
(hash-fold (lambda (key entries res)
|
||
(let-values (((name version) (key->name+version key)))
|
||
(proc name version entries res)))
|
||
init
|
||
%current-manifest-entries-table))
|
||
|
||
(define (fold-object proc init obj)
|
||
(fold proc init
|
||
(if (list? obj) obj (list obj))))
|
||
|
||
(define* (object-transformer param-alist #:optional (params '()))
|
||
"Return function for transforming an object into alist of parameters/values.
|
||
|
||
PARAM-ALIST is alist of available object parameters (symbols) and functions
|
||
returning values of these parameters. Each function is called with object as
|
||
a single argument.
|
||
|
||
PARAMS is list of parameters from PARAM-ALIST that should be returned by a
|
||
resulting function. If PARAMS is not specified or is an empty list, use all
|
||
available parameters.
|
||
|
||
Example:
|
||
|
||
(let ((alist `((plus1 . ,1+) (minus1 . ,1-) (mul2 . ,(cut * 2 <>))))
|
||
(number->alist (object-transformer alist '(plus1 mul2))))
|
||
(number->alist 8))
|
||
=>
|
||
((plus1 . 9) (mul2 . 16))
|
||
"
|
||
(let ((alist (let ((use-all-params (null? params)))
|
||
(filter-map (match-lambda
|
||
((param . fun)
|
||
(and (or use-all-params
|
||
(memq param params))
|
||
(cons param fun)))
|
||
(_ #f))
|
||
param-alist))))
|
||
(lambda (object)
|
||
(map (match-lambda
|
||
((param . fun)
|
||
(cons param (fun object))))
|
||
alist))))
|
||
|
||
(define package-installed-param-alist
|
||
(list
|
||
(cons 'output manifest-entry-output)
|
||
(cons 'path manifest-entry-item)
|
||
(cons 'dependencies manifest-entry-dependencies)))
|
||
|
||
(define manifest-entry->installed-entry
|
||
(object-transformer package-installed-param-alist))
|
||
|
||
(define (manifest-entries->installed-entries entries)
|
||
(map manifest-entry->installed-entry entries))
|
||
|
||
(define (installed-entries-by-name+version name version)
|
||
(manifest-entries->installed-entries
|
||
(manifest-entries-by-name+version name version)))
|
||
|
||
(define (installed-entries-by-package package)
|
||
(installed-entries-by-name+version (package-name package)
|
||
(package-version package)))
|
||
|
||
(define (package-inputs-names inputs)
|
||
"Return list of full names of the packages from package INPUTS."
|
||
(filter-map (match-lambda
|
||
((_ (? package? package))
|
||
(package-full-name package))
|
||
(_ #f))
|
||
inputs))
|
||
|
||
(define (package-license-names package)
|
||
"Return list of license names of the PACKAGE."
|
||
(fold-object (lambda (license res)
|
||
(if (license? license)
|
||
(cons (license-name license) res)
|
||
res))
|
||
'()
|
||
(package-license package)))
|
||
|
||
(define (package-unique? package)
|
||
"Return #t if PACKAGE is a single package with such name/version."
|
||
(null? (cdr (packages-by-name+version (package-name package)
|
||
(package-version package)))))
|
||
|
||
(define package-param-alist
|
||
(list
|
||
(cons 'id object-address)
|
||
(cons 'name package-name)
|
||
(cons 'version package-version)
|
||
(cons 'license package-license-names)
|
||
(cons 'synopsis package-synopsis)
|
||
(cons 'description package-description)
|
||
(cons 'home-url package-home-page)
|
||
(cons 'outputs package-outputs)
|
||
(cons 'non-unique (negate package-unique?))
|
||
(cons 'inputs (lambda (pkg) (package-inputs-names
|
||
(package-inputs pkg))))
|
||
(cons 'native-inputs (lambda (pkg) (package-inputs-names
|
||
(package-native-inputs pkg))))
|
||
(cons 'propagated-inputs (lambda (pkg) (package-inputs-names
|
||
(package-propagated-inputs pkg))))
|
||
(cons 'location (lambda (pkg) (location->string
|
||
(package-location pkg))))
|
||
(cons 'installed installed-entries-by-package)))
|
||
|
||
(define (package-param package param)
|
||
"Return the value of a PACKAGE PARAM."
|
||
(define (accessor param)
|
||
(and=> (assq param package-param-alist)
|
||
cdr))
|
||
(and=> (accessor param)
|
||
(cut <> package)))
|
||
|
||
(define (matching-package-entries ->entry predicate)
|
||
"Return list of package entries for the matching packages.
|
||
PREDICATE is called on each package."
|
||
(fold-packages (lambda (pkg res)
|
||
(if (predicate pkg)
|
||
(cons (->entry pkg) res)
|
||
res))
|
||
'()))
|
||
|
||
(define (make-obsolete-package-entry name version entries)
|
||
"Return package entry for an obsolete package with NAME and VERSION.
|
||
ENTRIES is a list of manifest entries used to get installed info."
|
||
`((id . ,(name+version->full-name name version))
|
||
(name . ,name)
|
||
(version . ,version)
|
||
(outputs . ,(map manifest-entry-output entries))
|
||
(obsolete . #t)
|
||
(installed . ,(manifest-entries->installed-entries entries))))
|
||
|
||
(define (package-entries-by-name+version ->entry name version)
|
||
"Return list of package entries for packages with NAME and VERSION."
|
||
(let ((packages (packages-by-name+version name version)))
|
||
(if (null? packages)
|
||
(let ((entries (manifest-entries-by-name+version name version)))
|
||
(if (null? entries)
|
||
'()
|
||
(list (make-obsolete-package-entry name version entries))))
|
||
(map ->entry packages))))
|
||
|
||
(define (package-entries-by-spec profile ->entry spec)
|
||
"Return list of package entries for packages with name specification SPEC."
|
||
(set-current-manifest-maybe! profile)
|
||
(let-values (((name version)
|
||
(full-name->name+version spec)))
|
||
(if version
|
||
(package-entries-by-name+version ->entry name version)
|
||
(matching-package-entries
|
||
->entry
|
||
(lambda (pkg) (string=? name (package-name pkg)))))))
|
||
|
||
(define (package-entries-by-regexp profile ->entry regexp match-params)
|
||
"Return list of package entries for packages matching REGEXP string.
|
||
MATCH-PARAMS is a list of parameters that REGEXP can match."
|
||
(define (package-match? package regexp)
|
||
(any (lambda (param)
|
||
(let ((val (package-param package param)))
|
||
(and (string? val) (regexp-exec regexp val))))
|
||
match-params))
|
||
|
||
(set-current-manifest-maybe! profile)
|
||
(let ((re (make-regexp regexp regexp/icase)))
|
||
(matching-package-entries ->entry (cut package-match? <> re))))
|
||
|
||
(define (package-entries-by-ids profile ->entry ids)
|
||
"Return list of package entries for packages matching KEYS.
|
||
IDS may be an object-address, a full-name or a list of such elements."
|
||
(set-current-manifest-maybe! profile)
|
||
(fold-object
|
||
(lambda (id res)
|
||
(if (integer? id)
|
||
(let ((pkg (package-by-address id)))
|
||
(if pkg
|
||
(cons (->entry pkg) res)
|
||
res))
|
||
(let ((entries (package-entries-by-spec #f ->entry id)))
|
||
(if (null? entries)
|
||
res
|
||
(append res entries)))))
|
||
'()
|
||
ids))
|
||
|
||
(define (newest-available-package-entries profile ->entry)
|
||
"Return list of package entries for the newest available packages."
|
||
(set-current-manifest-maybe! profile)
|
||
(vhash-fold (lambda (name elem res)
|
||
(match elem
|
||
((version newest pkgs ...)
|
||
(cons (->entry newest) res))))
|
||
'()
|
||
(find-newest-available-packages)))
|
||
|
||
(define (all-available-package-entries profile ->entry)
|
||
"Return list of package entries for all available packages."
|
||
(set-current-manifest-maybe! profile)
|
||
(matching-package-entries ->entry (const #t)))
|
||
|
||
(define (manifest-package-entries ->entry)
|
||
"Return list of package entries for the current manifest."
|
||
(fold-manifest-entries
|
||
(lambda (name version entries res)
|
||
;; We don't care about duplicates for the list of
|
||
;; installed packages, so just take any package (car)
|
||
;; matching name+version
|
||
(cons (car (package-entries-by-name+version ->entry name version))
|
||
res))
|
||
'()))
|
||
|
||
(define (installed-package-entries profile ->entry)
|
||
"Return list of package entries for all installed packages."
|
||
(set-current-manifest-maybe! profile)
|
||
(manifest-package-entries ->entry))
|
||
|
||
(define (generation-package-entries profile ->entry generation)
|
||
"Return list of package entries for packages from GENERATION."
|
||
(set-current-manifest-maybe!
|
||
(generation-file-name profile generation))
|
||
(manifest-package-entries ->entry))
|
||
|
||
(define (obsolete-package-entries profile _)
|
||
"Return list of package entries for obsolete packages."
|
||
(set-current-manifest-maybe! profile)
|
||
(fold-manifest-entries
|
||
(lambda (name version entries res)
|
||
(let ((packages (packages-by-name+version name version)))
|
||
(if (null? packages)
|
||
(cons (make-obsolete-package-entry name version entries) res)
|
||
res)))
|
||
'()))
|
||
|
||
|
||
;;; Generation entries
|
||
|
||
(define (profile-generations profile)
|
||
"Return list of generations for PROFILE."
|
||
(let ((generations (generation-numbers profile)))
|
||
(if (equal? generations '(0))
|
||
'()
|
||
generations)))
|
||
|
||
(define (generation-param-alist profile)
|
||
"Return alist of generation parameters and functions for PROFILE."
|
||
(list
|
||
(cons 'id identity)
|
||
(cons 'number identity)
|
||
(cons 'prev-number (cut previous-generation-number profile <>))
|
||
(cons 'path (cut generation-file-name profile <>))
|
||
(cons 'time (lambda (gen)
|
||
(time-second (generation-time profile gen))))))
|
||
|
||
(define (matching-generation-entries profile ->entry predicate)
|
||
"Return list of generation entries for the matching generations.
|
||
PREDICATE is called on each generation."
|
||
(filter-map (lambda (gen)
|
||
(and (predicate gen) (->entry gen)))
|
||
(profile-generations profile)))
|
||
|
||
(define (last-generation-entries profile ->entry number)
|
||
"Return list of last NUMBER generation entries.
|
||
If NUMBER is 0 or less, return all generation entries."
|
||
(let ((generations (profile-generations profile))
|
||
(number (if (<= number 0) +inf.0 number)))
|
||
(map ->entry
|
||
(if (> (length generations) number)
|
||
(list-head (reverse generations) number)
|
||
generations))))
|
||
|
||
(define (all-generation-entries profile ->entry)
|
||
"Return list of all generation entries."
|
||
(last-generation-entries profile ->entry +inf.0))
|
||
|
||
(define (generation-entries-by-ids profile ->entry ids)
|
||
"Return list of generation entries for generations matching IDS.
|
||
IDS is a list of generation numbers."
|
||
(matching-generation-entries profile ->entry (cut memq <> ids)))
|
||
|
||
|
||
;;; Getting package/generation entries
|
||
|
||
(define %package-entries-functions
|
||
(alist->vhash
|
||
`((id . ,package-entries-by-ids)
|
||
(name . ,package-entries-by-spec)
|
||
(regexp . ,package-entries-by-regexp)
|
||
(all-available . ,all-available-package-entries)
|
||
(newest-available . ,newest-available-package-entries)
|
||
(installed . ,installed-package-entries)
|
||
(obsolete . ,obsolete-package-entries)
|
||
(generation . ,generation-package-entries))
|
||
hashq))
|
||
|
||
(define %generation-entries-functions
|
||
(alist->vhash
|
||
`((id . ,generation-entries-by-ids)
|
||
(last . ,last-generation-entries)
|
||
(all . ,all-generation-entries))
|
||
hashq))
|
||
|
||
(define (get-entries profile params entry-type search-type search-vals)
|
||
"Return list of entries.
|
||
ENTRY-TYPE and SEARCH-TYPE define a search function that should be
|
||
applied to PARAMS and VALS."
|
||
(let-values (((vhash ->entry)
|
||
(case entry-type
|
||
((package)
|
||
(values %package-entries-functions
|
||
(object-transformer
|
||
package-param-alist params)))
|
||
((generation)
|
||
(values %generation-entries-functions
|
||
(object-transformer
|
||
(generation-param-alist profile) params)))
|
||
(else (format (current-error-port)
|
||
"Wrong entry type '~a'" entry-type)))))
|
||
(match (vhash-assq search-type vhash)
|
||
((key . fun)
|
||
(apply fun profile ->entry search-vals))
|
||
(_ '()))))
|
||
|
||
|
||
;;; Actions
|
||
|
||
(define* (package->manifest-entry* package #:optional output)
|
||
(and package
|
||
(begin
|
||
(check-package-freshness package)
|
||
(package->manifest-entry package output))))
|
||
|
||
(define* (make-install-manifest-entries id #:optional output)
|
||
(package->manifest-entry* (package-by-id id) output))
|
||
|
||
(define* (make-upgrade-manifest-entries id #:optional output)
|
||
(package->manifest-entry* (newest-package-by-id id) output))
|
||
|
||
(define* (make-manifest-pattern id #:optional output)
|
||
"Make manifest pattern from a package ID and OUTPUT."
|
||
(let-values (((name version)
|
||
(id->name+version id)))
|
||
(and name version
|
||
(manifest-pattern
|
||
(name name)
|
||
(version version)
|
||
(output output)))))
|
||
|
||
(define (convert-action-pattern pattern proc)
|
||
"Convert action PATTERN into a list of objects returned by PROC.
|
||
PROC is called: (PROC ID) or (PROC ID OUTPUT)."
|
||
(match pattern
|
||
((id . outputs)
|
||
(if (null? outputs)
|
||
(let ((obj (proc id)))
|
||
(if obj (list obj) '()))
|
||
(filter-map (cut proc id <>)
|
||
outputs)))
|
||
(_ '())))
|
||
|
||
(define (convert-action-patterns patterns proc)
|
||
(append-map (cut convert-action-pattern <> proc)
|
||
patterns))
|
||
|
||
(define* (process-package-actions
|
||
profile #:key (install '()) (upgrade '()) (remove '())
|
||
(use-substitutes? #t) dry-run?)
|
||
"Perform package actions.
|
||
|
||
INSTALL, UPGRADE, REMOVE are lists of 'package action patterns'.
|
||
Each pattern should have the following form:
|
||
|
||
(ID . OUTPUTS)
|
||
|
||
ID is an object address or a full-name of a package.
|
||
OUTPUTS is a list of package outputs (may be an empty list)."
|
||
(format #t "The process begins ...~%")
|
||
(let* ((install (append
|
||
(convert-action-patterns
|
||
install make-install-manifest-entries)
|
||
(convert-action-patterns
|
||
upgrade make-upgrade-manifest-entries)))
|
||
(remove (convert-action-patterns remove make-manifest-pattern))
|
||
(transaction (manifest-transaction (install install)
|
||
(remove remove)))
|
||
(manifest (profile-manifest profile))
|
||
(new-manifest (manifest-perform-transaction
|
||
manifest transaction)))
|
||
(unless (and (null? install) (null? remove))
|
||
(let* ((store (open-connection))
|
||
(derivation (run-with-store
|
||
store (profile-derivation new-manifest)))
|
||
(derivations (list derivation))
|
||
(new-profile (derivation->output-path derivation)))
|
||
(set-build-options store
|
||
#:use-substitutes? use-substitutes?)
|
||
(manifest-show-transaction store manifest transaction
|
||
#:dry-run? dry-run?)
|
||
(show-what-to-build store derivations
|
||
#:use-substitutes? use-substitutes?
|
||
#:dry-run? dry-run?)
|
||
(unless dry-run?
|
||
(let ((name (generation-file-name
|
||
profile
|
||
(+ 1 (generation-number profile)))))
|
||
(and (build-derivations store derivations)
|
||
(let* ((entries (manifest-entries new-manifest))
|
||
(count (length entries)))
|
||
(switch-symlinks name new-profile)
|
||
(switch-symlinks profile name)
|
||
(format #t (N_ "~a package in profile~%"
|
||
"~a packages in profile~%"
|
||
count)
|
||
count)))))))))
|
||
|