guix/describe.scm

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