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) (channel-name
  27                                 sexp->channel
  28                                 manifest-entry-channel)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (ice-9 match)
  31   #:export (current-profile
  32             current-profile-date
  33             current-profile-entries
  34             current-channels
  35             package-path-entries
  36
  37             package-provenance
  38             package-channels
  39             manifest-entry-with-provenance
  40             manifest-entry-provenance))
  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
  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
  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."
  62     (match initial-program-arguments
  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
  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
  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
 103 (define current-profile-entries
 104   (mlambda ()
 105     "Return the list of entries in the 'guix pull' profile the calling process
 106 lives in, or the empty list if this is not applicable."
 107     (match (current-profile)
 108       (#f '())
 109       (profile
 110        (let ((manifest (profile-manifest profile)))
 111          (manifest-entries manifest))))))
 112
 113 (define current-channel-entries
 114   (mlambda ()
 115     "Return manifest entries corresponding to extra channels--i.e., not the
 116 'guix' channel."
 117     (remove (lambda (entry)
 118               (or (string=? (manifest-entry-name entry) "guix")
 119
 120                   ;; If ENTRY lacks the 'source' property, it's not an entry
 121                   ;; from 'guix pull'.  See <https://bugs.gnu.org/48778>.
 122                   (not (assq 'source (manifest-entry-properties entry)))))
 123             (current-profile-entries))))
 124
 125 (define current-channels
 126   (mlambda ()
 127     "Return the list of channels currently available, including the 'guix'
 128 channel.  Return the empty list if this information is missing."
 129     (define (build-time-metadata)
 130       (match (channel-metadata)
 131         (#f '())
 132         (sexp (or (and=> (sexp->channel sexp 'guix) list) '()))))
 133
 134     (match (current-profile-entries)
 135       (()
 136        ;; As a fallback, if we're not running from a profile, use 'guix'
 137        ;; channel metadata from (guix config).
 138        (build-time-metadata))
 139       (entries
 140        (match (filter-map manifest-entry-channel entries)
 141          (()
 142           ;; This profile lacks provenance metadata, so fall back to
 143           ;; build-time metadata as returned by 'channel-metadata'.
 144           (build-time-metadata))
 145          (lst
 146           lst))))))
 147
 148 (define (package-path-entries)
 149   "Return two values: the list of package path entries to be added to the
 150 package search path, and the list to be added to %LOAD-COMPILED-PATH.  These
 151 entries are taken from the 'guix pull' profile the calling process lives in,
 152 when applicable."
 153   ;; Filter out Guix itself.
 154   (unzip2 (map (lambda (entry)
 155                  (list (string-append (manifest-entry-item entry)
 156                                       "/share/guile/site/"
 157                                       (effective-version))
 158                        (string-append (manifest-entry-item entry)
 159                                       "/lib/guile/" (effective-version)
 160                                       "/site-ccache")))
 161                (current-channel-entries))))
 162
 163 (define (package-channels package)
 164   "Return the list of channels providing PACKAGE or an empty list if it could
 165 not be determined."
 166   (match (and=> (package-location package) location-file)
 167     (#f '())
 168     (file
 169      (let ((file (if (string-prefix? "/" file)
 170                      file
 171                      (search-path %load-path file))))
 172        (if (and file
 173                 (string-prefix? (%store-prefix) file))
 174            (filter-map
 175             (lambda (entry)
 176               (let ((item (manifest-entry-item entry)))
 177                 (and (or (string-prefix? item file)
 178                          (string=? "guix" (manifest-entry-name entry)))
 179                      (manifest-entry-channel entry))))
 180             (current-profile-entries))
 181            '())))))
 182
 183 (define (package-provenance package)
 184   "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
 185 property of manifest entries, or #f if it could not be determined."
 186   (define (entry-source entry)
 187     (match (assq 'source
 188                  (manifest-entry-properties entry))
 189       (('source value) value)
 190       (_ #f)))
 191
 192   (let* ((channels (package-channels package))
 193          (names (map (compose symbol->string channel-name) channels)))
 194     ;; Always store information about the 'guix' channel and
 195     ;; optionally about the specific channel FILE comes from.
 196     (or (let ((main  (and=> (find (lambda (entry)
 197                                     (string=? "guix"
 198                                               (manifest-entry-name entry)))
 199                                   (current-profile-entries))
 200                             entry-source))
 201               (extra (any (lambda (entry)
 202                             (let ((item (manifest-entry-item entry))
 203                                   (name (manifest-entry-name entry)))
 204                               (and (member name names)
 205                                    (not (string=? name "guix"))
 206                                    (entry-source entry))))
 207                           (current-profile-entries))))
 208           (and main
 209                `(,main
 210                  ,@(if extra (list extra) '())))))))
 211
 212 (define (manifest-entry-with-provenance entry)
 213   "Return ENTRY with an additional 'provenance' property if it's not already
 214 there."
 215   (let ((properties (manifest-entry-properties entry)))
 216     (if (assq 'provenance properties)
 217         entry
 218         (let ((item (manifest-entry-item entry)))
 219           (manifest-entry
 220             (inherit entry)
 221             (properties
 222              (match (and (package? item) (package-provenance item))
 223                (#f   properties)
 224                (sexp `((provenance ,@sexp)
 225                        ,@properties)))))))))
 226
 227 (define (manifest-entry-provenance entry)
 228   "Return the list of channels ENTRY comes from.  Return the empty list if
 229 that information is missing."
 230   (match (assq-ref (manifest-entry-properties entry) 'provenance)
 231     ((main extras ...)
 232      ;; XXX: Until recently, channel sexps lacked the channel name.  For
 233      ;; entries created by 'manifest-entry-with-provenance', the first sexp
 234      ;; is known to be the 'guix channel, and for the other ones, invent a
 235      ;; fallback name (it's OK as the name is just a "pet name").
 236      (match (sexp->channel main 'guix)
 237        (#f '())
 238        (channel
 239         (let loop ((extras   extras)
 240                    (counter  1)
 241                    (channels (list channel)))
 242           (match extras
 243             (()
 244              (reverse channels))
 245             ((head . tail)
 246              (let* ((name  (string->symbol
 247                             (format #f "channel~a" counter)))
 248                     (extra (sexp->channel head name)))
 249                (if extra
 250                    (loop tail (+ 1 counter) (cons extra channels))
 251                    (loop tail counter channels)))))))))
 252     (_
 253      '())))