From 63fd9f084a5e345d2edaeaf5e8f435a3130f9edc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 Nov 2018 19:38:55 +0100 Subject: ssh: Make 'send-files' more robust. Possibly fixes . * guix/ssh.scm (send-files): Call 'channel-get-exit-status' only when RESULT is true. --- guix/ssh.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 25ec8295e8..104f4f52d6 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -297,9 +297,11 @@ Return the list of store items actually sent." (channel-send-eof port) ;; Wait for completion of the remote process and read the status sexp from - ;; PORT. + ;; PORT. Wait for the exit status only when 'read' completed; otherwise, + ;; we might wait forever if the other end is stuck. (let* ((result (false-if-exception (read port))) - (status (zero? (channel-get-exit-status port)))) + (status (and result + (zero? (channel-get-exit-status port))))) (close-port port) (match result (('success . _) -- cgit v1.2.3 From 3b5829bbcb7ea3a76a4d2393f0b2cbfb6d1a5e37 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 11:06:21 +0100 Subject: git-download: Use 'git-minimal' instead of 'git'. * guix/git-download.scm (git-package): Refer to 'git-minimal'. --- guix/git-download.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index fa94fad8f8..072ab51538 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -60,7 +60,7 @@ (define (git-package) "Return the default Git package." (let ((distro (resolve-interface '(gnu packages version-control)))) - (module-ref distro 'git))) + (module-ref distro 'git-minimal))) (define* (git-fetch ref hash-algo hash #:optional name -- cgit v1.2.3 From de2bfe902936e3f7abfd4b55ad1149f75c5818b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Nov 2018 15:40:21 +0100 Subject: Add (guix swh). * guix/swh.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/swh.scm | 551 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 552 insertions(+) create mode 100644 guix/swh.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 69e66fad75..c5676b0b94 100644 --- a/Makefile.am +++ b/Makefile.am @@ -75,6 +75,7 @@ MODULES = \ guix/discovery.scm \ guix/git-download.scm \ guix/hg-download.scm \ + guix/swh.scm \ guix/monads.scm \ guix/monad-repl.scm \ guix/gexp.scm \ diff --git a/guix/swh.scm b/guix/swh.scm new file mode 100644 index 0000000000..c188e17c69 --- /dev/null +++ b/guix/swh.scm @@ -0,0 +1,551 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix swh) + #:use-module (guix base16) + #:use-module (guix build utils) + #:use-module ((guix build syscalls) #:select (mkdtemp!)) + #:use-module (web client) + #:use-module (web response) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 popen) + #:use-module ((ice-9 ftw) #:select (scandir)) + #:export (origin? + origin-id + origin-type + origin-url + origin-visits + lookup-origin + + visit? + visit-date + visit-origin + visit-url + visit-snapshot-url + visit-status + visit-number + visit-snapshot + + branch? + branch-name + branch-target + + release? + release-id + release-name + release-message + release-target + + revision? + revision-id + revision-date + revision-directory + lookup-revision + lookup-origin-revision + + content? + content-checksums + content-data-url + content-length + lookup-content + + directory-entry? + directory-entry-name + directory-entry-type + directory-entry-checksums + directory-entry-length + directory-entry-permissions + lookup-directory + directory-entry-target + + vault-reply? + vault-reply-id + vault-reply-fetch-url + vault-reply-object-id + vault-reply-object-type + vault-reply-progress-message + vault-reply-status + query-vault + request-cooking + vault-fetch + + swh-download)) + +;;; Commentary: +;;; +;;; This module provides bindings to the HTTP interface of Software Heritage. +;;; It allows you to browse the archive, look up revisions (such as SHA1 +;;; commit IDs), "origins" (code hosting URLs), content (files), etc. See +;;; for more information. +;;; +;;; The high-level 'swh-download' procedure allows you to download a Git +;;; revision from Software Heritage, provided it is available. +;;; +;;; Code: + +(define %swh-base-url + ;; Presumably we won't need to change it. + "https://archive.softwareheritage.org") + +(define (swh-url path . rest) + (define url + (string-append %swh-base-url path + (string-join rest "/" 'prefix))) + + ;; Ensure there's a trailing slash or we get a redirect. + (if (string-suffix? "/" url) + url + (string-append url "/"))) + +(define-syntax-rule (define-json-reader json->record ctor spec ...) + "Define JSON->RECORD as a procedure that converts a JSON representation, +read from a port, string, or hash table, into a record created by CTOR and +following SPEC, a series of field specifications." + (define (json->record input) + (let ((table (cond ((port? input) + (json->scm input)) + ((string? input) + (json-string->scm input)) + ((hash-table? input) + input)))) + (let-syntax ((extract-field (syntax-rules () + ((_ table (field key json->value)) + (json->value (hash-ref table key))) + ((_ table (field key)) + (hash-ref table key)) + ((_ table (field)) + (hash-ref table + (symbol->string 'field)))))) + (ctor (extract-field table spec) ...))))) + +(define-syntax-rule (define-json-mapping rtd ctor pred json->record + (field getter spec ...) ...) + "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, +and define JSON->RECORD as a conversion from JSON to a record of this type." + (begin + (define-record-type rtd + (ctor field ...) + pred + (field getter) ...) + + (define-json-reader json->record ctor + (field spec ...) ...))) + +(define %date-regexp + ;; Match strings like "2014-11-17T22:09:38+01:00" or + ;; "2018-09-30T23:20:07.815449+00:00"". + (make-regexp "^([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})((\\.[0-9]+)?)([+-][0-9]{2}):([0-9]{2})$")) + +(define (string->date* str) + "Return a SRFI-19 date parsed from STR, a date string as returned by +Software Heritage." + ;; We can't use 'string->date' because of the timezone format: SWH returns + ;; "+01:00" when the '~z' template expects "+0100". So we roll our own! + (or (and=> (regexp-exec %date-regexp str) + (lambda (match) + (define (ref n) + (string->number (match:substring match n))) + + (make-date (let ((ns (match:substring match 8))) + (if ns + (string->number (string-drop ns 1)) + 0)) + (ref 6) (ref 5) (ref 4) + (ref 3) (ref 2) (ref 1) + (+ (* 3600 (ref 9)) ;time zone + (if (< (ref 9) 0) + (- (ref 10)) + (ref 10)))))) + str)) ;oops! + +(define* (call url decode #:optional (method http-get) + #:key (false-if-404? #t)) + "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body +using DECODE, a one-argument procedure that takes an input port. When +FALSE-IF-404? is true, return #f upon 404 responses." + (let*-values (((response port) + (method url #:streaming? #t))) + ;; See . + (match (assq-ref (response-headers response) 'x-ratelimit-remaining) + (#f #t) + ((? (compose zero? string->number)) + (throw 'swh-error url response)) + (_ #t)) + + (cond ((= 200 (response-code response)) + (let ((result (decode port))) + (close-port port) + result)) + ((and false-if-404? + (= 404 (response-code response))) + (close-port port) + #f) + (else + (close-port port) + (throw 'swh-error url response))))) + +(define-syntax define-query + (syntax-rules (path) + "Define a procedure that performs a Software Heritage query." + ((_ (name args ...) docstring (path components ...) + json->value) + (define (name args ...) + docstring + (call (swh-url components ...) json->value))))) + +;; +(define-json-mapping make-origin origin? + json->origin + (id origin-id) + (visits-url origin-visits-url "origin_visits_url") + (type origin-type) + (url origin-url)) + +;; +(define-json-mapping make-visit visit? + json->visit + (date visit-date "date" string->date*) + (origin visit-origin) + (url visit-url "origin_visit_url") + (snapshot-url visit-snapshot-url "snapshot_url") + (status visit-status) + (number visit-number "visit")) + +;; +(define-json-mapping make-snapshot snapshot? + json->snapshot + (branches snapshot-branches "branches" json->branches)) + +;; This is used for the "branches" field of snapshots. +(define-record-type + (make-branch name target-type target-url) + branch? + (name branch-name) + (target-type branch-target-type) ;release | revision + (target-url branch-target-url)) + +(define (json->branches branches) + (hash-map->list (lambda (key value) + (make-branch key + (string->symbol + (hash-ref value "target_type")) + (hash-ref value "target_url"))) + branches)) + +;; +(define-json-mapping make-release release? + json->release + (id release-id) + (name release-name) + (message release-message) + (target-type release-target-type "target_type" string->symbol) + (target-url release-target-url "target_url")) + +;; +(define-json-mapping make-revision revision? + json->revision + (id revision-id) + (date revision-date "date" string->date*) + (directory revision-directory) + (directory-url revision-directory-url "directory_url")) + +;; +(define-json-mapping make-content content? + json->content + (checksums content-checksums "checksums" json->checksums) + (data-url content-data-url "data_url") + (file-type-url content-file-type-url "filetype_url") + (language-url content-language-url "language_url") + (length content-length) + (license-url content-license-url "license_url")) + +(define (json->checksums checksums) + (hash-map->list (lambda (key value) + (cons key (base16-string->bytevector value))) + checksums)) + +;; +(define-json-mapping make-directory-entry directory-entry? + json->directory-entry + (name directory-entry-name) + (type directory-entry-type "type" + (match-lambda + ("dir" 'directory) + (str (string->symbol str)))) + (checksums directory-entry-checksums "checksums" + (match-lambda + (#f #f) + (lst (json->checksums lst)))) + (id directory-entry-id "dir_id") + (length directory-entry-length) + (permissions directory-entry-permissions "perms") + (target-url directory-entry-target-url "target_url")) + +;; +(define-json-mapping make-save-reply save-reply? + json->save-reply + (origin-url save-reply-origin-url "origin_url") + (origin-type save-reply-origin-type "origin_type") + (request-date save-reply-request-date "save_request_date" + string->date*) + (request-status save-reply-request-status "save_request_status" + string->symbol) + (task-status save-reply-task-status "save_task_status" + (match-lambda + ("not created" 'not-created) + ((? string? str) (string->symbol str))))) + +;; +(define-json-mapping make-vault-reply vault-reply? + json->vault-reply + (id vault-reply-id) + (fetch-url vault-reply-fetch-url "fetch_url") + (object-id vault-reply-object-id "obj_id") + (object-type vault-reply-object-type "obj_type" string->symbol) + (progress-message vault-reply-progress-message "progress_message") + (status vault-reply-status "status" string->symbol)) + + +;;; +;;; RPCs. +;;; + +(define-query (lookup-origin url) + "Return an origin for URL." + (path "/api/1/origin/git/url" url) + json->origin) + +(define-query (lookup-content hash type) + "Return a content for HASH, of the given TYPE--e.g., \"sha256\"." + (path "/api/1/content" + (string-append type ":" + (bytevector->base16-string hash))) + json->content) + +(define-query (lookup-revision id) + "Return the revision with the given ID, typically a Git commit SHA1." + (path "/api/1/revision" id) + json->revision) + +(define-query (lookup-directory id) + "Return the directory with the given ID." + (path "/api/1/directory" id) + json->directory-entries) + +(define (json->directory-entries port) + (map json->directory-entry (json->scm port))) + +(define (origin-visits origin) + "Return the list of visits of ORIGIN, a record as returned by +'lookup-origin'." + (call (swh-url (origin-visits-url origin)) + (lambda (port) + (map json->visit (json->scm port))))) + +(define (visit-snapshot visit) + "Return the snapshot corresponding to VISIT." + (call (swh-url (visit-snapshot-url visit)) + json->snapshot)) + +(define (branch-target branch) + "Return the target of BRANCH, either a or a ." + (match (branch-target-type branch) + ('release + (call (swh-url (branch-target-url branch)) + json->release)) + ('revision + (call (swh-url (branch-target-url branch)) + json->revision)))) + +(define (lookup-origin-revision url tag) + "Return a corresponding to the given TAG for the repository +coming from URL. Example: + + (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\") + => #< id: \"44941…\" …> + +The information is based on the latest visit of URL available. Return #f if +URL could not be found." + (match (lookup-origin url) + (#f #f) + (origin + (match (origin-visits origin) + ((visit . _) + (let ((snapshot (visit-snapshot visit))) + (match (and=> (find (lambda (branch) + (string=? (string-append "refs/tags/" tag) + (branch-name branch))) + (snapshot-branches snapshot)) + branch-target) + ((? release? release) + (release-target release)) + ((? revision? revision) + revision) + (#f ;tag not found + #f)))) + (() + #f))))) + +(define (release-target release) + "Return the revision that is the target of RELEASE." + (match (release-target-type release) + ('revision + (call (swh-url (release-target-url release)) + json->revision)))) + +(define (directory-entry-target entry) + "If ENTRY, a directory entry, has type 'directory, return its list of +directory entries; if it has type 'file, return its object." + (call (swh-url (directory-entry-target-url entry)) + (match (directory-entry-type entry) + ('file json->content) + ('directory json->directory-entries)))) + +(define* (save-origin url #:optional (type "git")) + "Request URL to be saved." + (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply + http-post)) + +(define-query (save-origin-status url type) + "Return the status of a /save request for URL and TYPE (e.g., \"git\")." + (path "/api/1/origin/save" type "url" url) + json->save-reply) + +(define-query (query-vault id kind) + "Ask the availability of object ID and KIND to the vault, where KIND is +'directory or 'revision. Return #f if it could not be found, or a + on success." + ;; + ;; There's a single format supported for directories and revisions and for + ;; now, the "/format" bit of the URL *must* be omitted. + (path "/api/1/vault" (symbol->string kind) id) + json->vault-reply) + +(define (request-cooking id kind) + "Request the cooking of object ID and KIND (one of 'directory or 'revision) +to the vault. Return a ." + (call (swh-url "/api/1/vault" (symbol->string kind) id) + json->vault-reply + http-post)) + +(define* (vault-fetch id kind + #:key (log-port (current-error-port))) + "Return an input port from which a bundle of the object with the given ID +and KIND (one of 'directory or 'revision) can be retrieved, or #f if the +object could not be found. + +For a directory, the returned stream is a gzip-compressed tarball. For a +revision, it is a gzip-compressed stream for 'git fast-import'." + (let loop ((reply (query-vault id kind))) + (match reply + (#f + (and=> (request-cooking id kind) loop)) + (_ + (match (vault-reply-status reply) + ('done + ;; Fetch the bundle. + (let-values (((response port) + (http-get (swh-url (vault-reply-fetch-url reply)) + #:streaming? #t))) + (if (= (response-code response) 200) + port + (begin ;shouldn't happen + (close-port port) + #f)))) + ('failed + ;; Upon failure, we're supposed to try again. + (format log-port "SWH vault: failure: ~a~%" + (vault-reply-progress-message reply)) + (format log-port "SWH vault: retrying...~%") + (loop (request-cooking id kind))) + ((and (or 'new 'pending) status) + ;; Wait until the bundle shows up. + (let ((message (vault-reply-progress-message reply))) + (when (eq? 'new status) + (format log-port "SWH vault: \ +requested bundle cooking, waiting for completion...~%")) + (when (string? message) + (format log-port "SWH vault: ~a~%" message)) + + ;; Wait long enough so we don't exhaust our maximum number of + ;; requests per hour too fast (as of this writing, the limit is 60 + ;; requests per hour per IP address.) + (sleep (if (eq? status 'new) 60 30)) + + (loop (query-vault id kind))))))))) + + +;;; +;;; High-level interface. +;;; + +(define (commit-id? reference) + "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if +it is a tag name." + (and (= (string-length reference) 40) + (string-every char-set:hex-digit reference))) + +(define (call-with-temporary-directory proc) ;FIXME: factorize + "Call PROC with a name of a temporary directory; close the directory and +delete it when leaving the dynamic extent of this call." + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-directory.XXXXXX")) + (tmp-dir (mkdtemp! template))) + (dynamic-wind + (const #t) + (lambda () + (proc tmp-dir)) + (lambda () + (false-if-exception (delete-file-recursively tmp-dir)))))) + +(define (swh-download url reference output) + "Download from Software Heritage a checkout of the Git tag or commit +REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success +and #f on failure. + +This procedure uses the \"vault\", which contains \"cooked\" directories in +the form of tarballs. If the requested directory is not cooked yet, it will +wait until it becomes available, which could take several minutes." + (match (if (commit-id? reference) + (lookup-revision reference) + (lookup-origin-revision url reference)) + ((? revision? revision) + (call-with-temporary-directory + (lambda (directory) + (let ((input (vault-fetch (revision-directory revision) 'directory)) + (tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-"))) + (dump-port input tar) + (close-port input) + (let ((status (close-pipe tar))) + (unless (zero? status) + (error "tar extraction failure" status))) + + (match (scandir directory) + (("." ".." sub-directory) + (copy-recursively (string-append directory "/" sub-directory) + output + #:log (%make-void-port "w")) + #t)))))) + (#f + #f))) -- cgit v1.2.3 From 608d3dca89d73fe7260e97a284a8aeea756a3e11 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Nov 2018 15:46:50 +0100 Subject: git-download: Download from Software Heritage as a last resort. * guix/git-download.scm (git-fetch)[inputs]: Add gzip and tar when 'git-reference-recursive?' is false. [guile-json, gnutls]: New variables. [modules]: Add (guix swh). [build]: Wrap in 'with-extensions'. Add call to 'swh-download'. --- guix/git-download.scm | 68 ++++++++++++++++++++++++++++++++++----------------- 1 file changed, 46 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/git-download.scm b/guix/git-download.scm index 072ab51538..6cf267d6c8 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -74,11 +74,22 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; available so that 'git submodule' works. (if (git-reference-recursive? ref) (standard-packages) - '())) + + ;; The 'swh-download' procedure requires tar and gzip. + `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) + 'gzip)) + ("tar" ,(module-ref (resolve-interface '(gnu packages base)) + 'tar))))) (define zlib (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + (define guile-json + (module-ref (resolve-interface '(gnu packages guile)) 'guile-json)) + + (define gnutls + (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + (define config.scm (scheme-file "config.scm" #~(begin @@ -93,30 +104,43 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (delete '(guix config) (source-module-closure '((guix build git) (guix build utils) - (guix build download-nar)))))) + (guix build download-nar) + (guix swh)))))) (define build (with-imported-modules modules - #~(begin - (use-modules (guix build git) - (guix build utils) - (guix build download-nar) - (ice-9 match)) - - ;; The 'git submodule' commands expects Coreutils, sed, - ;; grep, etc. to be in $PATH. - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) - - (or (git-fetch (getenv "git url") (getenv "git commit") - #$output - #:recursive? (call-with-input-string - (getenv "git recursive?") - read) - #:git-command (string-append #+git "/bin/git")) - (download-nar #$output))))) + (with-extensions (list guile-json gnutls) ;for (guix swh) + #~(begin + (use-modules (guix build git) + (guix build utils) + (guix build download-nar) + (guix swh) + (ice-9 match)) + + (define recursive? + (call-with-input-string (getenv "git recursive?") read)) + + ;; The 'git submodule' commands expects Coreutils, sed, + ;; grep, etc. to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (or (git-fetch (getenv "git url") (getenv "git commit") + #$output + #:recursive? recursive? + #:git-command (string-append #+git "/bin/git")) + (download-nar #$output) + + ;; As a last resort, attempt to download from Software Heritage. + ;; XXX: Currently recursive checkouts are not supported. + (and (not recursive?) + (swh-download (getenv "git url") (getenv "git commit") + #$output))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build -- cgit v1.2.3 From 3133d678a8e13aee1c432272e6fd82bc57f6e95e Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Thu, 22 Nov 2018 03:06:51 +0300 Subject: repl: Do not exit repl on SIGINT. * guix/scripts/repl.scm (guix-repl): Do not exit repl on SIGINT. --- guix/scripts/repl.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index b157833a49..1a105f51ee 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -188,7 +188,10 @@ call THUNK." (save-module-excursion (lambda () (set-current-module user-module) - (start-repl)))) + ;; Do not exit repl on SIGINT. + ((@@ (ice-9 top-repl) call-with-sigint) + (lambda () + (start-repl)))))) ((machine) (machine-repl)) (else -- cgit v1.2.3 From ee6b3bb60d145690a35a8069cf8168d072f04730 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Nov 2018 10:11:52 +0100 Subject: swh: Export 'save-origin' and related bindings. * guix/swh.scm: Export bindings related to 'save-origin'. --- guix/swh.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index c188e17c69..89cddb2bdd 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -79,6 +79,15 @@ lookup-directory directory-entry-target + save-reply? + save-reply-origin-url + save-reply-origin-type + save-reply-request-date + save-reply-request-status + save-reply-task-status + save-origin + save-origin-status + vault-reply? vault-reply-id vault-reply-fetch-url -- cgit v1.2.3 From 01262f1ece37d5ae9af56c1de6c4eefc758f35ba Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Wed, 21 Nov 2018 17:21:22 +0300 Subject: describe: Delete 'directory' argument from 'display-checkout-info'. This commit follows 1255400faabfcf0ca1666d17f2f34ea0d49f6b1f. * guix/scripts/describe.scm (display-checkout-info): Delete 'directory' argument. --- guix/scripts/describe.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 98be4ee89f..f21311af09 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -103,11 +103,11 @@ Display information about the channels currently in use.\n")) (format port "url: ~a~%" (channel-url channel)) (format port "commit: ~a~%" (channel-commit channel))) -(define* (display-checkout-info fmt #:optional directory) +(define (display-checkout-info fmt) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie within a Git checkout." - (let* ((program (or directory (car (command-line)))) + (let* ((program (car (command-line))) (directory (catch 'git-error (lambda () (repository-discover (dirname program))) -- cgit v1.2.3 From db08ea40873ae20507bc40d34a56dea1b8ce8f0e Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Tue, 6 Nov 2018 11:50:48 +0200 Subject: pack: List the available formats. * guix/scripts/pack.scm (show-formats): New variable. (%options, show-help): Add 'list-formats' option. --- guix/scripts/pack.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index ce46f549cc..98b06971bd 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich +;;; Copyright © 2018 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -609,6 +610,18 @@ please email '~a'~%") (squashfs . ,squashfs-image) (docker . ,docker-image))) +(define (show-formats) + ;; Print the supported pack formats. + (display (G_ "The supported formats for 'guix pack' are:")) + (newline) + (display (G_ " + tarball Self-contained tarball, ready to run on another machine")) + (display (G_ " + squashfs Squashfs image suitable for Singularity")) + (display (G_ " + docker Tarball ready for 'docker load'")) + (newline)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -625,6 +638,10 @@ please email '~a'~%") (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) + (option '("list-formats") #f #f + (lambda args + (show-formats) + (exit 0))) (option '(#\R "relocatable") #f #f (lambda (opt name arg result) (alist-cons 'relocatable? #t result))) @@ -686,6 +703,8 @@ Create a bundle of PACKAGE.\n")) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) + (display (G_ " + --list-formats list the formats available")) (display (G_ " -R, --relocatable produce relocatable executables")) (display (G_ " -- cgit v1.2.3 From 8856f409d13cd7376be4319b9f75df0692c009d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:14:11 +0100 Subject: derivations: Add properties. * guix/derivations.scm (derivation): Add #:properties parameter. [user+system-env-vars]: Honor it. (derivation-properties): New procedure. (build-expression->derivation): Add #:properties and pass it to 'derivation'. * guix/gexp.scm (gexp->derivation): Likewise. * tests/derivations.scm ("derivation-properties"): New test. * tests/gexp.scm ("gexp->derivation properties"): New test. * doc/guix.texi (Derivations, G-Expressions): Adjust accordingly. --- doc/guix.texi | 8 ++++++-- guix/derivations.scm | 30 +++++++++++++++++++++++++----- guix/gexp.scm | 4 +++- tests/derivations.scm | 10 ++++++++++ tests/gexp.scm | 10 +++++++++- 5 files changed, 53 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 917a3e9d57..c040a8531a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5060,7 +5060,7 @@ a derivation is the @code{derivation} procedure: [#:system (%current-system)] [#:references-graphs #f] @ [#:allowed-references #f] [#:disallowed-references #f] @ [#:leaked-env-vars #f] [#:local-build? #f] @ - [#:substitutable? #t] + [#:substitutable? #t] [#:properties '()] Build a derivation with the given arguments, and return the resulting @code{} object. @@ -5097,6 +5097,9 @@ When @var{substitutable?} is false, declare that substitutes of the derivation's output should not be used (@pxref{Substitutes}). This is useful, for instance, when building packages that capture details of the host CPU instruction set. + +@var{properties} must be an association list describing ``properties'' of the +derivation. It is kept as-is, uninterpreted, in the derivation. @end deffn @noindent @@ -5790,7 +5793,8 @@ information about monads.) [#:leaked-env-vars #f] @ [#:script-name (string-append @var{name} "-builder")] @ [#:deprecation-warnings #f] @ - [#:local-build? #f] [#:substitutable? #t] [#:guile-for-build #f] + [#:local-build? #f] [#:substitutable? #t] @ + [#:properties '()] [#:guile-for-build #f] Return a derivation @var{name} that runs @var{exp} (a gexp) with @var{guile-for-build} (a derivation) on @var{system}; @var{exp} is stored in a file called @var{script-name}. When @var{target} is true, diff --git a/guix/derivations.scm b/guix/derivations.scm index 7afecb10cc..f6176a78fd 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -80,6 +80,7 @@ substitutable-derivation? substitution-oracle derivation-hash + derivation-properties read-derivation read-derivation-from-file @@ -681,7 +682,8 @@ name of each input with that input's hash." references-graphs allowed-references disallowed-references leaked-env-vars local-build? - (substitutable? #t)) + (substitutable? #t) + (properties '())) "Build a derivation with the given arguments, and return the resulting object. When HASH and HASH-ALGO are given, a fixed-output derivation is created---i.e., one whose result is known in @@ -708,7 +710,10 @@ for offloading and should rather be built locally. This is the case for small derivations where the costs of data transfers would outweigh the benefits. When SUBSTITUTABLE? is false, declare that substitutes of the derivation's -output should not be used." +output should not be used. + +PROPERTIES must be an association list describing \"properties\" of the +derivation. It is kept as-is, uninterpreted, in the derivation." (define (add-output-paths drv) ;; Return DRV with an actual store path for each of its output and the ;; corresponding environment variable. @@ -763,6 +768,10 @@ output should not be used." `(("impureEnvVars" . ,(string-join leaked-env-vars))) '()) + ,@(match properties + (() '()) + (lst `(("guix properties" + . ,(object->string properties))))) ,@env-vars))) (match references-graphs (((file . path) ...) @@ -851,6 +860,14 @@ long-running processes that know what they're doing. Use with care!" (invalidate-memoization! derivation-path->base16-hash) (hash-clear! %derivation-cache)) +(define derivation-properties + (mlambdaq (drv) + "Return the property alist associated with DRV." + (match (assoc "guix properties" + (derivation-builder-environment-vars drv)) + ((_ . str) (call-with-input-string str read)) + (#f '())))) + (define* (map-derivation store drv mapping #:key (system (%current-system))) "Given MAPPING, a list of pairs of derivations, return a derivation based on @@ -1129,7 +1146,8 @@ they can refer to each other." references-graphs allowed-references disallowed-references - local-build? (substitutable? #t)) + local-build? (substitutable? #t) + (properties '())) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list @@ -1149,7 +1167,8 @@ EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. See the `derivation' procedure for the meaning of REFERENCES-GRAPHS, -ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." +ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, SUBSTITUTABLE?, +and PROPERTIES." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1277,7 +1296,8 @@ ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." #:allowed-references allowed-references #:disallowed-references disallowed-references #:local-build? local-build? - #:substitutable? substitutable?))) + #:substitutable? substitutable? + #:properties properties))) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index f33fb198e4..786e378308 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -631,6 +631,7 @@ names and file names suitable for the #:allowed-references argument to allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) + (properties '()) ;; TODO: This parameter is transitional; it's here ;; to avoid a full rebuild. Remove it on the next @@ -800,7 +801,8 @@ The other arguments are as for 'derivation'." #:disallowed-references disallowed #:leaked-env-vars leaked-env-vars #:local-build? local-build? - #:substitutable? substitutable?)))) + #:substitutable? substitutable? + #:properties properties)))) (define* (gexp-inputs exp #:key native?) "Return the input list for EXP. When NATIVE? is true, return only native diff --git a/tests/derivations.scm b/tests/derivations.scm index 159a6971b3..5f294c1827 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1132,6 +1132,16 @@ ((p2 . _) (stringderivation %store "bar" + '(mkdir %output))) + (drv2 (build-expression->derivation %store "foo" + '(mkdir %output) + #:properties '((type . test))))) + (list (derivation-properties drv1) + (derivation-properties drv2)))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) diff --git a/tests/gexp.scm b/tests/gexp.scm index ab60bdab68..7ae9201c81 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -476,7 +476,15 @@ (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) - (equal? refs2 (list file)))))) + (equal? refs2 (list file)) + (null? (derivation-properties drv)))))) + +(test-assertm "gexp->derivation properties" + (mlet %store-monad ((drv (gexp->derivation "foo" + #~(mkdir #$output) + #:properties '((type . test))))) + (return (equal? '((type . test)) + (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) -- cgit v1.2.3 From 64fd1c01bc6f1be6ffcafc08789d5dafb9850c2e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:27:39 +0100 Subject: grafts: Record metadata as derivation properties. * guix/grafts.scm (graft-derivation/shallow): Pass #:properties to 'build-expression->derivation'. * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Check the value returned by 'derivation-properties'. --- guix/grafts.scm | 7 ++++++- tests/grafts.scm | 13 ++++++++----- 2 files changed, 14 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 01e245d8eb..63f384555b 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV." (define add-label (cut cons "x" <>)) + (define properties + `((type . graft) + (graft (count . ,(length grafts))))) + (match grafts ((($ sources source-outputs targets target-outputs) ...) (let ((sources (zip sources source-outputs)) @@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV." ,@(append (map add-label sources) (map add-label targets))) #:outputs outputs - #:local-build? #t))))) + #:local-build? #t + #:properties properties))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the name of the output of that derivation ITEM corresponds to (for example diff --git a/tests/grafts.scm b/tests/grafts.scm index abb074d628..f85f3c6913 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +51,8 @@ (test-begin "grafts") -(test-assert "graft-derivation, grafted item is a direct dependency" +(test-equal "graft-derivation, grafted item is a direct dependency" + '((type . graft) (graft (count . 2))) (let* ((build `(begin (mkdir %output) (chdir %output) @@ -76,14 +77,16 @@ (origin %mkdir) (replacement two)))))) (and (build-derivations %store (list grafted)) - (let ((two (derivation->output-path two)) - (grafted (derivation->output-path grafted))) + (let ((properties (derivation-properties grafted)) + (two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) (call-with-input-file (string-append grafted "/text") get-string-all)) (string=? (readlink (string-append grafted "/sh")) one) (string=? (readlink (string-append grafted "/self")) - grafted)))))) + grafted) + properties))))) (test-assert "graft-derivation, grafted item uses a different name" (let* ((build `(begin -- cgit v1.2.3 From af1f1c38fbd5cb9e11d0e2fff1d62a7d6d5b8b59 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:29:29 +0100 Subject: status: Report grafting derivations specially. * guix/status.scm (print-build-event): In 'build-started' event handler, check the properties of DRV and handle 'graft' derivations specially. --- guix/status.scm | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 2ceb56788a..868bfdca21 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -325,7 +325,19 @@ addition to build events." (display "\r" port)) ;erase the spinner (match event (('build-started drv . _) - (format port (info (G_ "building ~a...")) drv) + (let ((properties (derivation-properties + (read-derivation-from-file drv)))) + (match (assq-ref properties 'type) + ('graft + (let ((count (match (assq-ref properties 'graft) + (#f 0) + (lst (or (assq-ref lst 'count) 0))))) + (format port (info (N_ "applying ~a graft for ~a..." + "applying ~a grafts for ~a..." + count)) + count drv))) + (_ + (format port (info (G_ "building ~a...")) drv)))) (newline port)) (('build-succeeded drv . _) (when (or print-log? (not (extended-build-trace-supported?))) -- cgit v1.2.3 From d4aa147eecc64a00d1463d4008b22c9595041552 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:31:09 +0100 Subject: ui: 'show-what-to-build' reports grafts separately. * guix/ui.scm (graft-derivation?): New procedure. (show-what-to-build): Distinguish among BUILD derivations that match 'graft-derivation?'. Report them separately. --- guix/ui.scm | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 96f403acf5..60636edac0 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -816,6 +816,12 @@ warning." (warning (G_ "at least ~,1h MB needed but only ~,1h MB available in ~a~%") (/ need 1e6) (/ free 1e6) directory)))) +(define (graft-derivation? drv) + "Return true if DRV is definitely a graft derivation, false otherwise." + (match (assq-ref (derivation-properties drv) 'type) + ('graft #t) + (_ #f))) + (define* (show-what-to-build store drv #:key dry-run? (use-substitutes? #t) (mode (build-mode normal))) @@ -865,7 +871,11 @@ report what is prerequisites are available for download." (append-map substitutable-references download)))) - download))) + download)) + ((graft build) + (partition (compose graft-derivation? + read-derivation-from-file) + build))) (define installed-size (reduce + 0 (map substitutable-nar-size download))) @@ -898,7 +908,12 @@ report what is prerequisites are available for download." "~:[The following files would be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download)))) + (map substitutable-path download))) + (format (current-error-port) + (N_ "~:[The following graft would be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts would be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) graft)) (begin (format (current-error-port) (N_ "~:[The following derivation will be built:~%~{ ~a~%~}~;~]" @@ -918,7 +933,12 @@ report what is prerequisites are available for download." "~:[The following files will be downloaded:~%~{ ~a~%~}~;~]" (length download)) (null? download) - (map substitutable-path download))))) + (map substitutable-path download))) + (format (current-error-port) + (N_ "~:[The following graft will be made:~%~{ ~a~%~}~;~]" + "~:[The following grafts will be made:~%~{ ~a~%~}~;~]" + (length graft)) + (null? graft) graft))) (check-available-space installed-size) -- cgit v1.2.3 From 94c0e61fe759924625c9e27d3da8c7c0c767ea2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 11:48:33 +0100 Subject: inferior: Add 'inferior-eval-with-store'. * guix/inferior.scm (inferior-eval-with-store): New procedure, with code formerly in 'inferior-package-derivation'. (inferior-package-derivation): Rewrite in terms of 'inferior-eval-with-store'. * tests/inferior.scm ("inferior-eval-with-store"): New test. --- guix/inferior.scm | 70 +++++++++++++++++++++++++++++++++--------------------- tests/inferior.scm | 9 +++++++ 2 files changed, 52 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 1dbb9e1699..ccc1c27cb2 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -56,6 +56,7 @@ open-inferior close-inferior inferior-eval + inferior-eval-with-store inferior-object? inferior-packages @@ -402,55 +403,70 @@ input/output ports.)" (unless (port-closed? client) (loop)))))) -(define* (inferior-package-derivation store package - #:optional - (system (%current-system)) - #:key target) - "Return the derivation for PACKAGE, an inferior package, built for SYSTEM -and cross-built for TARGET if TARGET is true. The inferior corresponding to -PACKAGE must be live." - ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to - ;; it and use it as its store. This ensures the inferior uses the same - ;; store, with the same options, the same per-session GC roots, etc. +(define (inferior-eval-with-store inferior store code) + "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must +thus be the code of a one-argument procedure that accepts a store." + ;; Create a named socket in /tmp and let INFERIOR connect to it and use it + ;; as its store. This ensures the inferior uses the same store, with the + ;; same options, the same per-session GC roots, etc. (call-with-temporary-directory (lambda (directory) (chmod directory #o700) (let* ((name (string-append directory "/inferior")) (socket (socket AF_UNIX SOCK_STREAM 0)) - (inferior (inferior-package-inferior package)) (major (nix-server-major-version store)) (minor (nix-server-minor-version store)) (proto (logior major minor))) (bind socket AF_UNIX name) (listen socket 1024) (send-inferior-request - `(let ((socket (socket AF_UNIX SOCK_STREAM 0))) + `(let ((proc ,code) + (socket (socket AF_UNIX SOCK_STREAM 0))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly ;; emulate it on older versions. Thus fall back to ;; 'open-connection', at the risk of talking to the wrong daemon or ;; having our build result reclaimed (XXX). - (let* ((store (if (defined? 'port->connection) - (port->connection socket #:version ,proto) - (open-connection))) - (package (hashv-ref %package-table - ,(inferior-package-id package))) - (drv ,(if target - `(package-cross-derivation store package - ,target - ,system) - `(package-derivation store package - ,system)))) - (close-connection store) - (close-port socket) - (derivation-file-name drv))) + (let ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection)))) + (dynamic-wind + (const #t) + (lambda () + (proc store)) + (lambda () + (close-connection store) + (close-port socket))))) inferior) (match (accept socket) ((client . address) (proxy client (nix-server-socket store)))) (close-port socket) - (read-derivation-from-file (read-inferior-response inferior)))))) + (read-inferior-response inferior))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + (define proc + `(lambda (store) + (let* ((package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (derivation-file-name drv)))) + + (and=> (inferior-eval-with-store (inferior-package-inferior package) store + proc) + read-derivation-from-file)) (define inferior-package->derivation (store-lift inferior-package-derivation)) diff --git a/tests/inferior.scm b/tests/inferior.scm index d1d5c00a77..d5a894ca8f 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -157,6 +157,15 @@ (close-inferior inferior) result)) +(test-equal "inferior-eval-with-store" + (add-text-to-store %store "foo" "Hello, world!") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "foo" + "Hello, world!"))))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3 From fe5db4eb03ff55a7b5731bea57f813cb8a9e3d8b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 17:16:18 +0100 Subject: channels: Add 'checkout->channel-instance'. * guix/channels.scm (checkout->channel-instance): New procedure. --- guix/channels.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 82389eb583..e57da68149 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -47,6 +47,7 @@ channel-instance-checkout latest-channel-instances + checkout->channel-instance latest-channel-derivation channel-instances->manifest channel-instances->derivation)) @@ -114,6 +115,17 @@ CHANNELS." (channel-instance channel commit checkout))) channels)) +(define* (checkout->channel-instance checkout + #:key commit + (url checkout) (name 'guix)) + "Return a channel instance for CHECKOUT, which is assumed to be a checkout +of COMMIT at URL. Use NAME as the channel name." + (let* ((commit (or commit (make-string 40 #\0))) + (channel (channel (name name) + (commit commit) + (url url)))) + (channel-instance channel commit checkout))) + (define %self-build-file ;; The file containing code to build Guix. This serves the same purpose as ;; a makefile, and, similarly, is intended to always keep this name. -- cgit v1.2.3 From e91152e9f28ada896c875b51481faffbfba95869 Mon Sep 17 00:00:00 2001 From: Tim Gesthuizen Date: Tue, 27 Nov 2018 18:43:45 +0100 Subject: guix hash: Fix version and help messages MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ca719424455465fca4b872c371daf2a46de88b33 changes the name of the executable to be displayed by the --version and --help commands of `guix hash` to "gcrypt hash". This is reverted by this commit. * guix/scripts/hash.scm (show-help): Change string literals Signed-off-by: Ludovic Courtès --- guix/scripts/hash.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 2bd2ac4a06..b8b2158195 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2016 Jan Nieuwenhuizen +;;; Copyright © 2018 Tim Gesthuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,7 +45,7 @@ `((format . ,bytevector->nix-base32-string))) (define (show-help) - (display (G_ "Usage: gcrypt hash [OPTION] FILE + (display (G_ "Usage: guix hash [OPTION] FILE Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' @@ -93,7 +94,7 @@ and 'hexadecimal' can be used as well).\n")) (exit 0))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "gcrypt hash"))))) + (show-version-and-exit "guix hash"))))) -- cgit v1.2.3 From a52ae1b6620fcef28e668047a51a6b2a9fb89e35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Nov 2018 22:17:39 +0100 Subject: download: Make (guix base16) a soft dependency. Fixes . Reported by Mark H Weaver . * guix/download.scm (%content-addressed-mirrors): Autoload (guix base16). --- guix/download.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 0f92e12c08..7aebec44ac 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -373,7 +373,13 @@ ;; procedure that takes a file name, an algorithm (symbol) and a hash ;; (bytevector), and returns a URL or #f. '(begin - (use-modules (guix base32) (guix base16)) + (use-modules (guix base32)) + + ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old + ;; installations of the daemon might lack it. Thus, load it lazily to + ;; avoid gratuitous errors. See . + (module-autoload! (current-module) + '(guix base16) '(bytevector->base16-string)) (list (lambda (file algo hash) ;; Files served by 'guix publish' are accessible under a single -- cgit v1.2.3 From 13bcc6b45fb7564347a55d03fa11b9bd8a96436d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Nov 2018 22:23:10 +0100 Subject: download: Add berlin.guixsd.org as a content-addressed mirror. * guix/download.scm (%content-addressed-mirrors)[guix-publish]: New procedure. Use it for "mirror.hydra.gnu.org" and add "berlin.guixsd.org" too. --- guix/download.scm | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 7aebec44ac..a7f51b1999 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -375,18 +375,22 @@ '(begin (use-modules (guix base32)) + (define (guix-publish host) + (lambda (file algo hash) + ;; Files served by 'guix publish' are accessible under a single + ;; hash algorithm. + (string-append "https://" host "/file/" + file "/" (symbol->string algo) "/" + (bytevector->nix-base32-string hash)))) + ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old ;; installations of the daemon might lack it. Thus, load it lazily to ;; avoid gratuitous errors. See . (module-autoload! (current-module) '(guix base16) '(bytevector->base16-string)) - (list (lambda (file algo hash) - ;; Files served by 'guix publish' are accessible under a single - ;; hash algorithm. - (string-append "https://mirror.hydra.gnu.org/file/" - file "/" (symbol->string algo) "/" - (bytevector->nix-base32-string hash))) + (list (guix-publish "mirror.hydra.gnu.org") + (guix-publish "berlin.guixsd.org") (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. (string-append "https://tarballs.nixos.org/" -- cgit v1.2.3 From d09ce3f91b9f064d623aed03c0d5ab1f472df918 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 29 Nov 2018 09:30:00 +0100 Subject: docker: Hide scary-looking but harmless tar failure messages. * guix/docker.scm (build-docker-image): Wrap "tar --delete" invocation in 'with-error-to-port'. --- guix/docker.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/docker.scm b/guix/docker.scm index c19a24d45c..c6e9c6fee5 100644 --- a/guix/docker.scm +++ b/guix/docker.scm @@ -209,8 +209,13 @@ SRFI-19 time-utc object, as the creation time in metadata." ;; the path "/a" into "/". The presence of "/" in the archive is ;; probably benign, but it is definitely safe to remove it, so let's ;; do that. This fails when "/" is not in the archive, so use system* - ;; instead of invoke to avoid an exception in that case. - (system* "tar" "--delete" "/" "-f" "layer.tar") + ;; instead of invoke to avoid an exception in that case, and redirect + ;; stderr to the bit bucket to avoid "Exiting with failure status" + ;; error messages. + (with-error-to-port (%make-void-port "w") + (lambda () + (system* "tar" "--delete" "/" "-f" "layer.tar"))) + (for-each delete-file-recursively (map (compose topmost-component symlink-source) symlinks)) -- cgit v1.2.3