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
  35 ;;; Commentary:
  36 ;;;
  37 ;;; This module provides supporting code to allow a Guix instance to find, at
  38 ;;; run time, which profile it's in (profiles created by 'guix pull').  That
  39 ;;; allows it to read meta-information about itself (e.g., repository URL and
  40 ;;; commit ID) and to find other channels available in the same profile.  It's
  41 ;;; a bit like ELPA's pkg-info.el.
  42 ;;;
  43 ;;; Code:
  44
  45 (define current-profile
  46   (mlambda ()
  47     "Return the profile (created by 'guix pull') the calling process lives in,
  48 or #f if this is not applicable."
  49     (match (command-line)
  50       ((program . _)
  51        (and (string-suffix? "/bin/guix" program)
  52             ;; Note: We want to do _lexical dot-dot resolution_.  Using ".."
  53             ;; for real would instead take us into the /gnu/store directory
  54             ;; that ~/.config/guix/current/bin points to, whereas we want to
  55             ;; obtain ~/.config/guix/current.
  56             (let ((candidate (dirname (dirname program))))
  57               (and (file-exists? (string-append candidate "/manifest"))
  58                    candidate)))))))
  59
  60 (define (current-profile-date)
  61   "Return the creation date of the current profile (produced by 'guix pull'),
  62 as a number of seconds since the Epoch, or #f if it could not be determined."
  63   ;; Normally 'current-profile' will return ~/.config/guix/current.  We need
  64   ;; to 'readlink' once to get '/var/guix/…/guix-profile', whose mtime is the
  65   ;; piece of information we're looking for.
  66   (let loop ((profile (current-profile)))
  67     (match profile
  68       (#f #f)
  69       ((? store-path?) #f)
  70       (file
  71        (if (string-prefix? %state-directory file)
  72            (and=> (lstat file) stat:mtime)
  73            (catch 'system-error
  74              (lambda ()
  75                (let ((target (readlink file)))
  76                  (loop (if (string-prefix? "/" target)
  77                            target
  78                            (string-append (dirname file) "/" target)))))
  79              (const #f)))))))
  80
  81 (define current-profile-entries
  82   (mlambda ()
  83     "Return the list of entries in the 'guix pull' profile the calling process
  84 lives in, or #f if this is not applicable."
  85     (match (current-profile)
  86       (#f '())
  87       (profile
  88        (let ((manifest (profile-manifest profile)))
  89          (manifest-entries manifest))))))
  90
  91 (define current-channel-entries
  92   (mlambda ()
  93     "Return manifest entries corresponding to extra channels--i.e., not the
  94 'guix' channel."
  95     (remove (lambda (entry)
  96               (string=? (manifest-entry-name entry) "guix"))
  97             (current-profile-entries))))
  98
  99 (define (package-path-entries)
 100   "Return two values: the list of package path entries to be added to the
 101 package search path, and the list to be added to %LOAD-COMPILED-PATH.  These
 102 entries are taken from the 'guix pull' profile the calling process lives in,
 103 when applicable."
 104   ;; Filter out Guix itself.
 105   (unzip2 (map (lambda (entry)
 106                  (list (string-append (manifest-entry-item entry)
 107                                       "/share/guile/site/"
 108                                       (effective-version))
 109                        (string-append (manifest-entry-item entry)
 110                                       "/lib/guile/" (effective-version)
 111                                       "/site-ccache")))
 112                (current-channel-entries))))
 113
 114 (define (package-provenance package)
 115   "Return the provenance of PACKAGE as an sexp for use as the 'provenance'
 116 property of manifest entries, or #f if it could not be determined."
 117   (define (entry-source entry)
 118     (match (assq 'source
 119                  (manifest-entry-properties entry))
 120       (('source value) value)
 121       (_ #f)))
 122
 123   (match (and=> (package-location package) location-file)
 124     (#f #f)
 125     (file
 126      (let ((file (if (string-prefix? "/" file)
 127                      file
 128                      (search-path %load-path file))))
 129        (and file
 130             (string-prefix? (%store-prefix) file)
 131
 132             ;; Always store information about the 'guix' channel and
 133             ;; optionally about the specific channel FILE comes from.
 134             (or (let ((main  (and=> (find (lambda (entry)
 135                                             (string=? "guix"
 136                                                       (manifest-entry-name entry)))
 137                                           (current-profile-entries))
 138                                     entry-source))
 139                       (extra (any (lambda (entry)
 140                                     (let ((item (manifest-entry-item entry)))
 141                                       (and (string-prefix? item file)
 142                                            (entry-source entry))))
 143                                   (current-profile-entries))))
 144                   (and main
 145                        `(,main
 146                          ,@(if extra (list extra) '()))))))))))