guix/describe.scm

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