| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (guix describe) |
| 20 | #:use-module (guix memoization) |
| 21 | #:use-module (guix profiles) |
| 22 | #:use-module (guix packages) |
| 23 | #:use-module ((guix utils) #:select (location-file)) |
| 24 | #:use-module ((guix store) #:select (%store-prefix store-path?)) |
| 25 | #:use-module ((guix config) #:select (%state-directory)) |
| 26 | #:use-module (srfi srfi-1) |
| 27 | #:use-module (ice-9 match) |
| 28 | #:export (current-profile |
| 29 | current-profile-date |
| 30 | current-profile-entries |
| 31 | package-path-entries |
| 32 | |
| 33 | package-provenance |
| 34 | manifest-entry-with-provenance)) |
| 35 | |
| 36 | ;;; Commentary: |
| 37 | ;;; |
| 38 | ;;; This module provides supporting code to allow a Guix instance to find, at |
| 39 | ;;; run time, which profile it's in (profiles created by 'guix pull'). That |
| 40 | ;;; allows it to read meta-information about itself (e.g., repository URL and |
| 41 | ;;; commit ID) and to find other channels available in the same profile. It's |
| 42 | ;;; a bit like ELPA's pkg-info.el. |
| 43 | ;;; |
| 44 | ;;; Code: |
| 45 | |
| 46 | (define current-profile |
| 47 | (mlambda () |
| 48 | "Return the profile (created by 'guix pull') the calling process lives in, |
| 49 | or #f if this is not applicable." |
| 50 | (match (command-line) |
| 51 | ((program . _) |
| 52 | (and (string-suffix? "/bin/guix" program) |
| 53 | ;; Note: We want to do _lexical dot-dot resolution_. Using ".." |
| 54 | ;; for real would instead take us into the /gnu/store directory |
| 55 | ;; that ~/.config/guix/current/bin points to, whereas we want to |
| 56 | ;; obtain ~/.config/guix/current. |
| 57 | (let ((candidate (dirname (dirname program)))) |
| 58 | (and (file-exists? (string-append candidate "/manifest")) |
| 59 | candidate))))))) |
| 60 | |
| 61 | (define (current-profile-date) |
| 62 | "Return the creation date of the current profile (produced by 'guix pull'), |
| 63 | as a number of seconds since the Epoch, or #f if it could not be determined." |
| 64 | ;; Normally 'current-profile' will return ~/.config/guix/current. We need |
| 65 | ;; to 'readlink' once to get '/var/guix/…/guix-profile', whose mtime is the |
| 66 | ;; piece of information we're looking for. |
| 67 | (let loop ((profile (current-profile))) |
| 68 | (match profile |
| 69 | (#f #f) |
| 70 | ((? store-path?) #f) |
| 71 | (file |
| 72 | (if (string-prefix? %state-directory file) |
| 73 | (and=> (lstat file) stat:mtime) |
| 74 | (catch 'system-error |
| 75 | (lambda () |
| 76 | (let ((target (readlink file))) |
| 77 | (loop (if (string-prefix? "/" target) |
| 78 | target |
| 79 | (string-append (dirname file) "/" target))))) |
| 80 | (const #f))))))) |
| 81 | |
| 82 | (define current-profile-entries |
| 83 | (mlambda () |
| 84 | "Return the list of entries in the 'guix pull' profile the calling process |
| 85 | lives in, or #f if this is not applicable." |
| 86 | (match (current-profile) |
| 87 | (#f '()) |
| 88 | (profile |
| 89 | (let ((manifest (profile-manifest profile))) |
| 90 | (manifest-entries manifest)))))) |
| 91 | |
| 92 | (define current-channel-entries |
| 93 | (mlambda () |
| 94 | "Return manifest entries corresponding to extra channels--i.e., not the |
| 95 | 'guix' channel." |
| 96 | (remove (lambda (entry) |
| 97 | (string=? (manifest-entry-name entry) "guix")) |
| 98 | (current-profile-entries)))) |
| 99 | |
| 100 | (define (package-path-entries) |
| 101 | "Return two values: the list of package path entries to be added to the |
| 102 | package search path, and the list to be added to %LOAD-COMPILED-PATH. These |
| 103 | entries are taken from the 'guix pull' profile the calling process lives in, |
| 104 | when applicable." |
| 105 | ;; Filter out Guix itself. |
| 106 | (unzip2 (map (lambda (entry) |
| 107 | (list (string-append (manifest-entry-item entry) |
| 108 | "/share/guile/site/" |
| 109 | (effective-version)) |
| 110 | (string-append (manifest-entry-item entry) |
| 111 | "/lib/guile/" (effective-version) |
| 112 | "/site-ccache"))) |
| 113 | (current-channel-entries)))) |
| 114 | |
| 115 | (define (package-provenance package) |
| 116 | "Return the provenance of PACKAGE as an sexp for use as the 'provenance' |
| 117 | property of manifest entries, or #f if it could not be determined." |
| 118 | (define (entry-source entry) |
| 119 | (match (assq 'source |
| 120 | (manifest-entry-properties entry)) |
| 121 | (('source value) value) |
| 122 | (_ #f))) |
| 123 | |
| 124 | (match (and=> (package-location package) location-file) |
| 125 | (#f #f) |
| 126 | (file |
| 127 | (let ((file (if (string-prefix? "/" file) |
| 128 | file |
| 129 | (search-path %load-path file)))) |
| 130 | (and file |
| 131 | (string-prefix? (%store-prefix) file) |
| 132 | |
| 133 | ;; Always store information about the 'guix' channel and |
| 134 | ;; optionally about the specific channel FILE comes from. |
| 135 | (or (let ((main (and=> (find (lambda (entry) |
| 136 | (string=? "guix" |
| 137 | (manifest-entry-name entry))) |
| 138 | (current-profile-entries)) |
| 139 | entry-source)) |
| 140 | (extra (any (lambda (entry) |
| 141 | (let ((item (manifest-entry-item entry))) |
| 142 | (and (string-prefix? item file) |
| 143 | (entry-source entry)))) |
| 144 | (current-profile-entries)))) |
| 145 | (and main |
| 146 | `(,main |
| 147 | ,@(if extra (list extra) '())))))))))) |
| 148 | |
| 149 | (define (manifest-entry-with-provenance entry) |
| 150 | "Return ENTRY with an additional 'provenance' property if it's not already |
| 151 | there." |
| 152 | (let ((properties (manifest-entry-properties entry))) |
| 153 | (if (assq 'properties properties) |
| 154 | entry |
| 155 | (let ((item (manifest-entry-item entry))) |
| 156 | (manifest-entry |
| 157 | (inherit entry) |
| 158 | (properties |
| 159 | (match (and (package? item) (package-provenance item)) |
| 160 | (#f properties) |
| 161 | (sexp `((provenance ,@sexp) |
| 162 | ,@properties))))))))) |