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               (string=? (manifest-entry-name entry) "guix"))
 119             (current-profile-entries))))
 120
 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
 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)
 143                                       "/share/guile/site/"
 144                                       (effective-version))
 145                        (string-append (manifest-entry-item entry)
 146                                       "/lib/guile/" (effective-version)
 147                                       "/site-ccache")))
 148                (current-channel-entries))))
 149
 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))))
 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            '())))))
 169
 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
 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) '())))))))
 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)))
 203     (if (assq 'provenance properties)
 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)))))))))
 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      '())))