bartronx7/guix
1
0
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2026-01-25 03:55:08 -06:00
Code Issues Projects Releases Packages Wiki Activity Actions

DRAFT substitute: Fetch digests and restore store items from digests.

Browse source 
DRAFT: Tests missing, compression support missing.

* guix/scripts/substitute.scm (digest-cache-file, cache-digest!)
(digest-request, lookup-digest): New procedures.
(fetch-narinfos)[%not-slash]: New variable.
[handle-digest-response, handle-response]: New procedures.
[do-fetch]: Append digest requests to narinfo requests.  Pass
'handle-response' to 'http-multiple-get' instead of
'handle-narinfo-response'.
(process-substitution): Rename to...
(process-substitution/nar): ... this.  Make 'narinfo' a parameter.
(http-fetch-files, nar-hash)
(process-substitution, process-substitution/digest): New procedures.
(guix-substitute): Pass #:delete-entry to 'maybe-remove-expired-cache-entries'.
* guix/digests.scm (sexp->digest): New procedure.
This commit is contained in:
Ludovic Courtès 2021-01-03 21:14:54 +01:00
parent f44a1e0b52
commit e43958af27
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 217 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
guix/digests.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -41,7 +41,8 @@
file-digest
restore-digest
digest->sexp))
digest->sexp
sexp->digest))
;;; Commentary:
;;;
@ -232,3 +233,25 @@ false."
`(digest (version 0)
,(->sexp digest)))
(define (sexp->digest sexp)
"Return a digest deserialized from SEXP."
(define (->digest sexp)
(match sexp
(('x size (algorithm hash) _ ...)
(digest 'executable size (list algorithm hash)))
(('f size (algorithm hash) _ ...)
(digest 'regular size
(list algorithm (nix-base32-string->bytevector hash))))
(('d entries ...)
(digest 'directory 0
(map (match-lambda
((name digest)
(digest-entry name (->digest digest))))
entries)))
(('l target)
(digest 'symlink 0 target))))
(match sexp
(('digest ('version 0) sexp)
(->digest sexp))))

204
guix/scripts/substitute.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;;
@ -28,7 +28,8 @@
#:use-module (guix records)
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module ((guix serialization) #:select (restore-file dump-file))
#:use-module ((guix serialization)
#:select (restore-file write-file dump-file dump-port*))
#:autoload (guix store deduplication) (dump-file/deduplicate)
#:autoload (guix scripts discover) (read-substitute-urls)
#:use-module (gcrypt hash)
@ -43,7 +44,7 @@
(open-connection-for-uri
. guix:open-connection-for-uri)
store-path-abbreviation byte-count->string))
#:use-module (guix progress)
#:use-module ((guix progress) #:hide (dump-port*))
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (ice-9 rdelim)
@ -66,6 +67,8 @@
#:use-module (web request)
#:use-module (web response)
#:use-module (guix http-client)
#:autoload (guix digests) (digest->sexp sexp->digest restore-digest
digest-type digest-size digest-content)
#:export (narinfo-signature->canonical-sexp
narinfo?
@ -433,6 +436,19 @@ entry is stored in a sub-directory specific to CACHE-URL."
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
"/" hash-part))))
(define (digest-cache-file cache-url path)
"Return the name of the local file that contains an entry for PATH. The
entry is stored in a sub-directory specific to CACHE-URL."
;; The daemon does not sanitize its input, so PATH could be something like
;; "/gnu/store/foo". Gracefully handle that.
(match (store-path-hash-part path)
(#f
(leave (G_ "'~a' does not name a store item~%") path))
((? string? hash-part)
(string-append %narinfo-cache-directory "/"
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
"/" hash-part ".digest"))))
(define (cached-narinfo cache-url path)
"Check locally if we have valid info about PATH coming from CACHE-URL.
Return two values: a Boolean indicating whether we have valid cached info, and
@ -498,6 +514,23 @@ indicates that PATH is unavailable at CACHE-URL."
(headers '((User-Agent . "GNU Guile"))))
(build-request (string->uri url) #:method 'GET #:headers headers)))
(define (cache-digest! cache-url path data)
"Cache DATA, a bytevector, as the digest for PATH obtained from CACHE-URL."
(define now
(current-time time-monotonic))
(let ((file (digest-cache-file cache-url path)))
(mkdir-p (dirname file))
(with-atomic-file-output file
(lambda (out)
(put-bytevector out data)))))
(define (digest-request cache-url path)
"Return an HTTP request for the digest of PATH at CACHE-URL."
(let ((url (string-append cache-url "/digest/" (store-path-hash-part path)))
(headers '((User-Agent . "GNU Guile"))))
(build-request (string->uri url) #:method 'GET #:headers headers)))
(define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail."
@ -686,20 +719,45 @@ port to it, or, if connection failed, print a warning and return #f. Pass
%narinfo-transient-error-ttl))
result))))
(define %not-slash
(char-set-complement (char-set #\/)))
(define (handle-digest-response request response port result)
(when (= 200 (response-code response))
(let ((len (response-content-length response)))
(match (string-tokenize (uri-path (request-uri request))
%not-slash)
(("digest" hash-part)
(let* ((data (if len
(get-bytevector-n port len)
(read-to-eof port)))
(digest (sexp->digest
(read (open-bytevector-input-port data)))))
(cache-digest! url (hash-part->path hash-part) data)))
(_ #f))))
result)
(define (handle-response request response port result)
(if (string-contains (uri-path (request-uri request))
"/digest/")
(handle-digest-response request response port result)
(handle-narinfo-response request response port result)))
(define (do-fetch uri)
(case (and=> uri uri-scheme)
((http https)
;; Note: Do not check HTTPS server certificates to avoid depending
;; on the X.509 PKI. We can do it because we authenticate
;; narinfos, which provides a much stronger guarantee.
(let* ((requests (map (cut narinfo-request url <>) paths))
(let* ((requests (append (map (cut narinfo-request url <>) paths)
(map (cut digest-request url <>) paths)))
(result (call-with-cached-connection uri
(lambda (port)
(if port
(begin
(update-progress!)
(http-multiple-get uri
handle-narinfo-response '()
handle-response '()
requests
#:open-connection
open-connection-for-uri/cached
@ -806,6 +864,18 @@ was found."
((answer) answer)
(_ #f)))
(define (lookup-digest cache-url path)
"Return the digest for PATH in CACHE-URL or #f if it could not be found in
cache."
(catch 'system-error
(lambda ()
(call-with-input-file (digest-cache-file cache-url path)
(compose sexp->digest read)))
(lambda args
(if (= ENOENT (system-error-errno args))
#f
(apply throw args)))))
(define (cached-narinfo-expiration-time file)
"Return the expiration time for FILE, which is a cached narinfo."
(catch 'system-error
@ -1065,18 +1135,14 @@ server certificates."
"Bind PORT with EXP... to a socket connected to URI."
(call-with-cached-connection uri (lambda (port) exp ...)))
(define* (process-substitution store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
(define* (process-substitution/nar store-item narinfo destination
#:key cache-urls
deduplicate? print-build-trace?)
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
DESTINATION as a nar file. Verify the substitute against ACL, and verify its
hash against what appears in the narinfo. When DEDUPLICATE? is true, and if
DESTINATION is in the store, deduplicate its files. Print a status line on
the current output port."
(define narinfo
(lookup-narinfo cache-urls store-item
(cut valid-narinfo? <> acl)))
(define destination-in-store?
(string-prefix? (string-append (%store-prefix) "/")
destination))
@ -1160,6 +1226,115 @@ the current output port."
(bytevector->nix-base32-string expected)
(bytevector->nix-base32-string actual)))))))
(define (http-fetch-files base-url files+digests)
"Fetch the files in FILES+DIGESTS, a list of file name/digest pairs as
returned by 'restore-digest'.scm"
(define (content-uri digest)
(match (digest-content digest)
(((algorithm hash) _ ...)
(string->uri
(string-append base-url "/content/" algorithm "/"
(bytevector->base32-string hash))))))
(define (content-request digest)
(build-request (content-uri digest)
#:method 'GET
#:headers '((User-Agent . "GNU Guile"))))
(define request->file
(fold (lambda (file+digest result)
(match file+digest
((file . digest)
(vhash-consq (content-request digest) file
result))))
vlist-null
files+digests))
(define total-size
(match files+digests
(((_ . digests) ...)
(fold (lambda (digest size)
(+ size (digest-size digest)))
0
digests))))
;; TODO: decompression
;; TODO: progress report
(http-multiple-get (string->uri base-url)
(lambda (request response port result)
(match (vhash-assq request request->file)
((digest . file)
;; TODO: deduplicate
(with-atomic-file-output file
(lambda (output)
(let ((len (response-content-length response)))
(dump-port* port output len))))
(chmod file (if (eq? (digest-type digest) 'regular)
#o444
#o555))
(utime file 1 1 0 0))))
#t
(vhash-fold-right (lambda (file request result)
(cons request result))
'()
request->file)))
(define (nar-hash file algorithm)
"Return the ALGORITHM hash of FILE."
(let-values (((port get-hash) (open-hash-port algorithm)))
(write-file file port)
(force-output port)
(let ((hash (get-hash)))
(close-port port)
hash)))
(define* (process-substitution/digest store-item narinfo destination
#:key digest
deduplicate? print-build-trace?)
(define destination-in-store?
(string-prefix? (string-append (%store-prefix) "/")
destination))
(let ((missing-files (restore-digest digest destination)))
(unless (null? missing-files)
(http-fetch-files (narinfo-uri-base narinfo) missing-files)))
(let*-values (((algorithm expected)
(narinfo-hash-algorithm+value narinfo))
((actual) (nar-hash destination algorithm)))
(if (bytevector=? actual expected)
;; Tell the daemon that we're done.
(format (current-output-port) "success ~a ~a~%"
(narinfo-hash narinfo) (narinfo-size narinfo))
;; The actual data has a different hash than that in NARINFO.
(format (current-output-port) "hash-mismatch ~a ~a ~a~%"
(hash-algorithm-name algorithm)
(bytevector->nix-base32-string expected)
(bytevector->nix-base32-string actual)))))
(define* (process-substitution store-item destination
#:key cache-urls acl
deduplicate? print-build-trace?)
(define narinfo
(lookup-narinfo cache-urls store-item
(cut valid-narinfo? <> acl)))
(define digest
(and narinfo
(lookup-digest (narinfo-uri-base narinfo) store-item)))
(if digest
(process-substitution/digest store-item narinfo destination
#:digest digest
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?)
(process-substitution/nar store-item narinfo destination
#:cache-urls cache-urls
#:deduplicate? deduplicate?
#:print-build-trace? print-build-trace?)))
;;;
;;; Entry point.
@ -1301,6 +1476,11 @@ default value."
cached-narinfo-files
#:entry-expiration
cached-narinfo-expiration-time
#:delete-entry
(lambda (file)
(delete-file* file)
(delete-file*
(string-append file ".digest")))
#:cleanup-period
%narinfo-expired-cache-entry-removal-delay)
(check-acl-initialized)