+++ /dev/null
-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 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.
-
-;; ‘entries’ procedure 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.
-
-;;; Code:
-
-(use-modules
- (ice-9 vlist)
- (ice-9 match)
- (ice-9 popen)
- (srfi srfi-1)
- (srfi srfi-2)
- (srfi srfi-11)
- (srfi srfi-19)
- (srfi srfi-26)
- (guix)
- (guix combinators)
- (guix git-download)
- (guix grafts)
- (guix packages)
- (guix profiles)
- (guix licenses)
- (guix utils)
- (guix ui)
- (guix scripts)
- (guix scripts package)
- (gnu packages)
- (gnu system))
-
-(define-syntax-rule (first-or-false lst)
- (and (not (null? lst))
- (first lst)))
-
-(define (list-maybe obj)
- (if (list? obj) obj (list obj)))
-
-(define (output+error thunk)
- "Call THUNK and return 2 values: output and error output as strings."
- (let ((output-port (open-output-string))
- (error-port (open-output-string)))
- (with-output-to-port output-port
- (lambda () (with-error-to-port error-port thunk)))
- (let ((strings (list (get-output-string output-port)
- (get-output-string error-port))))
- (close-output-port output-port)
- (close-output-port error-port)
- (apply values strings))))
-
-(define (full-name->name+version spec)
- "Given package specification SPEC with or without output,
-return two values: name and version. For example, for SPEC
-\"foo@0.9.1b:lib\", return \"foo\" and \"0.9.1b\"."
- (let-values (((name version output)
- (package-specification->name+version+output spec)))
- (values 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 (manifest-entry->name+version+output entry)
- (values
- (manifest-entry-name entry)
- (manifest-entry-version entry)
- (manifest-entry-output entry)))
-
-(define (manifest-entry->package-specification entry)
- (call-with-values
- (lambda () (manifest-entry->name+version+output entry))
- make-package-specification))
-
-(define (manifest-entries->package-specifications entries)
- (map manifest-entry->package-specification entries))
-
-(define (profile-package-specifications profile)
- "Return a list of package specifications for PROFILE."
- (let ((manifest (profile-manifest profile)))
- (manifest-entries->package-specifications
- (manifest-entries manifest))))
-
-(define (profile->specifications+paths profile)
- "Return a list of package specifications and paths for PROFILE.
-Each element of the list is a list of the package specification and its path."
- (let ((manifest (profile-manifest profile)))
- (map (lambda (entry)
- (list (manifest-entry->package-specification entry)
- (manifest-entry-item entry)))
- (manifest-entries manifest))))
-
-(define (profile-difference profile1 profile2)
- "Return a list of package specifications for outputs installed in PROFILE1
-and not installed in PROFILE2."
- (let ((specs1 (profile-package-specifications profile1))
- (specs2 (profile-package-specifications profile2)))
- (lset-difference string=? specs1 specs2)))
-
-(define (manifest-entries->hash-table entries)
- "Return a hash table of name keys and lists of matching manifest ENTRIES."
- (let ((table (make-hash-table (length entries))))
- (for-each (lambda (entry)
- (let* ((key (manifest-entry-name entry))
- (ref (hash-ref table key)))
- (hash-set! table key
- (if ref (cons entry ref) (list entry)))))
- entries)
- table))
-
-(define (manifest=? m1 m2)
- (or (eq? m1 m2)
- (equal? m1 m2)))
-
-(define manifest->hash-table
- (let ((current-manifest #f)
- (current-table #f))
- (lambda (manifest)
- "Return a hash table of name keys and matching MANIFEST entries."
- (unless (manifest=? manifest current-manifest)
- (set! current-manifest manifest)
- (set! current-table (manifest-entries->hash-table
- (manifest-entries manifest))))
- current-table)))
-
-(define* (manifest-entries-by-name manifest name #:optional version output)
- "Return a list of MANIFEST entries matching NAME, VERSION and OUTPUT."
- (let ((entries (or (hash-ref (manifest->hash-table manifest) name)
- '())))
- (if (or version output)
- (filter (lambda (entry)
- (and (or (not version)
- (equal? version (manifest-entry-version entry)))
- (or (not output)
- (equal? output (manifest-entry-output entry)))))
- entries)
- entries)))
-
-(define (manifest-entry-by-output entries output)
- "Return a manifest entry from ENTRIES matching OUTPUT."
- (find (lambda (entry)
- (string= output (manifest-entry-output entry)))
- entries))
-
-(define (fold-manifest-by-name manifest proc init)
- "Fold over MANIFEST entries.
-Call (PROC NAME VERSION ENTRIES RESULT), using INIT as the initial value
-of RESULT. ENTRIES is a list of manifest entries with NAME/VERSION."
- (hash-fold (lambda (name entries res)
- (proc name (manifest-entry-version (car entries))
- entries res))
- init
- (manifest->hash-table manifest)))
-
-(define* (object-transformer param-alist #:optional (params '()))
- "Return procedure transforming objects into alist of parameter/value pairs.
-
-PARAM-ALIST is alist of available parameters (symbols) and procedures
-returning values of these parameters. Each procedure is applied to
-objects.
-
-PARAMS is list of parameters from PARAM-ALIST that should be returned by
-a resulting procedure. 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* ((use-all-params (null? params))
- (alist (filter-map (match-lambda
- ((param . proc)
- (and (or use-all-params
- (memq param params))
- (cons param proc)))
- (_ #f))
- param-alist)))
- (lambda objects
- (map (match-lambda
- ((param . proc)
- (cons param (apply proc objects))))
- alist))))
-
-(define %manifest-entry-param-alist
- `((output . ,manifest-entry-output)
- (path . ,manifest-entry-item)
- (dependencies . ,manifest-entry-dependencies)))
-
-(define manifest-entry->sexp
- (object-transformer %manifest-entry-param-alist))
-
-(define (manifest-entries->sexps entries)
- (map manifest-entry->sexp entries))
-
-(define (package-inputs-names inputs)
- "Return a list of full names of the packages from package INPUTS."
- (filter-map (match-lambda
- ((_ (? package? package))
- (make-package-specification (package-name package)
- (package-version package)))
- ((_ (? package? package) output)
- (make-package-specification (package-name package)
- (package-version package)
- output))
- (_ #f))
- inputs))
-
-(define (package-license-names package)
- "Return a list of license names of the PACKAGE."
- (filter-map (lambda (license)
- (and (license? license)
- (license-name license)))
- (list-maybe (package-license package))))
-
-(define (package-source-names package)
- "Return a list of source names (URLs) of the PACKAGE."
- (let ((source (package-source package)))
- (and (origin? source)
- (filter-map (lambda (uri)
- (cond ((string? uri)
- uri)
- ((git-reference? uri)
- (git-reference-url uri))
- (else "Unknown source type")))
- (list-maybe (origin-uri source))))))
-
-(define (package-unique? package)
- "Return #t if PACKAGE is a single package with such name/version."
- (match (packages-by-name (package-name package)
- (package-version package))
- ((package) #t)
- (_ #f)))
-
-(define %package-param-alist
- `((id . ,object-address)
- (package-id . ,object-address)
- (name . ,package-name)
- (version . ,package-version)
- (license . ,package-license-names)
- (source . ,package-source-names)
- (synopsis . ,package-synopsis)
- (description . ,package-description-string)
- (home-url . ,package-home-page)
- (outputs . ,package-outputs)
- (systems . ,package-supported-systems)
- (non-unique . ,(negate package-unique?))
- (inputs . ,(lambda (pkg)
- (package-inputs-names
- (package-inputs pkg))))
- (native-inputs . ,(lambda (pkg)
- (package-inputs-names
- (package-native-inputs pkg))))
- (propagated-inputs . ,(lambda (pkg)
- (package-inputs-names
- (package-propagated-inputs pkg))))
- (location . ,(lambda (pkg)
- (location->string (package-location pkg))))))
-
-(define (package-param package param)
- "Return a value of a PACKAGE PARAM."
- (and=> (assq-ref %package-param-alist param)
- (cut <> package)))
-
-\f
-;;; Finding packages.
-
-(define-values (package-by-address
- register-package)
- (let ((table (delay (fold-packages
- (lambda (package table)
- (vhash-consq (object-address package)
- package table))
- vlist-null))))
- (values
- (lambda (address)
- "Return package by its object ADDRESS."
- (match (vhash-assq address (force table))
- ((_ . package) package)
- (_ #f)))
- (lambda (package)
- "Register PACKAGE by its 'object-address', so that later
-'package-by-address' can be used to access it."
- (let ((table* (force table)))
- (set! table
- (delay (vhash-consq (object-address package)
- package table*))))))))
-
-(define packages-by-name+version
- (let ((table (delay (fold-packages
- (lambda (package table)
- (let ((file (location-file
- (package-location package))))
- (vhash-cons (cons (package-name package)
- (package-version package))
- package table)))
- vlist-null))))
- (lambda (name version)
- "Return packages matching NAME and VERSION."
- (vhash-fold* cons '() (cons name version) (force table)))))
-
-(define (packages-by-full-name full-name)
- (call-with-values
- (lambda () (full-name->name+version full-name))
- packages-by-name+version))
-
-(define (packages-by-id id)
- (if (integer? id)
- (let ((pkg (package-by-address id)))
- (if pkg (list pkg) '()))
- (packages-by-full-name id)))
-
-(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 (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 (matching-packages predicate)
- (fold-packages (lambda (pkg res)
- (if (predicate pkg)
- (cons pkg res)
- res))
- '()))
-
-(define (filter-packages-by-output packages output)
- (filter (lambda (package)
- (member output (package-outputs package)))
- packages))
-
-(define* (packages-by-name name #:optional version output)
- "Return a list of packages matching NAME, VERSION and OUTPUT."
- (let ((packages (if version
- (packages-by-name+version name version)
- (matching-packages
- (lambda (pkg) (string=? name (package-name pkg)))))))
- (if output
- (filter-packages-by-output packages output)
- packages)))
-
-(define (manifest-entry->packages entry)
- (call-with-values
- (lambda () (manifest-entry->name+version+output entry))
- packages-by-name))
-
-(define (packages-by-regexp regexp match-params)
- "Return a list of 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))
-
- (let ((re (make-regexp regexp regexp/icase)))
- (matching-packages (cut package-match? <> re))))
-
-(define (packages-by-license license)
- "Return a list of packages with LICENSE."
- (matching-packages
- (lambda (package)
- (memq license (list-maybe (package-license package))))))
-
-(define (all-available-packages)
- "Return a list of all available packages."
- (matching-packages (const #t)))
-
-(define (newest-available-packages)
- "Return a list of the newest available packages."
- (vhash-fold (lambda (name elem res)
- (match elem
- ((_ newest pkgs ...)
- (cons newest res))))
- '()
- (find-newest-available-packages)))
-
-(define (packages-from-file file)
- "Return a list of packages from FILE."
- (let ((package (load (canonicalize-path file))))
- (if (package? package)
- (begin
- (register-package package)
- (list package))
- '())))
-
-\f
-;;; Making package/output patterns.
-
-(define (specification->package-pattern specification)
- (call-with-values
- (lambda ()
- (full-name->name+version specification))
- list))
-
-(define (specification->output-pattern specification)
- (call-with-values
- (lambda ()
- (package-specification->name+version+output specification #f))
- list))
-
-(define (id->package-pattern id)
- (if (integer? id)
- (package-by-address id)
- (specification->package-pattern id)))
-
-(define (id->output-pattern id)
- "Return an output pattern by output ID.
-ID should be '<package-address>:<output>' or '<name>-<version>:<output>'."
- (let-values (((name version output)
- (package-specification->name+version+output id)))
- (if version
- (list name version output)
- (list (package-by-address (string->number name))
- output))))
-
-(define (specifications->package-patterns . specifications)
- (map specification->package-pattern specifications))
-
-(define (specifications->output-patterns . specifications)
- (map specification->output-pattern specifications))
-
-(define (ids->package-patterns . ids)
- (map id->package-pattern ids))
-
-(define (ids->output-patterns . ids)
- (map id->output-pattern ids))
-
-(define* (manifest-patterns-result packages res obsolete-pattern
- #:optional installed-pattern)
- "Auxiliary procedure for 'manifest-package-patterns' and
-'manifest-output-patterns'."
- (if (null? packages)
- (cons (obsolete-pattern) res)
- (if installed-pattern
- ;; We don't need duplicates for a list of installed packages,
- ;; so just take any (car) package.
- (cons (installed-pattern (car packages)) res)
- res)))
-
-(define* (manifest-package-patterns manifest #:optional obsolete-only?)
- "Return a list of package patterns for MANIFEST entries.
-If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
-for obsolete packages."
- (fold-manifest-by-name
- manifest
- (lambda (name version entries res)
- (manifest-patterns-result (packages-by-name name version)
- res
- (lambda () (list name version entries))
- (and (not obsolete-only?)
- (cut list <> entries))))
- '()))
-
-(define* (manifest-output-patterns manifest #:optional obsolete-only?)
- "Return a list of output patterns for MANIFEST entries.
-If OBSOLETE-ONLY? is #f, use all entries, otherwise make patterns only
-for obsolete packages."
- (fold (lambda (entry res)
- (manifest-patterns-result (manifest-entry->packages entry)
- res
- (lambda () entry)
- (and (not obsolete-only?)
- (cut list <> entry))))
- '()
- (manifest-entries manifest)))
-
-(define (obsolete-package-patterns manifest)
- (manifest-package-patterns manifest #t))
-
-(define (obsolete-output-patterns manifest)
- (manifest-output-patterns manifest #t))
-
-\f
-;;; Transforming package/output patterns into alists.
-
-(define (obsolete-package-sexp name version entries)
- "Return an alist with information about obsolete package.
-ENTRIES is a list of installed manifest entries."
- `((id . ,(name+version->full-name name version))
- (name . ,name)
- (version . ,version)
- (outputs . ,(map manifest-entry-output entries))
- (obsolete . #t)
- (installed . ,(manifest-entries->sexps entries))))
-
-(define (package-pattern-transformer manifest params)
- "Return 'package-pattern->package-sexps' procedure."
- (define package->sexp
- (object-transformer %package-param-alist params))
-
- (define* (sexp-by-package package #:optional
- (entries (manifest-entries-by-name
- manifest
- (package-name package)
- (package-version package))))
- (cons (cons 'installed (manifest-entries->sexps entries))
- (package->sexp package)))
-
- (define (->sexps pattern)
- (match pattern
- ((? package? package)
- (list (sexp-by-package package)))
- (((? package? package) entries)
- (list (sexp-by-package package entries)))
- ((name version entries)
- (list (obsolete-package-sexp
- name version entries)))
- ((name version)
- (let ((packages (packages-by-name name version)))
- (if (null? packages)
- (let ((entries (manifest-entries-by-name
- manifest name version)))
- (if (null? entries)
- '()
- (list (obsolete-package-sexp
- name version entries))))
- (map sexp-by-package packages))))
- (_ '())))
-
- ->sexps)
-
-(define (output-pattern-transformer manifest params)
- "Return 'output-pattern->output-sexps' procedure."
- (define package->sexp
- (object-transformer (alist-delete 'id %package-param-alist)
- params))
-
- (define manifest-entry->sexp
- (object-transformer (alist-delete 'output %manifest-entry-param-alist)
- params))
-
- (define* (output-sexp pkg-alist pkg-address output
- #:optional entry)
- (let ((entry-alist (if entry
- (manifest-entry->sexp entry)
- '()))
- (base `((id . ,(string-append
- (number->string pkg-address)
- ":" output))
- (output . ,output)
- (installed . ,(->bool entry)))))
- (append entry-alist base pkg-alist)))
-
- (define (obsolete-output-sexp entry)
- (let-values (((name version output)
- (manifest-entry->name+version+output entry)))
- (let ((base `((id . ,(make-package-specification
- name version output))
- (package-id . ,(name+version->full-name name version))
- (name . ,name)
- (version . ,version)
- (output . ,output)
- (obsolete . #t)
- (installed . #t))))
- (append (manifest-entry->sexp entry) base))))
-
- (define* (sexps-by-package package #:optional output
- (entries (manifest-entries-by-name
- manifest
- (package-name package)
- (package-version package))))
- ;; Assuming that PACKAGE has this OUTPUT.
- (let ((pkg-alist (package->sexp package))
- (address (object-address package))
- (outputs (if output
- (list output)
- (package-outputs package))))
- (map (lambda (output)
- (output-sexp pkg-alist address output
- (manifest-entry-by-output entries output)))
- outputs)))
-
- (define* (sexps-by-manifest-entry entry #:optional
- (packages (manifest-entry->packages
- entry)))
- (if (null? packages)
- (list (obsolete-output-sexp entry))
- (map (lambda (package)
- (output-sexp (package->sexp package)
- (object-address package)
- (manifest-entry-output entry)
- entry))
- packages)))
-
- (define (->sexps pattern)
- (match pattern
- ((? package? package)
- (sexps-by-package package))
- ((package (? string? output))
- (sexps-by-package package output))
- ((? manifest-entry? entry)
- (list (obsolete-output-sexp entry)))
- ((package entry)
- (sexps-by-manifest-entry entry (list package)))
- ((name version output)
- (let ((packages (packages-by-name name version output)))
- (if (null? packages)
- (let ((entries (manifest-entries-by-name
- manifest name version output)))
- (append-map (cut sexps-by-manifest-entry <>)
- entries))
- (append-map (cut sexps-by-package <> output)
- packages))))
- (_ '())))
-
- ->sexps)
-
-(define (entry-type-error entry-type)
- (error (format #f "Wrong entry-type '~a'" entry-type)))
-
-(define (search-type-error entry-type search-type)
- (error (format #f "Wrong search type '~a' for entry-type '~a'"
- search-type entry-type)))
-
-(define %pattern-transformers
- `((package . ,package-pattern-transformer)
- (output . ,output-pattern-transformer)))
-
-(define (pattern-transformer entry-type)
- (assq-ref %pattern-transformers entry-type))
-
-;; All procedures from inner alists are called with (MANIFEST . SEARCH-VALS)
-;; as arguments; see `package/output-sexps'.
-(define %patterns-makers
- (let* ((apply-to-rest (lambda (proc)
- (lambda (_ . rest) (apply proc rest))))
- (apply-to-first (lambda (proc)
- (lambda (first . _) (proc first))))
- (manifest-package-proc (apply-to-first manifest-package-patterns))
- (manifest-output-proc (apply-to-first manifest-output-patterns))
- (regexp-proc (lambda (_ regexp params . __)
- (packages-by-regexp regexp params)))
- (license-proc (lambda (_ license-name)
- (packages-by-license
- (lookup-license license-name))))
- (location-proc (lambda (_ location)
- (packages-by-location-file location)))
- (file-proc (lambda (_ file)
- (packages-from-file file)))
- (all-proc (lambda _ (all-available-packages)))
- (newest-proc (lambda _ (newest-available-packages))))
- `((package
- (id . ,(apply-to-rest ids->package-patterns))
- (name . ,(apply-to-rest specifications->package-patterns))
- (installed . ,manifest-package-proc)
- (obsolete . ,(apply-to-first obsolete-package-patterns))
- (regexp . ,regexp-proc)
- (license . ,license-proc)
- (location . ,location-proc)
- (from-file . ,file-proc)
- (all-available . ,all-proc)
- (newest-available . ,newest-proc))
- (output
- (id . ,(apply-to-rest ids->output-patterns))
- (name . ,(apply-to-rest specifications->output-patterns))
- (installed . ,manifest-output-proc)
- (obsolete . ,(apply-to-first obsolete-output-patterns))
- (regexp . ,regexp-proc)
- (license . ,license-proc)
- (location . ,location-proc)
- (from-file . ,file-proc)
- (all-available . ,all-proc)
- (newest-available . ,newest-proc)))))
-
-(define (patterns-maker entry-type search-type)
- (or (and=> (assq-ref %patterns-makers entry-type)
- (cut assq-ref <> search-type))
- (search-type-error entry-type search-type)))
-
-(define (package/output-sexps profile params entry-type
- search-type search-vals)
- "Return information about packages or package outputs.
-See 'entry-sexps' for details."
- (let* ((manifest (profile-manifest profile))
- (patterns (if (and (eq? entry-type 'output)
- (eq? search-type 'profile-diff))
- (match search-vals
- ((p1 p2)
- (map specification->output-pattern
- (profile-difference p1 p2)))
- (_ '()))
- (apply (patterns-maker entry-type search-type)
- manifest search-vals)))
- (->sexps ((pattern-transformer entry-type) manifest params)))
- (append-map ->sexps patterns)))
-
-\f
-;;; Getting information about generations.
-
-(define (generation-param-alist profile)
- "Return an alist of generation parameters and procedures for PROFILE."
- (let ((current (generation-number profile)))
- `((id . ,identity)
- (number . ,identity)
- (prev-number . ,(cut previous-generation-number profile <>))
- (current . ,(cut = current <>))
- (path . ,(cut generation-file-name profile <>))
- (time . ,(lambda (gen)
- (time-second (generation-time profile gen)))))))
-
-(define (matching-generations profile predicate)
- "Return a list of PROFILE generations matching PREDICATE."
- (filter predicate (profile-generations profile)))
-
-(define (last-generations profile number)
- "Return a list of last NUMBER generations.
-If NUMBER is 0 or less, return all generations."
- (let ((generations (profile-generations profile))
- (number (if (<= number 0) +inf.0 number)))
- (if (> (length generations) number)
- (list-head (reverse generations) number)
- generations)))
-
-(define (find-generations profile search-type search-vals)
- "Find PROFILE's generations matching SEARCH-TYPE and SEARCH-VALS."
- (case search-type
- ((id)
- (matching-generations profile (cut memq <> search-vals)))
- ((last)
- (last-generations profile (car search-vals)))
- ((all)
- (last-generations profile +inf.0))
- ((time)
- (match search-vals
- ((from to)
- (matching-generations
- profile
- (lambda (gen)
- (let ((time (time-second (generation-time profile gen))))
- (< from time to)))))
- (_ '())))
- (else (search-type-error "generation" search-type))))
-
-(define (generation-sexps profile params search-type search-vals)
- "Return information about generations.
-See 'entry-sexps' for details."
- (let ((generations (find-generations profile search-type search-vals))
- (->sexp (object-transformer (generation-param-alist profile)
- params)))
- (map ->sexp generations)))
-
-(define system-generation-boot-parameters
- (memoize
- (lambda (profile generation)
- "Return boot parameters for PROFILE's system GENERATION."
- (let* ((gen-file (generation-file-name profile generation))
- (param-file (string-append gen-file "/parameters")))
- (call-with-input-file param-file read-boot-parameters)))))
-
-(define (system-generation-param-alist profile)
- "Return an alist of system generation parameters and procedures for
-PROFILE."
- (append (generation-param-alist profile)
- `((label . ,(lambda (gen)
- (boot-parameters-label
- (system-generation-boot-parameters
- profile gen))))
- (root-device . ,(lambda (gen)
- (boot-parameters-root-device
- (system-generation-boot-parameters
- profile gen))))
- (kernel . ,(lambda (gen)
- (boot-parameters-kernel
- (system-generation-boot-parameters
- profile gen)))))))
-
-(define (system-generation-sexps profile params search-type search-vals)
- "Return an alist with information about system generations."
- (let ((generations (find-generations profile search-type search-vals))
- (->sexp (object-transformer (system-generation-param-alist profile)
- params)))
- (map ->sexp generations)))
-
-\f
-;;; Getting package/output/generation entries (alists).
-
-(define (entries profile params entry-type search-type search-vals)
- "Return information about entries.
-
-ENTRY-TYPE is a symbol defining a type of returning information. Should
-be: 'package', 'output' or 'generation'.
-
-SEARCH-TYPE and SEARCH-VALS define how to get the information.
-SEARCH-TYPE should be one of the following symbols:
-
-- If ENTRY-TYPE is 'package' or 'output':
- 'id', 'name', 'regexp', 'all-available', 'newest-available',
- 'installed', 'obsolete', 'generation'.
-
-- If ENTRY-TYPE is 'generation':
- 'id', 'last', 'all', 'time'.
-
-PARAMS is a list of parameters for receiving. If it is an empty list,
-get information with all available parameters, which are:
-
-- If ENTRY-TYPE is 'package':
- 'id', 'name', 'version', 'outputs', 'license', 'synopsis',
- 'description', 'home-url', 'inputs', 'native-inputs',
- 'propagated-inputs', 'location', 'installed'.
-
-- If ENTRY-TYPE is 'output':
- 'id', 'package-id', 'name', 'version', 'output', 'license',
- 'synopsis', 'description', 'home-url', 'inputs', 'native-inputs',
- 'propagated-inputs', 'location', 'installed', 'path', 'dependencies'.
-
-- If ENTRY-TYPE is 'generation':
- 'id', 'number', 'prev-number', 'path', 'time'.
-
-Returning value is a list of alists. Each alist consists of
-parameter/value pairs."
- (case entry-type
- ((package output)
- (package/output-sexps profile params entry-type
- search-type search-vals))
- ((generation)
- (generation-sexps profile params
- search-type search-vals))
- ((system-generation)
- (system-generation-sexps profile params
- search-type search-vals))
- (else (entry-type-error entry-type))))
-
-\f
-;;; Package actions.
-
-(define* (package->manifest-entry* package #:optional output)
- (and 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))
- (parameterize ((%graft? (not dry-run?)))
- (with-store store
- (set-build-options store
- #:print-build-trace #f
- #:use-substitutes? use-substitutes?)
- (show-manifest-transaction store manifest transaction
- #:dry-run? dry-run?)
- (build-and-use-profile store profile new-manifest
- #:use-substitutes? use-substitutes?
- #:dry-run? dry-run?))))))
-
-(define (delete-generations* profile generations)
- "Delete GENERATIONS from PROFILE.
-GENERATIONS is a list of generation numbers."
- (with-store store
- (delete-generations store profile generations)))
-
-(define (package-location-string id-or-name)
- "Return a location string of a package with ID-OR-NAME."
- (and=> (or (package-by-id id-or-name)
- (match (packages-by-name id-or-name)
- (() #f)
- ((package _ ...) package)))
- (compose location->string package-location)))
-
-(define (package-store-path package-id)
- "Return a list of store directories of outputs of package PACKAGE-ID."
- (match (package-by-id package-id)
- (#f '())
- (package
- (with-store store
- (map (match-lambda
- ((_ . drv)
- (derivation-output-path drv)))
- (derivation-outputs (package-derivation store package)))))))
-
-(define (package-source-derivation->store-path derivation)
- "Return a store path of the package source DERIVATION."
- (match (derivation-outputs derivation)
- ;; Source derivation is always (("out" . derivation)).
- (((_ . output-drv))
- (derivation-output-path output-drv))
- (_ #f)))
-
-(define (package-source-path package-id)
- "Return a store file path to a source of a package PACKAGE-ID."
- (and-let* ((package (package-by-id package-id))
- (source (package-source package)))
- (with-store store
- (package-source-derivation->store-path
- (package-source-derivation store source)))))
-
-(define* (package-source-build-derivation package-id #:key dry-run?
- (use-substitutes? #t))
- "Build source derivation of a package PACKAGE-ID."
- (and-let* ((package (package-by-id package-id))
- (source (package-source package)))
- (with-store store
- (let* ((derivation (package-source-derivation store source))
- (derivations (list derivation)))
- (set-build-options store
- #:print-build-trace #f
- #:use-substitutes? use-substitutes?)
- (show-what-to-build store derivations
- #:use-substitutes? use-substitutes?
- #:dry-run? dry-run?)
- (unless dry-run?
- (build-derivations store derivations))
- (format #t "The source store path: ~a~%"
- (package-source-derivation->store-path derivation))))))
-
-(define (package-build-log-file package-id)
- "Return the build log file of a package PACKAGE-ID.
-Return #f if the build log is not found."
- (and-let* ((package (package-by-id package-id)))
- (with-store store
- (let* ((derivation (package-derivation store package))
- (file (derivation-file-name derivation)))
- (or (log-file store file)
- ((@@ (guix scripts build) log-url) store file))))))
-
-\f
-;;; Executing guix commands
-
-(define (guix-command . args)
- "Run 'guix ARGS ...' command."
- (catch 'quit
- (lambda () (apply run-guix args))
- (const #t)))
-
-(define (guix-command-output . args)
- "Return 2 strings with 'guix ARGS ...' output and error output."
- (output+error
- (lambda ()
- (parameterize ((guix-warning-port (current-error-port)))
- (apply guix-command args)))))
-
-(define (help-string . commands)
- "Return string with 'guix COMMANDS ... --help' output."
- (apply guix-command-output `(,@commands "--help")))
-
-(define (pipe-guix-output guix-args command-args)
- "Run 'guix GUIX-ARGS ...' command and pipe its output to a shell command
-defined by COMMAND-ARGS.
-Return #t if the shell command was executed successfully."
- (let ((pipe (apply open-pipe* OPEN_WRITE command-args)))
- (with-output-to-port pipe
- (lambda () (apply guix-command guix-args)))
- (zero? (status:exit-val (close-pipe pipe)))))
-
-\f
-;;; Lists of packages, lint checkers, etc.
-
-(define (graph-type-names)
- "Return a list of names of available graph node types."
- (map (@ (guix graph) node-type-name)
- (@ (guix scripts graph) %node-types)))
-
-(define (refresh-updater-names)
- "Return a list of names of available refresh updater types."
- (map (@ (guix upstream) upstream-updater-name)
- (@ (guix scripts refresh) %updaters)))
-
-(define (lint-checker-names)
- "Return a list of names of available lint checkers."
- (map (lambda (checker)
- (symbol->string ((@ (guix scripts lint) lint-checker-name)
- checker)))
- (@ (guix scripts lint) %checkers)))
-
-(define (package-names)
- "Return a list of names of available packages."
- (delete-duplicates
- (fold-packages (lambda (pkg res)
- (cons (package-name pkg) res))
- '())))
-
-;; See the comment to 'guix-package-names' function in "guix-popup.el".
-(define (package-names-lists)
- (map list (package-names)))
-
-\f
-;;; Licenses
-
-(define %licenses
- (delay
- (filter license?
- (module-map (lambda (_ var)
- (variable-ref var))
- (resolve-interface '(guix licenses))))))
-
-(define (licenses)
- (force %licenses))
-
-(define (license-names)
- "Return a list of names of available licenses."
- (map license-name (licenses)))
-
-(define lookup-license
- (memoize
- (lambda (name)
- "Return a license by its name."
- (find (lambda (l)
- (string=? name (license-name l)))
- (licenses)))))
-
-(define (lookup-license-uri name)
- "Return a license URI by its name."
- (and=> (lookup-license name)
- license-uri))
-
-(define %license-param-alist
- `((id . ,license-name)
- (name . ,license-name)
- (url . ,license-uri)
- (comment . ,license-comment)))
-
-(define license->sexp
- (object-transformer %license-param-alist))
-
-(define (find-licenses search-type . search-values)
- "Return a list of licenses depending on SEARCH-TYPE and SEARCH-VALUES."
- (case search-type
- ((id name)
- (let ((names search-values))
- (filter-map lookup-license names)))
- ((all)
- (licenses))))
-
-(define (license-entries search-type . search-values)
- (map license->sexp
- (apply find-licenses search-type search-values)))
-
-\f
-;;; Package locations
-
-(define-values (packages-by-location-file
- package-location-files)
- (let* ((table (delay (fold-packages
- (lambda (package table)
- (let ((file (location-file
- (package-location package))))
- (vhash-cons file package table)))
- vlist-null)))
- (files (delay (vhash-fold
- (lambda (file _ result)
- (if (member file result)
- result
- (cons file result)))
- '()
- (force table)))))
- (values
- (lambda (file)
- "Return the (possibly empty) list of packages defined in location FILE."
- (vhash-fold* cons '() file (force table)))
- (lambda ()
- "Return the list of file names of all package locations."
- (force files)))))
-
-(define %package-location-param-alist
- `((id . ,identity)
- (location . ,identity)
- (number-of-packages . ,(lambda (location)
- (length (packages-by-location-file location))))))
-
-(define package-location->sexp
- (object-transformer %package-location-param-alist))
-
-(define (package-location-entries)
- (map package-location->sexp (package-location-files)))
HCoop / jackhill / guix / guix.git / blobdiff