;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix monads)
#:use-module (guix profiles)
#:use-module (guix derivations)
+ #:use-module (guix combinators)
+ #:use-module (guix diagnostics)
#:use-module (guix store)
#:use-module (guix i18n)
#:use-module ((guix utils)
channel-location
%default-channels
+ guix-channel?
channel-instance?
channel-instance-channel
latest-channel-derivation
channel-instances->manifest
%channel-profile-hooks
- channel-instances->derivation))
+ channel-instances->derivation
+
+ profile-channels))
;;; Commentary:
;;;
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
- (channel-metadata version dependencies)
+ (channel-metadata directory dependencies)
channel-metadata?
- (version channel-metadata-version)
- (dependencies channel-metadata-dependencies))
+ (directory channel-metadata-directory) ;string with leading slash
+ (dependencies channel-metadata-dependencies)) ;list of <channel>
(define (channel-reference channel)
"Return the \"reference\" for CHANNEL, an sexp suitable for
(#f `(branch . ,(channel-branch channel)))
(commit `(commit . ,(channel-commit channel)))))
-(define (read-channel-metadata instance)
+(define (read-channel-metadata port)
+ "Read from PORT channel metadata in the format expected for the
+'.guix-channel' file. Return a <channel-metadata> record, or raise an error
+if valid metadata could not be read from PORT."
+ (match (read port)
+ (('channel ('version 0) properties ...)
+ (let ((directory (and=> (assoc-ref properties 'directory) first))
+ (dependencies (or (assoc-ref properties 'dependencies) '())))
+ (channel-metadata
+ (cond ((not directory) "/")
+ ((string-prefix? "/" directory) directory)
+ (else (string-append "/" directory)))
+ (map (lambda (item)
+ (let ((get (lambda* (key #:optional default)
+ (or (and=> (assoc-ref item key) first) default))))
+ (and-let* ((name (get 'name))
+ (url (get 'url))
+ (branch (get 'branch "master")))
+ (channel
+ (name name)
+ (branch branch)
+ (url url)
+ (commit (get 'commit))))))
+ dependencies))))
+ ((and ('channel ('version version) _ ...) sexp)
+ (raise (condition
+ (&message (message "unsupported '.guix-channel' version"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))
+ (sexp
+ (raise (condition
+ (&message (message "invalid '.guix-channel' file"))
+ (&error-location
+ (location (source-properties->location
+ (source-properties sexp)))))))))
+
+(define (read-channel-metadata-from-source source)
+ "Return a channel-metadata record read from channel's SOURCE/.guix-channel
+description file, or return the default channel-metadata record if that file
+doesn't exist."
+ (catch 'system-error
+ (lambda ()
+ (call-with-input-file (string-append source "/.guix-channel")
+ read-channel-metadata))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (channel-metadata "/" '())
+ (apply throw args)))))
+
+(define (channel-instance-metadata instance)
"Return a channel-metadata record read from the channel INSTANCE's
-description file, or return #F if the channel instance does not include the
-file."
- (let* ((source (channel-instance-checkout instance))
- (meta-file (string-append source "/.guix-channel")))
- (and (file-exists? meta-file)
- (and-let* ((raw (call-with-input-file meta-file read))
- (version (and=> (assoc-ref raw 'version) first))
- (dependencies (or (assoc-ref raw 'dependencies) '())))
- (channel-metadata
- version
- (map (lambda (item)
- (let ((get (lambda* (key #:optional default)
- (or (and=> (assoc-ref item key) first) default))))
- (and-let* ((name (get 'name))
- (url (get 'url))
- (branch (get 'branch "master")))
- (channel
- (name name)
- (branch branch)
- (url url)
- (commit (get 'commit))))))
- dependencies))))))
+description file or its default value."
+ (read-channel-metadata-from-source (channel-instance-checkout instance)))
(define (channel-instance-dependencies instance)
"Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
- (match (read-channel-metadata instance)
- (#f '())
- (($ <channel-metadata> version dependencies)
- dependencies)))
+ (channel-metadata-dependencies (channel-instance-metadata instance)))
(define* (latest-channel-instances store channels #:optional (previous-channels '()))
"Return a list of channel instances corresponding to the latest checkouts of
(or (channel-commit b)
(not (or (channel-commit a)
(channel-commit b))))))))
+
;; Accumulate a list of instances. A list of processed channels is also
;; accumulated to decide on duplicate channel specifications.
- (match (fold (lambda (channel acc)
- (match acc
- ((#:channels previous-channels #:instances instances)
- (if (ignore? channel previous-channels)
- acc
- (begin
- (format (current-error-port)
- (G_ "Updating channel '~a' from Git repository at '~a'...~%")
- (channel-name channel)
- (channel-url channel))
- (let-values (((checkout commit)
- (latest-repository-commit store (channel-url channel)
- #:ref (channel-reference
- channel))))
- (let ((instance (channel-instance channel commit checkout)))
- (let-values (((new-instances new-channels)
- (latest-channel-instances
- store
- (channel-instance-dependencies instance)
- previous-channels)))
- `(#:channels
- ,(append (cons channel new-channels)
- previous-channels)
- #:instances
- ,(append (cons instance new-instances)
- instances))))))))))
- `(#:channels ,previous-channels #:instances ())
- channels)
- ((#:channels channels #:instances instances)
- (let ((instance-name (compose channel-name channel-instance-channel)))
- ;; Remove all earlier channel specifications if they are followed by a
- ;; more specific one.
- (values (delete-duplicates instances
- (lambda (a b)
- (eq? (instance-name a) (instance-name b))))
- channels)))))
+ (define-values (resulting-channels instances)
+ (fold2 (lambda (channel previous-channels instances)
+ (if (ignore? channel previous-channels)
+ (values previous-channels instances)
+ (begin
+ (format (current-error-port)
+ (G_ "Updating channel '~a' from Git repository at '~a'...~%")
+ (channel-name channel)
+ (channel-url channel))
+ (let-values (((checkout commit)
+ (latest-repository-commit store (channel-url channel)
+ #:ref (channel-reference
+ channel))))
+ (let ((instance (channel-instance channel commit checkout)))
+ (let-values (((new-instances new-channels)
+ (latest-channel-instances
+ store
+ (channel-instance-dependencies instance)
+ previous-channels)))
+ (values (append (cons channel new-channels)
+ previous-channels)
+ (append (cons instance new-instances)
+ instances))))))))
+ previous-channels
+ '() ;instances
+ channels))
+
+ (let ((instance-name (compose channel-name channel-instance-channel)))
+ ;; Remove all earlier channel specifications if they are followed by a
+ ;; more specific one.
+ (values (delete-duplicates instances
+ (lambda (a b)
+ (eq? (instance-name a) (instance-name b))))
+ resulting-channels)))
(define* (checkout->channel-instance checkout
#:key commit
modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
objects. The assumption is that SOURCE contains package modules to be added
to '%package-module-path'."
- ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow
- ;; channel publishers to specify things such as the sub-directory where .scm
- ;; files live, files to exclude from the channel, preferred substitute URLs,
- ;; etc.
-
- (define build
- ;; This is code that we'll run in CORE, a Guix instance, with its own
- ;; modules and so on. That way, we make sure these modules are built for
- ;; the right Guile version, with the right dependencies, and that they get
- ;; to see the right (gnu packages …) modules.
- (with-extensions dependencies
- #~(begin
- (use-modules (guix build compile)
- (guix build utils)
- (srfi srfi-26))
-
- (define go
- (string-append #$output "/lib/guile/" (effective-version)
- "/site-ccache"))
- (define scm
- (string-append #$output "/share/guile/site/"
- (effective-version)))
- (compile-files #$source go
- (find-files #$source "\\.scm$"))
- (mkdir-p (dirname scm))
- (symlink #$source scm)
- scm)))
+ (let* ((metadata (read-channel-metadata-from-source source))
+ (directory (channel-metadata-directory metadata)))
- (gexp->derivation-in-inferior name build core))
+ (define build
+ ;; This is code that we'll run in CORE, a Guix instance, with its own
+ ;; modules and so on. That way, we make sure these modules are built for
+ ;; the right Guile version, with the right dependencies, and that they get
+ ;; to see the right (gnu packages …) modules.
+ (with-extensions dependencies
+ #~(begin
+ (use-modules (guix build compile)
+ (guix build utils)
+ (srfi srfi-26))
+
+ (define go
+ (string-append #$output "/lib/guile/" (effective-version)
+ "/site-ccache"))
+ (define scm
+ (string-append #$output "/share/guile/site/"
+ (effective-version)))
+
+ (let* ((subdir #$directory)
+ (source (string-append #$source subdir)))
+ (compile-files source go (find-files source "\\.scm$"))
+ (mkdir-p (dirname scm))
+ (symlink (string-append #$source subdir) scm))
+
+ scm)))
+
+ (gexp->derivation-in-inferior name build core)))
(define* (build-from-source name source
#:key core verbose? commit
(if (file-exists? script)
(let ((build (save-module-excursion
(lambda ()
- (primitive-load script)))))
+ ;; Disable deprecation warnings; it's OK for SCRIPT to
+ ;; use deprecated APIs and the user doesn't have to know
+ ;; about it.
+ (parameterize ((guix-warning-port
+ (%make-void-port "w")))
+ (primitive-load script))))))
;; BUILD must be a monadic procedure of at least one argument: the
;; source tree.
;;
(resolve-dependencies instances))
(define (instance->derivation instance)
- (mcached (if (eq? instance core-instance)
- (build-channel-instance instance)
- (mlet %store-monad ((core (instance->derivation core-instance))
- (deps (mapm %store-monad instance->derivation
- (edges instance))))
- (build-channel-instance instance core deps)))
- instance))
+ (mlet %store-monad ((system (current-system)))
+ (mcached (if (eq? instance core-instance)
+ (build-channel-instance instance)
+ (mlet %store-monad ((core (instance->derivation core-instance))
+ (deps (mapm %store-monad instance->derivation
+ (edges instance))))
+ (build-channel-instance instance core deps)))
+ instance
+ system)))
(unless core-instance
(let ((loc (and=> (any (compose channel-location channel-instance-channel)
;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
;; dated May 30, 2018) did not depend on "guix-command.drv".
(not (find (lambda (input)
- (string-suffix? "-guix-command.drv"
- (derivation-input-path input)))
+ (string=? "guix-command"
+ (derivation-name
+ (derivation-input-derivation input))))
(derivation-inputs drv))))
(define (channel-instances->manifest instances)
"Return a profile manifest with entries for all of INSTANCES, a list of
channel instances."
- (define instance->entry
- (match-lambda
- ((instance drv)
- (let ((commit (channel-instance-commit instance))
- (channel (channel-instance-channel instance)))
- (with-monad %store-monad
- (return (manifest-entry
- (name (symbol->string (channel-name channel)))
- (version (string-take commit 7))
- (item (if (guix-channel? channel)
- (if (old-style-guix? drv)
- (whole-package-for-legacy
- (string-append name "-" version)
- drv)
- drv)
- drv))
- (properties
- `((source (repository
- (version 0)
- (url ,(channel-url channel))
- (branch ,(channel-branch channel))
- (commit ,commit))))))))))))
+ (define (instance->entry instance drv)
+ (let ((commit (channel-instance-commit instance))
+ (channel (channel-instance-channel instance)))
+ (manifest-entry
+ (name (symbol->string (channel-name channel)))
+ (version (string-take commit 7))
+ (item (if (guix-channel? channel)
+ (if (old-style-guix? drv)
+ (whole-package-for-legacy (string-append name "-" version)
+ drv)
+ drv)
+ drv))
+ (properties
+ `((source (repository
+ (version 0)
+ (url ,(channel-url channel))
+ (branch ,(channel-branch channel))
+ (commit ,commit))))))))
(mlet* %store-monad ((derivations (channel-instance-derivations instances))
- (entries (mapm %store-monad instance->entry
- (zip instances derivations))))
+ (entries -> (map instance->entry instances derivations)))
(return (manifest entries))))
(define (package-cache-file manifest)
(gexp->derivation-in-inferior "guix-package-cache" build
profile
+
+ ;; If the Guix in PROFILE is too old and
+ ;; lacks 'guix repl', don't build the cache
+ ;; instead of failing.
+ #:silent-failure? #t
+
#:properties '((type . profile-hook)
- (hook . package-cache)))))
+ (hook . package-cache))
+ #:local-build? #t)))
(define %channel-profile-hooks
;; The default channel profile hooks.
latest instances of CHANNELS."
(mlet %store-monad ((instances (latest-channel-instances* channels)))
(channel-instances->derivation instances)))
+
+(define (profile-channels profile)
+ "Return the list of channels corresponding to entries in PROFILE. If
+PROFILE is not a profile created by 'guix pull', return the empty list."
+ (filter-map (lambda (entry)
+ (match (assq 'source (manifest-entry-properties entry))
+ (('source ('repository ('version 0)
+ ('url url)
+ ('branch branch)
+ ('commit commit)
+ _ ...))
+ (channel (name (string->symbol
+ (manifest-entry-name entry)))
+ (url url)
+ (commit commit)))
+
+ ;; No channel information for this manifest entry.
+ ;; XXX: Pre-0.15.0 Guix did not provide that information,
+ ;; but there's not much we can do in that case.
+ (_ #f)))
+
+ ;; Show most recently installed packages last.
+ (reverse
+ (manifest-entries (profile-manifest profile)))))
HCoop / jackhill / guix / guix.git / blobdiff