Commit | Line | Data |
---|---|---|
fe634eaf | 1 | ;;; GNU Guix --- Functional package management for GNU |
aedbc5ff | 2 | ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
fe634eaf LC |
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) | |
2cb658a9 LC |
22 | #:use-module (guix packages) |
23 | #:use-module ((guix utils) #:select (location-file)) | |
cd2e4b2a LC |
24 | #:use-module ((guix store) #:select (%store-prefix store-path?)) |
25 | #:use-module ((guix config) #:select (%state-directory)) | |
b6c7e5af MO |
26 | #:autoload (guix channels) (channel-name |
27 | sexp->channel | |
28 | manifest-entry-channel) | |
fe634eaf LC |
29 | #:use-module (srfi srfi-1) |
30 | #:use-module (ice-9 match) | |
bd747018 | 31 | #:export (current-profile |
cd2e4b2a | 32 | current-profile-date |
bd747018 | 33 | current-profile-entries |
316fc2ac | 34 | current-channels |
2cb658a9 LC |
35 | package-path-entries |
36 | ||
c48e522f | 37 | package-provenance |
17fbd5a5 | 38 | package-channels |
aedbc5ff LC |
39 | manifest-entry-with-provenance |
40 | manifest-entry-provenance)) | |
fe634eaf LC |
41 | |
42 | ;;; Commentary: | |
43 | ;;; | |
44 | ;;; This module provides supporting code to allow a Guix instance to find, at | |
45 | ;;; run time, which profile it's in (profiles created by 'guix pull'). That | |
46 | ;;; allows it to read meta-information about itself (e.g., repository URL and | |
47 | ;;; commit ID) and to find other channels available in the same profile. It's | |
48 | ;;; a bit like ELPA's pkg-info.el. | |
49 | ;;; | |
50 | ;;; Code: | |
51 | ||
1b179d78 LC |
52 | (define initial-program-arguments |
53 | ;; Save the initial program arguments. This allows us to see the "real" | |
54 | ;; 'guix' program, even if 'guix repl -s' calls 'set-program-arguments' | |
55 | ;; later on. | |
56 | (program-arguments)) | |
57 | ||
fe634eaf LC |
58 | (define current-profile |
59 | (mlambda () | |
60 | "Return the profile (created by 'guix pull') the calling process lives in, | |
61 | or #f if this is not applicable." | |
1b179d78 | 62 | (match initial-program-arguments |
fe634eaf LC |
63 | ((program . _) |
64 | (and (string-suffix? "/bin/guix" program) | |
65 | ;; Note: We want to do _lexical dot-dot resolution_. Using ".." | |
66 | ;; for real would instead take us into the /gnu/store directory | |
67 | ;; that ~/.config/guix/current/bin points to, whereas we want to | |
68 | ;; obtain ~/.config/guix/current. | |
69 | (let ((candidate (dirname (dirname program)))) | |
70 | (and (file-exists? (string-append candidate "/manifest")) | |
71 | candidate))))))) | |
72 | ||
cd2e4b2a LC |
73 | (define (current-profile-date) |
74 | "Return the creation date of the current profile (produced by 'guix pull'), | |
75 | as a number of seconds since the Epoch, or #f if it could not be determined." | |
76 | ;; Normally 'current-profile' will return ~/.config/guix/current. We need | |
77 | ;; to 'readlink' once to get '/var/guix/…/guix-profile', whose mtime is the | |
78 | ;; piece of information we're looking for. | |
79 | (let loop ((profile (current-profile))) | |
80 | (match profile | |
81 | (#f #f) | |
82 | ((? store-path?) #f) | |
83 | (file | |
84 | (if (string-prefix? %state-directory file) | |
85 | (and=> (lstat file) stat:mtime) | |
86 | (catch 'system-error | |
87 | (lambda () | |
88 | (let ((target (readlink file))) | |
89 | (loop (if (string-prefix? "/" target) | |
90 | target | |
91 | (string-append (dirname file) "/" target))))) | |
92 | (const #f))))))) | |
93 | ||
316fc2ac LC |
94 | (define (channel-metadata) |
95 | "Return the 'guix' channel metadata sexp from (guix config) if available; | |
96 | otherwise return #f." | |
97 | ;; Older 'build-self.scm' would create a (guix config) file without the | |
98 | ;; '%channel-metadata' variable. Thus, properly deal with a lack of | |
99 | ;; information. | |
100 | (let ((module (resolve-interface '(guix config)))) | |
101 | (and=> (module-variable module '%channel-metadata) variable-ref))) | |
102 | ||
fe634eaf LC |
103 | (define current-profile-entries |
104 | (mlambda () | |
105 | "Return the list of entries in the 'guix pull' profile the calling process | |
316fc2ac | 106 | lives in, or the empty list if this is not applicable." |
fe634eaf LC |
107 | (match (current-profile) |
108 | (#f '()) | |
109 | (profile | |
110 | (let ((manifest (profile-manifest profile))) | |
111 | (manifest-entries manifest)))))) | |
112 | ||
bfc9c339 | 113 | (define current-channel-entries |
fe634eaf | 114 | (mlambda () |
bfc9c339 LC |
115 | "Return manifest entries corresponding to extra channels--i.e., not the |
116 | 'guix' channel." | |
117 | (remove (lambda (entry) | |
118 | (string=? (manifest-entry-name entry) "guix")) | |
119 | (current-profile-entries)))) | |
120 | ||
316fc2ac LC |
121 | (define current-channels |
122 | (mlambda () | |
123 | "Return the list of channels currently available, including the 'guix' | |
124 | channel. Return the empty list if this information is missing." | |
125 | (match (current-profile-entries) | |
126 | (() | |
127 | ;; As a fallback, if we're not running from a profile, use 'guix' | |
128 | ;; channel metadata from (guix config). | |
129 | (match (channel-metadata) | |
130 | (#f '()) | |
131 | (sexp (or (and=> (sexp->channel sexp 'guix) list) '())))) | |
132 | (entries | |
133 | (filter-map manifest-entry-channel entries))))) | |
134 | ||
bfc9c339 LC |
135 | (define (package-path-entries) |
136 | "Return two values: the list of package path entries to be added to the | |
137 | package search path, and the list to be added to %LOAD-COMPILED-PATH. These | |
138 | entries are taken from the 'guix pull' profile the calling process lives in, | |
139 | when applicable." | |
140 | ;; Filter out Guix itself. | |
141 | (unzip2 (map (lambda (entry) | |
142 | (list (string-append (manifest-entry-item entry) | |
fe634eaf | 143 | "/share/guile/site/" |
bfc9c339 LC |
144 | (effective-version)) |
145 | (string-append (manifest-entry-item entry) | |
146 | "/lib/guile/" (effective-version) | |
147 | "/site-ccache"))) | |
3f4f2ee4 | 148 | (current-channel-entries)))) |
2cb658a9 | 149 | |
17fbd5a5 MO |
150 | (define (package-channels package) |
151 | "Return the list of channels providing PACKAGE or an empty list if it could | |
152 | not be determined." | |
153 | (match (and=> (package-location package) location-file) | |
154 | (#f '()) | |
155 | (file | |
156 | (let ((file (if (string-prefix? "/" file) | |
157 | file | |
158 | (search-path %load-path file)))) | |
4dfce011 MO |
159 | (if (and file |
160 | (string-prefix? (%store-prefix) file)) | |
161 | (filter-map | |
162 | (lambda (entry) | |
163 | (let ((item (manifest-entry-item entry))) | |
164 | (and (or (string-prefix? item file) | |
165 | (string=? "guix" (manifest-entry-name entry))) | |
166 | (manifest-entry-channel entry)))) | |
167 | (current-profile-entries)) | |
168 | '()))))) | |
17fbd5a5 | 169 | |
2cb658a9 LC |
170 | (define (package-provenance package) |
171 | "Return the provenance of PACKAGE as an sexp for use as the 'provenance' | |
172 | property of manifest entries, or #f if it could not be determined." | |
173 | (define (entry-source entry) | |
174 | (match (assq 'source | |
175 | (manifest-entry-properties entry)) | |
176 | (('source value) value) | |
177 | (_ #f))) | |
178 | ||
17fbd5a5 MO |
179 | (let* ((channels (package-channels package)) |
180 | (names (map (compose symbol->string channel-name) channels))) | |
181 | ;; Always store information about the 'guix' channel and | |
182 | ;; optionally about the specific channel FILE comes from. | |
183 | (or (let ((main (and=> (find (lambda (entry) | |
184 | (string=? "guix" | |
185 | (manifest-entry-name entry))) | |
186 | (current-profile-entries)) | |
187 | entry-source)) | |
188 | (extra (any (lambda (entry) | |
189 | (let ((item (manifest-entry-item entry)) | |
190 | (name (manifest-entry-name entry))) | |
191 | (and (member name names) | |
192 | (not (string=? name "guix")) | |
193 | (entry-source entry)))) | |
194 | (current-profile-entries)))) | |
195 | (and main | |
196 | `(,main | |
197 | ,@(if extra (list extra) '()))))))) | |
c48e522f LC |
198 | |
199 | (define (manifest-entry-with-provenance entry) | |
200 | "Return ENTRY with an additional 'provenance' property if it's not already | |
201 | there." | |
202 | (let ((properties (manifest-entry-properties entry))) | |
ce2ba343 | 203 | (if (assq 'provenance properties) |
c48e522f LC |
204 | entry |
205 | (let ((item (manifest-entry-item entry))) | |
206 | (manifest-entry | |
207 | (inherit entry) | |
208 | (properties | |
209 | (match (and (package? item) (package-provenance item)) | |
210 | (#f properties) | |
211 | (sexp `((provenance ,@sexp) | |
212 | ,@properties))))))))) | |
aedbc5ff LC |
213 | |
214 | (define (manifest-entry-provenance entry) | |
215 | "Return the list of channels ENTRY comes from. Return the empty list if | |
216 | that information is missing." | |
217 | (match (assq-ref (manifest-entry-properties entry) 'provenance) | |
218 | ((main extras ...) | |
219 | ;; XXX: Until recently, channel sexps lacked the channel name. For | |
220 | ;; entries created by 'manifest-entry-with-provenance', the first sexp | |
221 | ;; is known to be the 'guix channel, and for the other ones, invent a | |
222 | ;; fallback name (it's OK as the name is just a "pet name"). | |
223 | (match (sexp->channel main 'guix) | |
224 | (#f '()) | |
225 | (channel | |
226 | (let loop ((extras extras) | |
227 | (counter 1) | |
228 | (channels (list channel))) | |
229 | (match extras | |
230 | (() | |
231 | (reverse channels)) | |
232 | ((head . tail) | |
233 | (let* ((name (string->symbol | |
234 | (format #f "channel~a" counter))) | |
235 | (extra (sexp->channel head name))) | |
236 | (if extra | |
237 | (loop tail (+ 1 counter) (cons extra channels)) | |
238 | (loop tail counter channels))))))))) | |
239 | (_ | |
240 | '()))) |