gnu: r-phangorn: Move to (gnu packages cran).
[jackhill/guix/guix.git] / guix / describe.scm
CommitLineData
fe634eaf 1;;; GNU Guix --- Functional package management for GNU
2cb658a9 2;;; Copyright © 2018, 2019 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))
fe634eaf
LC
26 #:use-module (srfi srfi-1)
27 #:use-module (ice-9 match)
bd747018 28 #:export (current-profile
cd2e4b2a 29 current-profile-date
bd747018 30 current-profile-entries
2cb658a9
LC
31 package-path-entries
32
c48e522f
LC
33 package-provenance
34 manifest-entry-with-provenance))
fe634eaf
LC
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,
49or #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
cd2e4b2a
LC
61(define (current-profile-date)
62 "Return the creation date of the current profile (produced by 'guix pull'),
63as 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
fe634eaf
LC
82(define current-profile-entries
83 (mlambda ()
84 "Return the list of entries in the 'guix pull' profile the calling process
85lives 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
bfc9c339 92(define current-channel-entries
fe634eaf 93 (mlambda ()
bfc9c339
LC
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
102package search path, and the list to be added to %LOAD-COMPILED-PATH. These
103entries are taken from the 'guix pull' profile the calling process lives in,
104when applicable."
105 ;; Filter out Guix itself.
106 (unzip2 (map (lambda (entry)
107 (list (string-append (manifest-entry-item entry)
fe634eaf 108 "/share/guile/site/"
bfc9c339
LC
109 (effective-version))
110 (string-append (manifest-entry-item entry)
111 "/lib/guile/" (effective-version)
112 "/site-ccache")))
3f4f2ee4 113 (current-channel-entries))))
2cb658a9
LC
114
115(define (package-provenance package)
116 "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
117property 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) '()))))))))))
c48e522f
LC
148
149(define (manifest-entry-with-provenance entry)
150 "Return ENTRY with an additional 'provenance' property if it's not already
151there."
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)))))))))