diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/graph.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/home.scm | 524 | ||||
| -rw-r--r-- | guix/scripts/home/import.scm | 243 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 82 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 7 |
5 files changed, 849 insertions, 18 deletions
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 66de824ef4..439fae0b52 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -500,6 +500,10 @@ package modules, while attempting to retain user package modules." (lambda (opt name arg result) (alist-cons 'backend (lookup-backend arg) result))) + (option '(#\M "max-depth") #t #f + (lambda (opt name arg result) + (alist-cons 'max-depth (string->number* arg) + result))) (option '("list-backends") #f #f (lambda (opt name arg result) (list-backends) @@ -538,6 +542,8 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (display (G_ " --list-types list the available graph types")) (display (G_ " + --max-depth=DEPTH limit to nodes within distance DEPTH")) + (display (G_ " --path display the shortest path between the given nodes")) (display (G_ " -e, --expression=EXPR consider the package EXPR evaluates to")) @@ -559,6 +565,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (define %default-options `((node-type . ,%package-node-type) (backend . ,%graphviz-backend) + (max-depth . +inf.0) (system . ,(%current-system)))) @@ -582,6 +589,7 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (with-store store (let* ((transform (options->transformation opts)) + (max-depth (assoc-ref opts 'max-depth)) (items (filter-map (match-lambda (('argument . (? store-path? item)) item) @@ -613,7 +621,8 @@ nodes (given ~a)~%") (export-graph (concatenate nodes) (current-output-port) #:node-type type - #:backend backend))) + #:backend backend + #:max-depth max-depth))) #:system (assq-ref opts 'system))))) #t) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm new file mode 100644 index 0000000000..55e7b436c1 --- /dev/null +++ b/guix/scripts/home.scm @@ -0,0 +1,524 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> +;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts home) + #:use-module (gnu packages admin) + #:use-module ((gnu services) #:hide (delete)) + #:use-module (gnu packages) + #:use-module (gnu home) + #:use-module (gnu home services) + #:use-module (guix channels) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (guix grafts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts system search) + #:autoload (guix scripts pull) (channel-commit-hyperlink) + #:use-module (guix scripts home import) + #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-home)) + + +;;; +;;; Options. +;;; + +(define %user-module + (make-user-module '((gnu home)))) + +(define %guix-home + (string-append %profile-directory "/guix-home")) + +(define (show-help) + (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE] +Build the home environment declared in FILE according to ACTION. +Some ACTIONS support additional ARGS.\n")) + (newline) + (display (G_ "The valid values for ACTION are:\n")) + (newline) + (display (G_ "\ + search search for existing service types\n")) + (display (G_ "\ + reconfigure switch to a new home environment configuration\n")) + (display (G_ "\ + roll-back switch to the previous home environment configuration\n")) + (display (G_ "\ + describe describe the current home environment\n")) + (display (G_ "\ + list-generations list the home environment generations\n")) + (display (G_ "\ + switch-generation switch to an existing home environment configuration\n")) + (display (G_ "\ + delete-generations delete old home environment generations\n")) + (display (G_ "\ + build build the home environment without installing anything\n")) + (display (G_ "\ + import generates a home environment definition from dotfiles\n")) + + (show-build-options-help) + (display (G_ " + -e, --expression=EXPR consider the home-environment EXPR evaluates to + instead of reading FILE, when applicable")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (verbosity-level opts) + "Return the verbosity level based on OPTS, the alist of parsed options." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + %standard-build-options)) + +(define %default-options + `((build-mode . ,(build-mode normal)) + (graft? . #t) + (substitutes? . #t) + (offload? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 3) + (debug . 0))) + + +;;; +;;; Actions. +;;; + +(define* (perform-action action he + #:key + dry-run? + derivations-only? + use-substitutes?) + "Perform ACTION for home environment. " + + (define println + (cut format #t "~a~%" <>)) + + (mlet* %store-monad + ((he-drv (home-environment-derivation he)) + (drvs (mapm/accumulate-builds lower-object (list he-drv))) + (% (if derivations-only? + (return + (for-each (compose println derivation-file-name) drvs)) + (built-derivations drvs))) + + (he-out-path -> (derivation->output-path he-drv))) + (if (or dry-run? derivations-only?) + (return #f) + (begin + (for-each (compose println derivation->output-path) drvs) + + (case action + ((reconfigure) + (let* ((number (generation-number %guix-home)) + (generation (generation-file-name + %guix-home (+ 1 number)))) + + (switch-symlinks generation he-out-path) + (switch-symlinks %guix-home generation) + (setenv "GUIX_NEW_HOME" he-out-path) + (primitive-load (string-append he-out-path "/activate")) + (setenv "GUIX_NEW_HOME" #f) + (return he-out-path))) + (else + (newline) + (return he-out-path))))))) + +(define (process-action action args opts) + "Process ACTION, a sub-command, with the arguments are listed in ARGS. +ACTION must be one of the sub-commands that takes a home environment +declaration as an argument (a file name.) OPTS is the raw alist of options +resulting from command-line parsing." + (define (ensure-home-environment file-or-exp obj) + (ensure-profile-directory) + (unless (home-environment? obj) + (leave (G_ "'~a' does not return a home environment ~%") + file-or-exp)) + obj) + + (let* ((file (match args + (() #f) + ((x . _) x))) + (expr (assoc-ref opts 'expression)) + (system (assoc-ref opts 'system)) + + (transform (lambda (obj) + (home-environment-with-provenance obj file))) + + (home-environment + (transform + (ensure-home-environment + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) + + (dry? (assoc-ref opts 'dry-run?))) + + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) + #:dry-run? + (assoc-ref opts 'dry-run?)) + + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + + (case action + (else + (perform-action action home-environment + #:dry-run? dry? + #:derivations-only? (assoc-ref opts 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?)) + )))))) + (warn-about-disk-space))) + + +(define (process-command command args opts) + "Process COMMAND, one of the 'guix home' sub-commands. ARGS is its +argument list and OPTS is the option alist." + (define-syntax-rule (with-store* store exp ...) + (with-store store + (set-build-options-from-command-line store opts) + exp ...)) + (case command + ;; The following commands do not need to use the store, and they do not need + ;; an home environment file. + ((search) + (apply search args)) + ((import) + (let* ((profiles (delete-duplicates + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) + (manifest (concatenate-manifests + (map profile-manifest profiles)))) + (import-manifest manifest (current-output-port)))) + ((describe) + (match (generation-number %guix-home) + (0 + (error (G_ "no home environment generation, nothing to describe~%"))) + (generation + (display-home-environment-generation generation)))) + ((list-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (list-generations pattern))) + ((switch-generation) + (let ((pattern (match args + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (switch-to-home-environment-generation store pattern)))) + ((roll-back) + (let ((pattern (match args + (() "") + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (roll-back-home-environment store)))) + ((delete-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* + store + (delete-matching-generations store %guix-home pattern)))) + (else (process-action command args opts)))) + +(define-command (guix-home . args) + (synopsis "build and deploy home environments") + + (define (parse-sub-command arg result) + ;; Parse sub-command ARG and augment RESULT accordingly. + (if (assoc-ref result 'action) + (alist-cons 'argument arg result) + (let ((action (string->symbol arg))) + (case action + ((build + reconfigure + extension-graph shepherd-graph + list-generations describe + delete-generations roll-back + switch-generation search + import) + (alist-cons 'action action result)) + (else (leave (G_ "~a: unknown action~%") action)))))) + + (define (match-pair car) + ;; Return a procedure that matches a pair with CAR. + (match-lambda + ((head . tail) + (and (eq? car head) tail)) + (_ #f))) + + (define (option-arguments opts) + ;; Extract the plain arguments from OPTS. + (let* ((args (reverse (filter-map (match-pair 'argument) opts))) + (count (length args)) + (action (assoc-ref opts 'action)) + (expr (assoc-ref opts 'expression))) + (define (fail) + (leave (G_ "wrong number of arguments for action '~a'~%") + action)) + + (unless action + (format (current-error-port) + (G_ "guix home: missing command name~%")) + (format (current-error-port) + (G_ "Try 'guix home --help' for more information.~%")) + (exit 1)) + + (case action + ((build reconfigure) + (unless (or (= count 1) + (and expr (= count 0))) + (fail))) + ((init) + (unless (= count 2) + (fail)))) + args)) + + (with-error-handling + (let* ((opts (parse-command-line args %options + (list %default-options) + #:argument-handler + parse-sub-command)) + (args (option-arguments opts)) + (command (assoc-ref opts 'action))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-verbosity (verbosity-level opts) + (process-command command args opts)))))) + + +;;; +;;; Searching. +;;; + +(define service-type-name* + (compose symbol->string service-type-name)) + +(define (service-type-description-string type) + "Return the rendered and localised description of TYPE, a service type." + (and=> (service-type-description type) + (compose texi->plain-text P_))) + +(define %service-type-metrics + ;; Metrics used to estimate the relevance of a search result. + `((,service-type-name* . 3) + (,service-type-description-string . 2) + (,(lambda (type) + (match (and=> (service-type-location type) location-file) + ((? string? file) + (basename file ".scm")) + (#f + ""))) + . 1))) + +(define (find-service-types regexps) + "Return a list of service type/score pairs: service types whose name or +description matches REGEXPS sorted by relevance, and their score." + (let ((matches (fold-home-service-types + (lambda (type result) + (match (relevance type regexps + %service-type-metrics) + ((? zero?) + result) + (score + (cons (cons type score) result)))) + '()))) + (sort matches + (lambda (m1 m2) + (match m1 + ((type1 . score1) + (match m2 + ((type2 . score2) + (if (= score1 score2) + (string>? (service-type-name* type1) + (service-type-name* type2)) + (> score1 score2)))))))))) + +(define (search . args) + (with-error-handling + (let* ((regexps (map (cut make-regexp* <> regexp/icase) args)) + (matches (find-service-types regexps))) + (leave-on-EPIPE + (display-search-results matches (current-output-port) + #:print service-type->recutils + #:command "guix home search"))))) + + +;;; +;;; Generations. +;;; + +(define* (display-home-environment-generation + number + #:optional (profile %guix-home)) + "Display a summary of home-environment generation NUMBER in a +human-readable format." + (define (display-channel channel) + (format #t " ~a:~%" (channel-name channel)) + (format #t (G_ " repository URL: ~a~%") (channel-url channel)) + (when (channel-branch channel) + (format #t (G_ " branch: ~a~%") (channel-branch channel))) + (format #t (G_ " commit: ~a~%") + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel) + (channel-commit channel)))) + + (unless (zero? number) + (let* ((generation (generation-file-name profile number))) + (define-values (channels config-file) + ;; The function will work for home environments too, we just + ;; need to keep provenance file. + (system-provenance generation)) + + (display-generation profile number) + (format #t (G_ " file name: ~a~%") generation) + (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) + ;; TRANSLATORS: Please preserve the two-space indentation. + + (unless (null? channels) + ;; TRANSLATORS: Here "channel" is the same terminology as used in + ;; "guix describe" and "guix pull --channels". + (format #t (G_ " channels:~%")) + (for-each display-channel channels)) + (when config-file + (format #t (G_ " configuration file: ~a~%") + (if (supports-hyperlinks?) + (file-hyperlink config-file) + config-file)))))) + +(define* (list-generations pattern #:optional (profile %guix-home)) + "Display in a human-readable format all the home environment +generations matching PATTERN, a string. When PATTERN is #f, display +all the home environment generations." + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((not pattern) + (for-each display-home-environment-generation (profile-generations profile))) + ((matching-generations pattern profile) + => + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each display-home-environment-generation numbers))))))) + + +;;; +;;; Switch generations. +;;; + +;; TODO: Make it public in (guix scripts system) +(define-syntax-rule (unless-file-not-found exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (switch-to-home-environment-generation store spec) + "Switch the home-environment profile to the generation specified by +SPEC. STORE is an open connection to the store." + (let* ((number (relative-generation-spec->number %guix-home spec)) + (generation (generation-file-name %guix-home number)) + (activate (string-append generation "/activate"))) + (if number + (begin + (setenv "GUIX_NEW_HOME" (readlink generation)) + (switch-to-generation* %guix-home number) + (unless-file-not-found (primitive-load activate)) + (setenv "GUIX_NEW_HOME" #f)) + (leave (G_ "cannot switch to home environment generation '~a'~%") spec)))) + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-home-environment store) + "Roll back the home-environment profile to its previous generation. +STORE is an open connection to the store." + (switch-to-home-environment-generation store "-1")) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm new file mode 100644 index 0000000000..611f580e85 --- /dev/null +++ b/guix/scripts/home/import.scm @@ -0,0 +1,243 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts home import) + #:use-module (guix profiles) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (import-manifest)) + +;;; Commentary: +;;; +;;; This module provides utilities for generating home service +;;; configurations from existing "dotfiles". +;;; +;;; Code: + + +(define (generate-bash-module+configuration) + (let ((rc (string-append (getenv "HOME") "/.bashrc")) + (profile (string-append (getenv "HOME") "/.bash_profile")) + (logout (string-append (getenv "HOME") "/.bash_logout"))) + `((gnu home services bash) + (service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((bashrc + (list (local-file ,rc)))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (local-file ,profile)))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (local-file ,logout)))) + '())))))) + + +(define %files-configurations-alist + `((".bashrc" . ,generate-bash-module+configuration) + (".bash_profile" . ,generate-bash-module+configuration) + (".bash_logout" . ,generate-bash-module+configuration))) + +(define (modules+configurations) + (let ((configurations (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (if (file-exists? + (string-append (getenv "HOME") "/" file)) + proc + #f))) + %files-configurations-alist) + (lambda (x y) + (equal? (procedure-name x) (procedure-name y)))))) + (map (lambda (proc) (proc)) configurations))) + +;; Based on `manifest->code' from (guix profiles) +;; MAYBE: Upstream it? +(define* (manifest->code manifest + #:key + (entry-package-version (const "")) + (home-environment? #f)) + "Return an sexp representing code to build an approximate version of +MANIFEST; the code is wrapped in a top-level 'begin' form. If +HOME-ENVIRONMENT? is #t, return an <home-environment> definition. +Call ENTRY-PACKAGE-VERSION to determine the version number to use in +the spec for a given entry; it can be set to 'manifest-entry-version' +for fully-specified version numbers, or to some other procedure to +disambiguate versions for packages for which several versions are +available." + (define (entry-transformations entry) + ;; Return the transformations that apply to ENTRY. + (assoc-ref (manifest-entry-properties entry) 'transformations)) + + (define transformation-procedures + ;; List of transformation options/procedure name pairs. + (let loop ((entries (manifest-entries manifest)) + (counter 1) + (result '())) + (match entries + (() result) + ((entry . tail) + (match (entry-transformations entry) + (#f + (loop tail counter result)) + (options + (if (assoc-ref result options) + (loop tail counter result) + (loop tail (+ 1 counter) + (alist-cons options + (string->symbol + (format #f "transform~a" counter)) + result))))))))) + + (define (qualified-name entry) + ;; Return the name of ENTRY possibly with "@" followed by a version. + (match (entry-package-version entry) + ("" (manifest-entry-name entry)) + (version (string-append (manifest-entry-name entry) + "@" version)))) + + (if (null? transformation-procedures) + (let ((specs (map (lambda (entry) + (match (manifest-entry-output entry) + ("out" (qualified-name entry)) + (output (string-append (qualified-name entry) + ":" output)))) + (manifest-entries manifest)))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + ,(home-environment-template + #:specs specs + #:services (map second modules+configurations)))) + `(begin + (use-modules (gnu packages)) + + (specifications->manifest + (list ,@specs))))) + (let* ((transform (lambda (options exp) + (if (not options) + exp + (let ((proc (assoc-ref transformation-procedures + options))) + `(,proc ,exp))))) + (packages (map (lambda (entry) + (define options + (entry-transformations entry)) + + (define name + (qualified-name entry)) + + (match (manifest-entry-output entry) + ("out" + (transform options + `(specification->package ,name))) + (output + `(list ,(transform + options + `(specification->package ,name)) + ,output)))) + (manifest-entries manifest))) + (transformations (map (match-lambda + ((options . name) + `(define ,name + (options->transformation ',options)))) + transformation-procedures))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (guix transformations) + (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + + ,@transformations + + ,(home-environment-template + #:packages packages + #:services (map second modules+configurations)))) + `(begin + (use-modules (guix transformations) + (gnu packages)) + + ,@transformations + + (packages->manifest + (list ,@packages))))))) + +(define* (home-environment-template #:key (packages #f) (specs #f) services) + "Return an S-exp containing a <home-environment> declaration +containing PACKAGES, or SPECS (package specifications), and SERVICES." + `(home-environment + (packages + ,@(if packages + `((list ,@packages)) + `((map specification->package + (list ,@specs))))) + (services (list ,@services)))) + +(define* (import-manifest + manifest + #:optional (port (current-output-port))) + "Write to PORT a <home-environment> corresponding to MANIFEST." + (define (version-spec entry) + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + + (match (manifest->code manifest + #:entry-package-version version-spec + #:home-environment? #t) + (('begin exp ...) + (format port (G_ "\ +;; This \"home-environment\" file can be passed to 'guix home reconfigure' +;; to reproduce the content of your profile. This is \"symbolic\": it only +;; specifies package names. To reproduce the exact same profile, you also +;; need to capture the channels being used, as returned by \"guix describe\". +;; See the \"Replicating Guix\" section in the manual.\n")) + (for-each (lambda (exp) + (newline port) + (pretty-print exp port)) + exp)))) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 25846b7dc2..6e2b4368da 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -25,6 +25,7 @@ #:use-module ((system repl server) #:prefix repl:) #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) + #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 poll) #:use-module (ice-9 regex) @@ -400,15 +401,18 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." (let ((store-path (hash-part->path store hash))) (if (string-null? store-path) (not-found request #:phrase "" #:ttl negative-ttl) - (values `((content-type . (application/x-nix-narinfo)) + (values `((content-type . (application/x-nix-narinfo + (charset . "UTF-8"))) + (x-nar-path . ,nar-path) + (x-narinfo-compressions . ,compressions) ,@(if ttl `((cache-control (max-age . ,ttl))) '())) - (cut display - (narinfo-string store store-path - #:nar-path nar-path - #:compressions compressions) - <>))))) + ;; Do not call narinfo-string directly here as it is an + ;; expensive call that could potentially block the main + ;; thread. Instead, create the narinfo string in the + ;; http-write procedure. + store-path)))) (define* (nar-cache-file directory item #:key (compression %no-compression)) @@ -663,19 +667,38 @@ requested using POOL." (link narinfo other))) others)))))) +(define (compression->sexp compression) + "Return the SEXP representation of COMPRESSION." + (match compression + (($ <compression> type level) + `(compression ,type ,level)))) + +(define (sexp->compression sexp) + "Turn the given SEXP into a <compression> record and return it." + (match sexp + (('compression type level) + (compression type level)))) + ;; XXX: Declare the 'X-Nar-Compression' HTTP header, which is in fact for ;; internal consumption: it allows us to pass the compression info to ;; 'http-write', as part of the workaround to <http://bugs.gnu.org/21093>. (declare-header! "X-Nar-Compression" (lambda (str) - (match (call-with-input-string str read) - (('compression type level) - (compression type level)))) + (sexp->compression + (call-with-input-string str read))) compression? (lambda (compression port) - (match compression - (($ <compression> type level) - (write `(compression ,type ,level) port))))) + (write (compression->sexp compression) port))) + +;; This header is used to pass the supported compressions to http-write in +;; order to format on-the-fly narinfo responses. +(declare-header! "X-Narinfo-Compressions" + (lambda (str) + (map sexp->compression + (call-with-input-string str read))) + (cut every compression? <>) + (lambda (compressions port) + (write (map compression->sexp compressions) port))) (define* (render-nar store request store-item #:key (compression %no-compression)) @@ -830,7 +853,8 @@ example: \"/foo/bar\" yields '(\"foo\" \"bar\")." "Return RESPONSE's headers minus 'Content-Length' and our internal headers." (fold alist-delete (response-headers response) - '(content-length x-raw-file x-nar-compression))) + '(content-length x-raw-file x-nar-compression + x-narinfo-compressions x-nar-path))) (define (sans-content-length response) "Return RESPONSE without its 'content-length' header." @@ -964,6 +988,38 @@ blocking." (unless keep-alive? (close-port client))) (values)))))) + (('application/x-nix-narinfo . _) + (let ((compressions (assoc-ref (response-headers response) + 'x-narinfo-compressions)) + (nar-path (assoc-ref (response-headers response) + 'x-nar-path))) + (if nar-path + (begin + (when (keep-alive? response) + (keep-alive client)) + (call-with-new-thread + (lambda () + (set-thread-name "publish narinfo") + (let* ((narinfo + (with-store store + (narinfo-string store (utf8->string body) + #:nar-path nar-path + #:compressions compressions))) + (narinfo-bv (string->bytevector narinfo "UTF-8")) + (narinfo-length + (bytevector-length narinfo-bv)) + (response (write-response + (with-content-length response + narinfo-length) + client)) + (output (response-port response))) + (configure-socket client) + (put-bytevector output narinfo-bv) + (force-output output) + (unless (keep-alive? response) + (close-port output)) + (values))))) + (%http-write server client response body)))) (_ (match (assoc-ref (response-headers response) 'x-raw-file) ((? string? file) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 65eb98e4b2..7faa92fd7d 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -64,6 +64,7 @@ (device-module-aliases matching-modules) #:use-module (gnu system linux-initrd) #:use-module (gnu image) + #:use-module (gnu platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -253,7 +254,7 @@ the ownership of '~a' may be incorrect!~%") (install-bootloader local-eval bootloader bootcfg #:target target) (return - (info (G_ "bootloader successfully installed on '~a'~%") + (info (G_ "bootloader successfully installed on~{ ~a~}~%") (bootloader-configuration-targets bootloader)))))))) @@ -1212,13 +1213,11 @@ resulting from command-line parsing." (base-image (if (operating-system? obj) (os->image obj #:type image-type) - obj)) - (base-target (image-target base-image))) + obj))) (image (inherit (if label (image-with-label base-image label) base-image)) - (target (or base-target target)) (size image-size) (volatile-root? volatile?)))) (os (image-operating-system image)) |