mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-01-18 21:46:35 +01:00
DRAFT substitute: Add IPFS support.
Missing: - documentation - command-line options - progress report when downloading over IPFS - fallback when we fail to fetch from IPFS * guix/scripts/substitute.scm (<narinfo>)[ipfs]: New field. (read-narinfo): Read "IPFS". (process-substitution/http): New procedure, with code formerly in 'process-substitution'. (process-substitution): Check for IPFS and call 'ipfs:restore-file-tree' when IPFS is true.
This commit is contained in:
parent
5fdb66f176
commit
79b0f72a9e
1 changed files with 61 additions and 45 deletions
|
@ -42,6 +42,7 @@ (define-module (guix scripts substitute)
|
||||||
#:use-module (guix progress)
|
#:use-module (guix progress)
|
||||||
#:use-module ((guix build syscalls)
|
#:use-module ((guix build syscalls)
|
||||||
#:select (set-thread-name))
|
#:select (set-thread-name))
|
||||||
|
#:use-module ((guix ipfs) #:prefix ipfs:)
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
@ -281,7 +282,7 @@ (define (read-cache-info port)
|
||||||
|
|
||||||
(define-record-type <narinfo>
|
(define-record-type <narinfo>
|
||||||
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
|
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
|
||||||
references deriver system signature contents)
|
references deriver system ipfs signature contents)
|
||||||
narinfo?
|
narinfo?
|
||||||
(path narinfo-path)
|
(path narinfo-path)
|
||||||
(uri narinfo-uri)
|
(uri narinfo-uri)
|
||||||
|
@ -294,6 +295,7 @@ (define-record-type <narinfo>
|
||||||
(references narinfo-references)
|
(references narinfo-references)
|
||||||
(deriver narinfo-deriver)
|
(deriver narinfo-deriver)
|
||||||
(system narinfo-system)
|
(system narinfo-system)
|
||||||
|
(ipfs narinfo-ipfs)
|
||||||
(signature narinfo-signature) ; canonical sexp
|
(signature narinfo-signature) ; canonical sexp
|
||||||
;; The original contents of a narinfo file. This field is needed because we
|
;; The original contents of a narinfo file. This field is needed because we
|
||||||
;; want to preserve the exact textual representation for verification purposes.
|
;; want to preserve the exact textual representation for verification purposes.
|
||||||
|
@ -335,7 +337,7 @@ (define (narinfo-maker str cache-url)
|
||||||
"Return a narinfo constructor for narinfos originating from CACHE-URL. STR
|
"Return a narinfo constructor for narinfos originating from CACHE-URL. STR
|
||||||
must contain the original contents of a narinfo file."
|
must contain the original contents of a narinfo file."
|
||||||
(lambda (path url compression file-hash file-size nar-hash nar-size
|
(lambda (path url compression file-hash file-size nar-hash nar-size
|
||||||
references deriver system signature)
|
references deriver system ipfs signature)
|
||||||
"Return a new <narinfo> object."
|
"Return a new <narinfo> object."
|
||||||
(%make-narinfo path
|
(%make-narinfo path
|
||||||
;; Handle the case where URL is a relative URL.
|
;; Handle the case where URL is a relative URL.
|
||||||
|
@ -352,6 +354,7 @@ (define (narinfo-maker str cache-url)
|
||||||
((or #f "") #f)
|
((or #f "") #f)
|
||||||
(_ deriver))
|
(_ deriver))
|
||||||
system
|
system
|
||||||
|
ipfs
|
||||||
(false-if-exception
|
(false-if-exception
|
||||||
(and=> signature narinfo-signature->canonical-sexp))
|
(and=> signature narinfo-signature->canonical-sexp))
|
||||||
str)))
|
str)))
|
||||||
|
@ -386,7 +389,7 @@ (define* (read-narinfo port #:optional url
|
||||||
(narinfo-maker str url)
|
(narinfo-maker str url)
|
||||||
'("StorePath" "URL" "Compression"
|
'("StorePath" "URL" "Compression"
|
||||||
"FileHash" "FileSize" "NarHash" "NarSize"
|
"FileHash" "FileSize" "NarHash" "NarSize"
|
||||||
"References" "Deriver" "System"
|
"References" "Deriver" "System" "IPFS"
|
||||||
"Signature"))))
|
"Signature"))))
|
||||||
|
|
||||||
(define (narinfo-sha256 narinfo)
|
(define (narinfo-sha256 narinfo)
|
||||||
|
@ -947,13 +950,58 @@ (define (valid? obj)
|
||||||
(wtf
|
(wtf
|
||||||
(error "unknown `--query' command" wtf))))
|
(error "unknown `--query' command" wtf))))
|
||||||
|
|
||||||
|
(define* (process-substitution/http narinfo destination uri
|
||||||
|
#:key print-build-trace?)
|
||||||
|
(unless print-build-trace?
|
||||||
|
(format (current-error-port)
|
||||||
|
(G_ "Downloading ~a...~%") (uri->string uri)))
|
||||||
|
|
||||||
|
(let*-values (((raw download-size)
|
||||||
|
;; Note that Hydra currently generates Nars on the fly
|
||||||
|
;; and doesn't specify a Content-Length, so
|
||||||
|
;; DOWNLOAD-SIZE is #f in practice.
|
||||||
|
(fetch uri #:buffered? #f #:timeout? #f))
|
||||||
|
((progress)
|
||||||
|
(let* ((comp (narinfo-compression narinfo))
|
||||||
|
(dl-size (or download-size
|
||||||
|
(and (equal? comp "none")
|
||||||
|
(narinfo-size narinfo))))
|
||||||
|
(reporter (if print-build-trace?
|
||||||
|
(progress-reporter/trace
|
||||||
|
destination
|
||||||
|
(uri->string uri) dl-size
|
||||||
|
(current-error-port))
|
||||||
|
(progress-reporter/file
|
||||||
|
(uri->string uri) dl-size
|
||||||
|
(current-error-port)
|
||||||
|
#:abbreviation nar-uri-abbreviation))))
|
||||||
|
(progress-report-port reporter raw)))
|
||||||
|
((input pids)
|
||||||
|
;; NOTE: This 'progress' port of current process will be
|
||||||
|
;; closed here, while the child process doing the
|
||||||
|
;; reporting will close it upon exit.
|
||||||
|
(decompressed-port (and=> (narinfo-compression narinfo)
|
||||||
|
string->symbol)
|
||||||
|
progress)))
|
||||||
|
;; Unpack the Nar at INPUT into DESTINATION.
|
||||||
|
(restore-file input destination)
|
||||||
|
(close-port input)
|
||||||
|
|
||||||
|
;; Wait for the reporter to finish.
|
||||||
|
(every (compose zero? cdr waitpid) pids)
|
||||||
|
|
||||||
|
;; Skip a line after what 'progress-reporter/file' printed, and another
|
||||||
|
;; one to visually separate substitutions.
|
||||||
|
(display "\n\n" (current-error-port))))
|
||||||
|
|
||||||
(define* (process-substitution store-item destination
|
(define* (process-substitution store-item destination
|
||||||
#:key cache-urls acl print-build-trace?)
|
#:key cache-urls acl print-build-trace?)
|
||||||
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
|
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
|
||||||
DESTINATION as a nar file. Verify the substitute against ACL."
|
DESTINATION as a nar file. Verify the substitute against ACL."
|
||||||
(let* ((narinfo (lookup-narinfo cache-urls store-item
|
(let* ((narinfo (lookup-narinfo cache-urls store-item
|
||||||
(cut valid-narinfo? <> acl)))
|
(cut valid-narinfo? <> acl)))
|
||||||
(uri (and=> narinfo narinfo-uri)))
|
(uri (and=> narinfo narinfo-uri))
|
||||||
|
(ipfs (and=> narinfo narinfo-ipfs)))
|
||||||
(unless uri
|
(unless uri
|
||||||
(leave (G_ "no valid substitute for '~a'~%")
|
(leave (G_ "no valid substitute for '~a'~%")
|
||||||
store-item))
|
store-item))
|
||||||
|
@ -961,47 +1009,15 @@ (define* (process-substitution store-item destination
|
||||||
;; Tell the daemon what the expected hash of the Nar itself is.
|
;; Tell the daemon what the expected hash of the Nar itself is.
|
||||||
(format #t "~a~%" (narinfo-hash narinfo))
|
(format #t "~a~%" (narinfo-hash narinfo))
|
||||||
|
|
||||||
(unless print-build-trace?
|
(if ipfs
|
||||||
(format (current-error-port)
|
(begin
|
||||||
(G_ "Downloading ~a...~%") (uri->string uri)))
|
(unless print-build-trace?
|
||||||
|
(format (current-error-port)
|
||||||
(let*-values (((raw download-size)
|
(G_ "Downloading from IPFS ~s...~%") ipfs))
|
||||||
;; Note that Hydra currently generates Nars on the fly
|
(ipfs:restore-file-tree ipfs destination))
|
||||||
;; and doesn't specify a Content-Length, so
|
(process-substitution/http narinfo destination uri
|
||||||
;; DOWNLOAD-SIZE is #f in practice.
|
#:print-build-trace?
|
||||||
(fetch uri #:buffered? #f #:timeout? #f))
|
print-build-trace?))))
|
||||||
((progress)
|
|
||||||
(let* ((comp (narinfo-compression narinfo))
|
|
||||||
(dl-size (or download-size
|
|
||||||
(and (equal? comp "none")
|
|
||||||
(narinfo-size narinfo))))
|
|
||||||
(reporter (if print-build-trace?
|
|
||||||
(progress-reporter/trace
|
|
||||||
destination
|
|
||||||
(uri->string uri) dl-size
|
|
||||||
(current-error-port))
|
|
||||||
(progress-reporter/file
|
|
||||||
(uri->string uri) dl-size
|
|
||||||
(current-error-port)
|
|
||||||
#:abbreviation nar-uri-abbreviation))))
|
|
||||||
(progress-report-port reporter raw)))
|
|
||||||
((input pids)
|
|
||||||
;; NOTE: This 'progress' port of current process will be
|
|
||||||
;; closed here, while the child process doing the
|
|
||||||
;; reporting will close it upon exit.
|
|
||||||
(decompressed-port (and=> (narinfo-compression narinfo)
|
|
||||||
string->symbol)
|
|
||||||
progress)))
|
|
||||||
;; Unpack the Nar at INPUT into DESTINATION.
|
|
||||||
(restore-file input destination)
|
|
||||||
(close-port input)
|
|
||||||
|
|
||||||
;; Wait for the reporter to finish.
|
|
||||||
(every (compose zero? cdr waitpid) pids)
|
|
||||||
|
|
||||||
;; Skip a line after what 'progress-reporter/file' printed, and another
|
|
||||||
;; one to visually separate substitutions.
|
|
||||||
(display "\n\n" (current-error-port)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
Loading…
Reference in a new issue