From mboxrd@z Thu Jan 1 00:00:00 1970 From: Caleb Ristvedt Subject: Re: 02/09: guix: store: Make register-items transactional, register drv outputs Date: Sat, 06 Apr 2019 18:57:09 -0500 Message-ID: <87k1g61ycq.fsf@cune.org> References: <20190204192241.15758.66035@vcs0.savannah.gnu.org> <20190204192243.D1BD820B84@vcs0.savannah.gnu.org> <87wom8pqbi.fsf@gnu.org> <87o97gcc3w.fsf@cune.org> <877edcjgbj.fsf@gnu.org> <87sgv11ujj.fsf@cune.org> <87a7h5rbc3.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([209.51.188.92]:57228) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hCvBZ-0004Gh-1X for guix-devel@gnu.org; Sat, 06 Apr 2019 19:57:25 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hCvBU-0000bA-Vd for guix-devel@gnu.org; Sat, 06 Apr 2019 19:57:20 -0400 Received: from mail-yb1-xb32.google.com ([2607:f8b0:4864:20::b32]:33975) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hCvBT-0000aL-Tr for guix-devel@gnu.org; Sat, 06 Apr 2019 19:57:16 -0400 Received: by mail-yb1-xb32.google.com with SMTP id c2so3829589ybn.1 for ; Sat, 06 Apr 2019 16:57:15 -0700 (PDT) In-Reply-To: <87a7h5rbc3.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Thu, 04 Apr 2019 18:20:44 +0200") List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: guix-devel@gnu.org --=-=-= Content-Type: text/plain > I finally got around to fixing it in > a31174e896047e6a0f42b69db331fdeebb3cc995. > > The kludge is no longer needed! Great. Here are updated patches: --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0001-guix-split-guix-store-and-guix-derivations.patch Content-Transfer-Encoding: quoted-printable >From 287879a825f41c46cc5091c715467e476d465def Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Mon, 1 Apr 2019 15:04:59 -0500 Subject: [PATCH 1/2] guix: split (guix store) and (guix derivations). * guix/store.scm (%store-prefix, store-path, output-path, fixed-output-path, store-path?, direct-store-path?, derivation-path?, store-path-package-nam= e, store-path-hash-part, direct-store-path, derivation-log-file): Moved to (guix store files) and re-exported from here. ((guix store files)): use it. * guix/store/files.scm: new module. above named variables: added. * guix/derivations.scm (, derivation?, derivation-outputs, derivation-inputs, derivation-sources, derivation-system, derivation-builder, derivation-builder-arguments, derivation-builder-environment-vars, derivation-file-name, derivation-output>, derivation-output?, derivation-output-path, derivation-output-hash-algo, derivation-output-hash, derivation-output-recursive?, derivation-input>, derivation-input?, derivation-input-path, derivation-input-sub-derivations, read-derivation, read-derivation-from-file, write-derivation): Moved to (guix store derivations) and re-exported from here. ((guix store derivations)): use it. * guix/store/derivations.scm: new module. above named variables: added. --- guix/derivations.scm | 281 ++++-------------------------------- guix/store.scm | 155 ++------------------ guix/store/derivations.scm | 287 +++++++++++++++++++++++++++++++++++++ guix/store/files.scm | 171 ++++++++++++++++++++++ 4 files changed, 502 insertions(+), 392 deletions(-) create mode 100644 guix/store/derivations.scm create mode 100644 guix/store/files.scm diff --git a/guix/derivations.scm b/guix/derivations.scm index fb2fa177be..483b274e53 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -39,31 +39,10 @@ #:use-module (guix base32) #:use-module (guix records) #:use-module (guix sets) - #:export ( - derivation? - derivation-outputs - derivation-inputs - derivation-sources - derivation-system - derivation-builder - derivation-builder-arguments - derivation-builder-environment-vars - derivation-file-name + #:use-module (guix store derivations) + #:export (derivation-input-output-paths derivation-prerequisites derivation-prerequisites-to-build - - - derivation-output? - derivation-output-path - derivation-output-hash-algo - derivation-output-hash - derivation-output-recursive? - - - derivation-input? - derivation-input-path - derivation-input-sub-derivations - derivation-input-output-paths valid-derivation-input? =20 &derivation-error @@ -82,9 +61,6 @@ derivation-hash derivation-properties =20 - read-derivation - read-derivation-from-file - write-derivation derivation->output-path derivation->output-paths derivation-path->output-path @@ -107,7 +83,33 @@ build-expression->derivation) =20 ;; Re-export it from here for backward compatibility. - #:re-export (%guile-for-build)) + #:re-export (%guile-for-build + + derivation? + derivation-outputs + derivation-inputs + derivation-sources + derivation-system + derivation-builder + derivation-builder-arguments + derivation-builder-environment-vars + derivation-file-name + + + derivation-output? + derivation-output-path + derivation-output-hash-algo + derivation-output-hash + derivation-output-recursive? + + + derivation-input? + derivation-input-path + derivation-input-sub-derivations + + read-derivation + read-derivation-from-file + write-derivation)) =20 ;;; ;;; Error conditions. @@ -121,48 +123,6 @@ derivation-missing-output-error? (output derivation-missing-output)) =20 -;;; -;;; Nix derivations, as implemented in Nix's `derivations.cc'. -;;; - -(define-immutable-record-type - (make-derivation outputs inputs sources system builder args env-vars - file-name) - derivation? - (outputs derivation-outputs) ; list of name/ pa= irs - (inputs derivation-inputs) ; list of - (sources derivation-sources) ; list of store paths - (system derivation-system) ; string - (builder derivation-builder) ; store path - (args derivation-builder-arguments) ; list of strings - (env-vars derivation-builder-environment-vars) ; list of name/value pai= rs - (file-name derivation-file-name)) ; the .drv file name - -(define-immutable-record-type - (make-derivation-output path hash-algo hash recursive?) - derivation-output? - (path derivation-output-path) ; store path - (hash-algo derivation-output-hash-algo) ; symbol | #f - (hash derivation-output-hash) ; bytevector | #f - (recursive? derivation-output-recursive?)) ; Boolean - -(define-immutable-record-type - (make-derivation-input path sub-derivations) - derivation-input? - (path derivation-input-path) ; store path - (sub-derivations derivation-input-sub-derivations)) ; list of strings - -(set-record-type-printer! - (lambda (drv port) - (format port "# ~a ~a>" - (derivation-file-name drv) - (string-join - (map (match-lambda - ((_ . output) - (derivation-output-path output= ))) - (derivation-outputs drv))) - (number->string (object-address drv) 1= 6)))) - (define (derivation-name drv) "Return the base name of DRV." (let ((base (store-path-package-name (derivation-file-name drv)))) @@ -406,189 +366,6 @@ one-argument procedure similar to that returned by 's= ubstitution-oracle'." inputs) (map derivation-input-sub-derivations inputs))))))) =20 -(define (read-derivation drv-port) - "Read the derivation from DRV-PORT and return the corresponding -object. Most of the time you'll want to use 'read-derivation-from-file', -which caches things as appropriate and is thus more efficient." - - (define comma (string->symbol ",")) - - (define (ununquote x) - (match x - (('unquote x) (ununquote x)) - ((x ...) (map ununquote x)) - (_ x))) - - (define (outputs->alist x) - (fold-right (lambda (output result) - (match output - ((name path "" "") - (alist-cons name - (make-derivation-output path #f #f #f) - result)) - ((name path hash-algo hash) - ;; fixed-output - (let* ((rec? (string-prefix? "r:" hash-algo)) - (algo (string->symbol - (if rec? - (string-drop hash-algo 2) - hash-algo))) - (hash (base16-string->bytevector hash))) - (alist-cons name - (make-derivation-output path algo - hash rec?) - result))))) - '() - x)) - - (define (make-input-drvs x) - (fold-right (lambda (input result) - (match input - ((path (sub-drvs ...)) - (cons (make-derivation-input path sub-drvs) - result)))) - '() - x)) - - ;; The contents of a derivation are typically ASCII, but choosing - ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'. - (set-port-encoding! drv-port "UTF-8") - - (let loop ((exp (read drv-port)) - (result '())) - (match exp - ((? eof-object?) - (let ((result (reverse result))) - (match result - (('Derive ((outputs ...) (input-drvs ...) - (input-srcs ...) - (? string? system) - (? string? builder) - ((? string? args) ...) - ((var value) ...))) - (make-derivation (outputs->alist outputs) - (make-input-drvs input-drvs) - input-srcs - system builder args - (fold-right alist-cons '() var value) - (port-filename drv-port))) - (_ - (error "failed to parse derivation" drv-port result))))) - ((? (cut eq? <> comma)) - (loop (read drv-port) result)) - (_ - (loop (read drv-port) - (cons (ununquote exp) result)))))) - -(define %derivation-cache - ;; Maps derivation file names to objects. - ;; XXX: This is redundant with 'atts-cache' in the store. - (make-weak-value-hash-table 200)) - -(define (read-derivation-from-file file) - "Read the derivation in FILE, a '.drv' file, and return the corresponding - object." - ;; Memoize that operation because 'read-derivation' is quite expensive, - ;; and because the same argument is read more than 15 times on average - ;; during something like (package-derivation s gdb). - (or (and file (hash-ref %derivation-cache file)) - (let ((drv (call-with-input-file file read-derivation))) - (hash-set! %derivation-cache file drv) - drv))) - -(define-inlinable (write-sequence lst write-item port) - ;; Write each element of LST with WRITE-ITEM to PORT, separating them wi= th a - ;; comma. - (match lst - (() - #t) - ((prefix (... ...) last) - (for-each (lambda (item) - (write-item item port) - (display "," port)) - prefix) - (write-item last port)))) - -(define-inlinable (write-list lst write-item port) - ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each - ;; element. - (display "[" port) - (write-sequence lst write-item port) - (display "]" port)) - -(define-inlinable (write-tuple lst write-item port) - ;; Same, but write LST as a tuple. - (display "(" port) - (write-sequence lst write-item port) - (display ")" port)) - -(define (write-derivation drv port) - "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of -Eelco Dolstra's PhD dissertation for an overview of a previous version of -that form." - - ;; Make sure we're using the faster implementation. - (define format simple-format) - - (define (write-string-list lst) - (write-list lst write port)) - - (define (write-output output port) - (match output - ((name . ($ path hash-algo hash recursive?)) - (write-tuple (list name path - (if hash-algo - (string-append (if recursive? "r:" "") - (symbol->string hash-algo)) - "") - (or (and=3D> hash bytevector->base16-string) - "")) - write - port)))) - - (define (write-input input port) - (match input - (($ path sub-drvs) - (display "(\"" port) - (display path port) - (display "\"," port) - (write-string-list sub-drvs) - (display ")" port)))) - - (define (write-env-var env-var port) - (match env-var - ((name . value) - (display "(" port) - (write name port) - (display "," port) - (write value port) - (display ")" port)))) - - ;; Assume all the lists we are writing are already sorted. - (match drv - (($ outputs inputs sources - system builder args env-vars) - (display "Derive(" port) - (write-list outputs write-output port) - (display "," port) - (write-list inputs write-input port) - (display "," port) - (write-string-list sources) - (simple-format port ",\"~a\",\"~a\"," system builder) - (write-string-list args) - (display "," port) - (write-list env-vars write-env-var port) - (display ")" port)))) - -(define derivation->bytevector - (mlambda (drv) - "Return the external representation of DRV as a UTF-8-encoded string." - (with-fluids ((%default-port-encoding "UTF-8")) - (call-with-values open-bytevector-output-port - (lambda (port get-bytevector) - (write-derivation drv port) - (get-bytevector)))))) - (define* (derivation->output-path drv #:optional (output "out")) "Return the store path of its output OUTPUT. Raise a '&derivation-missing-output-error' condition if OUTPUT is not an output of diff --git a/guix/store.scm b/guix/store.scm index 0a0a7c7c52..d1ccf36f27 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . =20 (define-module (guix store) + #:use-module (guix store files) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix deprecation) @@ -163,18 +164,18 @@ interned-file interned-file-tree =20 - %store-prefix - store-path - output-path - fixed-output-path - store-path? - direct-store-path? - derivation-path? - store-path-package-name - store-path-hash-part - direct-store-path - derivation-log-file - log-file)) + log-file) + #:re-export (%store-prefix + store-path + output-path + fixed-output-path + store-path? + direct-store-path? + derivation-path? + store-path-package-name + store-path-hash-part + direct-store-path + derivation-log-file)) =20 (define %protocol-version #x163) =20 @@ -193,6 +194,7 @@ ((_ name->int (name id) ...) (define-syntax name->int (syntax-rules (name ...) + ((_) '(name ...)) ((_ name) id) ...))))) =20 (define-enumerate-type operation-id @@ -1740,134 +1742,7 @@ connection, and return the result." result)))) =20 -;;; -;;; Store paths. -;;; - -(define %store-prefix - ;; Absolute path to the Nix store. - (make-parameter %store-directory)) - -(define (compressed-hash bv size) ; `compressHash' - "Given the hash stored in BV, return a compressed version thereof that f= its -in SIZE bytes." - (define new (make-bytevector size 0)) - (define old-size (bytevector-length bv)) - (let loop ((i 0)) - (if (=3D i old-size) - new - (let* ((j (modulo i size)) - (o (bytevector-u8-ref new j))) - (bytevector-u8-set! new j - (logxor o (bytevector-u8-ref bv i))) - (loop (+ 1 i)))))) - -(define (store-path type hash name) ; makeStorePath - "Return the store path for NAME/HASH/TYPE." - (let* ((s (string-append type ":sha256:" - (bytevector->base16-string hash) ":" - (%store-prefix) ":" name)) - (h (sha256 (string->utf8 s))) - (c (compressed-hash h 20))) - (string-append (%store-prefix) "/" - (bytevector->nix-base32-string c) "-" - name))) - -(define (output-path output hash name) ; makeOutputPath - "Return an output path for OUTPUT (the name of the output as a string) of -the derivation called NAME with hash HASH." - (store-path (string-append "output:" output) hash - (if (string=3D? output "out") - name - (string-append name "-" output)))) - -(define* (fixed-output-path name hash - #:key - (output "out") - (hash-algo 'sha256) - (recursive? #t)) - "Return an output path for the fixed output OUTPUT defined by HASH of ty= pe -HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for -'add-to-store'." - (if (and recursive? (eq? hash-algo 'sha256)) - (store-path "source" hash name) - (let ((tag (string-append "fixed:" output ":" - (if recursive? "r:" "") - (symbol->string hash-algo) ":" - (bytevector->base16-string hash) ":"))) - (store-path (string-append "output:" output) - (sha256 (string->utf8 tag)) - name)))) - -(define (store-path? path) - "Return #t if PATH is a store path." - ;; This is a lightweight check, compared to using a regexp, but this has= to - ;; be fast as it's called often in `derivation', for instance. - ;; `isStorePath' in Nix does something similar. - (string-prefix? (%store-prefix) path)) - -(define (direct-store-path? path) - "Return #t if PATH is a store path, and not a sub-directory of a store p= ath. -This predicate is sometimes needed because files *under* a store path are = not -valid inputs." - (and (store-path? path) - (not (string=3D? path (%store-prefix))) - (let ((len (+ 1 (string-length (%store-prefix))))) - (not (string-index (substring path len) #\/))))) - -(define (direct-store-path path) - "Return the direct store path part of PATH, stripping components after -'/gnu/store/xxxx-foo'." - (let ((prefix-length (+ (string-length (%store-prefix)) 35))) - (if (> (string-length path) prefix-length) - (let ((slash (string-index path #\/ prefix-length))) - (if slash (string-take path slash) path)) - path))) - -(define (derivation-path? path) - "Return #t if PATH is a derivation path." - (and (store-path? path) (string-suffix? ".drv" path))) - -(define store-regexp* - ;; The substituter makes repeated calls to 'store-path-hash-part', hence - ;; this optimization. - (mlambda (store) - "Return a regexp matching a file in STORE." - (make-regexp (string-append "^" (regexp-quote store) - "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))) - -(define (store-path-package-name path) - "Return the package name part of PATH, a file name in the store." - (let ((path-rx (store-regexp* (%store-prefix)))) - (and=3D> (regexp-exec path-rx path) - (cut match:substring <> 2)))) - -(define (store-path-hash-part path) - "Return the hash part of PATH as a base32 string, or #f if PATH is not a -syntactically valid store path." - (and (string-prefix? (%store-prefix) path) - (let ((base (string-drop path (+ 1 (string-length (%store-prefix)))= ))) - (and (> (string-length base) 33) - (let ((hash (string-take base 32))) - (and (string-every %nix-base32-charset hash) - hash)))))) - -(define (derivation-log-file drv) - "Return the build log file for DRV, a derivation file name, or #f if it -could not be found." - (let* ((base (basename drv)) - (log (string-append (or (getenv "GUIX_LOG_DIRECTORY") - (string-append %localstatedir "/log/g= uix")) - "/drvs/" - (string-take base 2) "/" - (string-drop base 2))) - (log.gz (string-append log ".gz")) - (log.bz2 (string-append log ".bz2"))) - (cond ((file-exists? log.gz) log.gz) - ((file-exists? log.bz2) log.bz2) - ((file-exists? log) log) - (else #f)))) - +;; Uses VALID-DERIVERS, so can't go in (guix store files) (define (log-file store file) "Return the build log file for FILE, or #f if none could be found. FILE must be an absolute store file name, or a derivation file name." diff --git a/guix/store/derivations.scm b/guix/store/derivations.scm new file mode 100644 index 0000000000..583c7b449a --- /dev/null +++ b/guix/store/derivations.scm @@ -0,0 +1,287 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Cour= t=C3=A8s +;;; Copyright =C2=A9 2016, 2017 Mathieu Lirzin +;;; Copyright =C2=A9 2019 Caleb Ristvedt +;;; +;;; 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 store derivations) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (guix base16) + #:use-module (guix memoization) + #:export ( + make-derivation + derivation? + derivation-outputs + derivation-inputs + derivation-sources + derivation-system + derivation-builder + derivation-builder-arguments + derivation-builder-environment-vars + derivation-file-name + + + make-derivation-output + derivation-output? + derivation-output-path + derivation-output-hash-algo + derivation-output-hash + derivation-output-recursive? + + + make-derivation-input + derivation-input? + derivation-input-path + derivation-input-sub-derivations + + read-derivation + read-derivation-from-file + derivation->bytevector + %derivation-cache + write-derivation)) + +;;; +;;; Nix derivations, as implemented in Nix's `derivations.cc'. +;;; + +(define-immutable-record-type + (make-derivation outputs inputs sources system builder args env-vars + file-name) + derivation? + (outputs derivation-outputs) ; list of name/ pa= irs + (inputs derivation-inputs) ; list of + (sources derivation-sources) ; list of store paths + (system derivation-system) ; string + (builder derivation-builder) ; store path + (args derivation-builder-arguments) ; list of strings + (env-vars derivation-builder-environment-vars) ; list of name/value pai= rs + (file-name derivation-file-name)) ; the .drv file name + +(define-immutable-record-type + (make-derivation-output path hash-algo hash recursive?) + derivation-output? + (path derivation-output-path) ; store path + (hash-algo derivation-output-hash-algo) ; symbol | #f + (hash derivation-output-hash) ; bytevector | #f + (recursive? derivation-output-recursive?)) ; Boolean + +(define-immutable-record-type + (make-derivation-input path sub-derivations) + derivation-input? + (path derivation-input-path) ; store path + (sub-derivations derivation-input-sub-derivations)) ; list of strings + +(set-record-type-printer! + (lambda (drv port) + (format port "# ~a ~a>" + (derivation-file-name drv) + (string-join + (map (match-lambda + ((_ . output) + (derivation-output-path output= ))) + (derivation-outputs drv))) + (number->string (object-address drv) 1= 6)))) + +(define (read-derivation drv-port) + "Read the derivation from DRV-PORT and return the corresponding +object. Most of the time you'll want to use 'read-derivation-from-file', +which caches things as appropriate and is thus more efficient." + + (define comma (string->symbol ",")) + + (define (ununquote x) + (match x + (('unquote x) (ununquote x)) + ((x ...) (map ununquote x)) + (_ x))) + + (define (outputs->alist x) + (fold-right (lambda (output result) + (match output + ((name path "" "") + (alist-cons name + (make-derivation-output path #f #f #f) + result)) + ((name path hash-algo hash) + ;; fixed-output + (let* ((rec? (string-prefix? "r:" hash-algo)) + (algo (string->symbol + (if rec? + (string-drop hash-algo 2) + hash-algo))) + (hash (base16-string->bytevector hash))) + (alist-cons name + (make-derivation-output path algo + hash rec?) + result))))) + '() + x)) + + (define (make-input-drvs x) + (fold-right (lambda (input result) + (match input + ((path (sub-drvs ...)) + (cons (make-derivation-input path sub-drvs) + result)))) + '() + x)) + + ;; The contents of a derivation are typically ASCII, but choosing + ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'. + (set-port-encoding! drv-port "UTF-8") + + (let loop ((exp (read drv-port)) + (result '())) + (match exp + ((? eof-object?) + (let ((result (reverse result))) + (match result + (('Derive ((outputs ...) (input-drvs ...) + (input-srcs ...) + (? string? system) + (? string? builder) + ((? string? args) ...) + ((var value) ...))) + (make-derivation (outputs->alist outputs) + (make-input-drvs input-drvs) + input-srcs + system builder args + (fold-right alist-cons '() var value) + (port-filename drv-port))) + (_ + (error "failed to parse derivation" drv-port result))))) + ((? (cut eq? <> comma)) + (loop (read drv-port) result)) + (_ + (loop (read drv-port) + (cons (ununquote exp) result)))))) + +(define %derivation-cache + ;; Maps derivation file names to objects. + ;; XXX: This is redundant with 'atts-cache' in the store. + (make-weak-value-hash-table 200)) + +(define (read-derivation-from-file file) + "Read the derivation in FILE, a '.drv' file, and return the corresponding + object." + ;; Memoize that operation because 'read-derivation' is quite expensive, + ;; and because the same argument is read more than 15 times on average + ;; during something like (package-derivation s gdb). + (or (and file (hash-ref %derivation-cache file)) + (let ((drv (call-with-input-file file read-derivation))) + (hash-set! %derivation-cache file drv) + drv))) + +(define-inlinable (write-sequence lst write-item port) + ;; Write each element of LST with WRITE-ITEM to PORT, separating them wi= th a + ;; comma. + (match lst + (() + #t) + ((prefix (... ...) last) + (for-each (lambda (item) + (write-item item port) + (display "," port)) + prefix) + (write-item last port)))) + +(define-inlinable (write-list lst write-item port) + ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each + ;; element. + (display "[" port) + (write-sequence lst write-item port) + (display "]" port)) + +(define-inlinable (write-tuple lst write-item port) + ;; Same, but write LST as a tuple. + (display "(" port) + (write-sequence lst write-item port) + (display ")" port)) + +(define (write-derivation drv port) + "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of +Eelco Dolstra's PhD dissertation for an overview of a previous version of +that form." + + ;; Make sure we're using the faster implementation. + (define format simple-format) + + (define (write-string-list lst) + (write-list lst write port)) + + (define (write-output output port) + (match output + ((name . ($ path hash-algo hash recursive?)) + (write-tuple (list name path + (if hash-algo + (string-append (if recursive? "r:" "") + (symbol->string hash-algo)) + "") + (or (and=3D> hash bytevector->base16-string) + "")) + write + port)))) + + (define (write-input input port) + (match input + (($ path sub-drvs) + (display "(\"" port) + (display path port) + (display "\"," port) + (write-string-list sub-drvs) + (display ")" port)))) + + (define (write-env-var env-var port) + (match env-var + ((name . value) + (display "(" port) + (write name port) + (display "," port) + (write value port) + (display ")" port)))) + + ;; Assume all the lists we are writing are already sorted. + (match drv + (($ outputs inputs sources + system builder args env-vars) + (display "Derive(" port) + (write-list outputs write-output port) + (display "," port) + (write-list inputs write-input port) + (display "," port) + (write-string-list sources) + (simple-format port ",\"~a\",\"~a\"," system builder) + (write-string-list args) + (display "," port) + (write-list env-vars write-env-var port) + (display ")" port)))) + +(define derivation->bytevector + (mlambda (drv) + "Return the external representation of DRV as a UTF-8-encoded string." + (with-fluids ((%default-port-encoding "UTF-8")) + (call-with-values open-bytevector-output-port + (lambda (port get-bytevector) + (write-derivation drv port) + (get-bytevector)))))) + diff --git a/guix/store/files.scm b/guix/store/files.scm new file mode 100644 index 0000000000..06ed0398ba --- /dev/null +++ b/guix/store/files.scm @@ -0,0 +1,171 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovi= c Court=C3=A8s +;;; Copyright =C2=A9 2018 Jan Nieuwenhuizen +;;; Copyright =C2=A9 2019 Caleb Ristvedt +;;; +;;; 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 store files) + #:use-module (ice-9 regex) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-26) + #:use-module (gcrypt hash) + #:use-module (guix base32) + #:use-module (guix base16) + #:use-module (guix config) + #:use-module (guix memoization) + #:export (%store-prefix + store-path + output-path + fixed-output-path + store-path? + direct-store-path? + derivation-path? + store-path-package-name + store-path-hash-part + direct-store-path + derivation-log-file + log-file)) + +;;; +;;; Store paths. +;;; + +(define %store-prefix + ;; Absolute path to the Nix store. + (make-parameter %store-directory)) + +(define (compressed-hash bv size) ; `compressHash' + "Given the hash stored in BV, return a compressed version thereof that f= its +in SIZE bytes." + (define new (make-bytevector size 0)) + (define old-size (bytevector-length bv)) + (let loop ((i 0)) + (if (=3D i old-size) + new + (let* ((j (modulo i size)) + (o (bytevector-u8-ref new j))) + (bytevector-u8-set! new j + (logxor o (bytevector-u8-ref bv i))) + (loop (+ 1 i)))))) + +(define (store-path type hash name) ; makeStorePath + "Return the store path for NAME/HASH/TYPE." + (let* ((s (string-append type ":sha256:" + (bytevector->base16-string hash) ":" + (%store-prefix) ":" name)) + (h (sha256 (string->utf8 s))) + (c (compressed-hash h 20))) + (string-append (%store-prefix) "/" + (bytevector->nix-base32-string c) "-" + name))) + +(define (output-path output hash name) ; makeOutputPath + "Return an output path for OUTPUT (the name of the output as a string) of +the derivation called NAME with hash HASH." + (store-path (string-append "output:" output) hash + (if (string=3D? output "out") + name + (string-append name "-" output)))) + +(define* (fixed-output-path name hash + #:key + (output "out") + (hash-algo 'sha256) + (recursive? #t)) + "Return an output path for the fixed output OUTPUT defined by HASH of ty= pe +HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for +'add-to-store'." + (if (and recursive? (eq? hash-algo 'sha256)) + (store-path "source" hash name) + (let ((tag (string-append "fixed:" output ":" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" + (bytevector->base16-string hash) ":"))) + (store-path (string-append "output:" output) + (sha256 (string->utf8 tag)) + name)))) + +(define (store-path? path) + "Return #t if PATH is a store path." + ;; This is a lightweight check, compared to using a regexp, but this has= to + ;; be fast as it's called often in `derivation', for instance. + ;; `isStorePath' in Nix does something similar. + (string-prefix? (%store-prefix) path)) + +(define (direct-store-path? path) + "Return #t if PATH is a store path, and not a sub-directory of a store p= ath. +This predicate is sometimes needed because files *under* a store path are = not +valid inputs." + (and (store-path? path) + (not (string=3D? path (%store-prefix))) + (let ((len (+ 1 (string-length (%store-prefix))))) + (not (string-index (substring path len) #\/))))) + +(define (direct-store-path path) + "Return the direct store path part of PATH, stripping components after +'/gnu/store/xxxx-foo'." + (let ((prefix-length (+ (string-length (%store-prefix)) 35))) + (if (> (string-length path) prefix-length) + (let ((slash (string-index path #\/ prefix-length))) + (if slash (string-take path slash) path)) + path))) + +(define (derivation-path? path) + "Return #t if PATH is a derivation path." + (and (store-path? path) (string-suffix? ".drv" path))) + +(define store-regexp* + ;; The substituter makes repeated calls to 'store-path-hash-part', hence + ;; this optimization. + (mlambda (store) + "Return a regexp matching a file in STORE." + (make-regexp (string-append "^" (regexp-quote store) + "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))) + +(define (store-path-package-name path) + "Return the package name part of PATH, a file name in the store." + (let ((path-rx (store-regexp* (%store-prefix)))) + (and=3D> (regexp-exec path-rx path) + (cut match:substring <> 2)))) + +(define (store-path-hash-part path) + "Return the hash part of PATH as a base32 string, or #f if PATH is not a +syntactically valid store path." + (and (string-prefix? (%store-prefix) path) + (let ((base (string-drop path (+ 1 (string-length (%store-prefix)))= ))) + (and (> (string-length base) 33) + (let ((hash (string-take base 32))) + (and (string-every %nix-base32-charset hash) + hash)))))) + +(define (derivation-log-file drv) + "Return the build log file for DRV, a derivation file name, or #f if it +could not be found." + (let* ((base (basename drv)) + (log (string-append (or (getenv "GUIX_LOG_DIRECTORY") + (string-append %localstatedir "/log/g= uix")) + "/drvs/" + (string-take base 2) "/" + (string-drop base 2))) + (log.gz (string-append log ".gz")) + (log.bz2 (string-append log ".bz2"))) + (cond ((file-exists? log.gz) log.gz) + ((file-exists? log.bz2) log.bz2) + ((file-exists? log) log) + (else #f)))) + + --=20 2.21.0 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0002-guix-store-Register-derivation-outputs.patch >From d847f7556790723cd230ef00ff4e106512299f86 Mon Sep 17 00:00:00 2001 From: Caleb Ristvedt Date: Wed, 13 Feb 2019 02:19:42 -0600 Subject: [PATCH 2/2] guix: store: Register derivation outputs. * guix/store/database.scm (register-output-sql, derivation-outputs-sql): new variables. (registered-derivation-outputs): new procedure. ((guix store derivations), (guix store files)): used for and derivation-path?, respectively. (register-items): if item is a derivation, also register its outputs. * tests/store-database.scm (register-path): first register a dummy derivation for the test file, and check that its outputs are registered in the DerivationOutputs table and are equal to what was specified in the dummy derivation. --- guix/store/database.scm | 41 ++++++++++++++++++++++++++++++++++++++++ tests/store-database.scm | 30 ++++++++++++++++++++++++++++- 2 files changed, 70 insertions(+), 1 deletion(-) diff --git a/guix/store/database.scm b/guix/store/database.scm index 88d05dc42e..22f411597a 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -21,6 +21,8 @@ #:use-module (sqlite3) #:use-module (guix config) #:use-module (guix serialization) + #:use-module (guix store derivations) + #:use-module (guix store files) #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix progress) @@ -42,6 +44,7 @@ sqlite-register register-path register-items + registered-derivation-outputs %epoch reset-timestamps)) @@ -282,6 +285,26 @@ be used internally by the daemon's build hook." ;; When it all began. (make-time time-utc 0 1)) +(define derivation-outputs-sql "SELECT id, path FROM DerivationOutputs WHERE +drv in (SELECT id from ValidPaths where path = :drv)") + +(define (registered-derivation-outputs db drv) + "Get the list of (id, output-path) pairs registered for DRV." + (let ((stmt (sqlite-prepare db derivation-outputs-sql #:cache? #t))) + (sqlite-bind-arguments stmt #:drv drv) + (let ((result (sqlite-fold (lambda (current prev) + (match current + (#(id path) + (cons (cons id path) + prev)))) + '() stmt))) + (sqlite-finalize stmt) + result))) + +(define register-output-sql + "INSERT OR REPLACE INTO DerivationOutputs (drv, id, path) SELECT id, :outid, +:outpath FROM ValidPaths WHERE path = :drvpath;") + (define* (register-items items #:key prefix state-directory (deduplicate? #t) @@ -330,6 +353,21 @@ Write a progress report to LOG-PORT." (define real-file-name (string-append store-dir "/" (basename (store-info-item item)))) + (define (register-derivation-outputs drv) + "Register all output paths of DRV as being produced by it (note that +this doesn't mean 'already produced by it', but rather just 'associated with +it')." + (let ((stmt (sqlite-prepare db register-output-sql #:cache? #t))) + (for-each (match-lambda + ((outid . ($ path)) + (sqlite-bind-arguments stmt + #:drvpath (derivation-file-name + drv) + #:outid outid + #:outpath path) + (sqlite-fold noop #f stmt))) + (derivation-outputs drv)) + (sqlite-finalize stmt))) ;; When TO-REGISTER is already registered, skip it. This makes a ;; significant differences when 'register-closures' is called @@ -345,6 +383,9 @@ Write a progress report to LOG-PORT." (bytevector->base16-string hash)) #:nar-size nar-size #:time registration-time) + (when (derivation-path? real-file-name) + (register-derivation-outputs (read-derivation-from-file + real-file-name))) (when deduplicate? (deduplicate real-file-name hash #:store store-dir))))) diff --git a/tests/store-database.scm b/tests/store-database.scm index 4d91884250..d5fb916586 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix store database) + #:use-module (guix derivations) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) @@ -44,14 +45,41 @@ (drv (string-append file ".drv"))) (call-with-output-file file (cut display "This is a fake store item.\n" <>)) + (when (valid-path? %store drv) + (delete-paths %store (list drv))) + (call-with-output-file drv + (lambda (port) + ;; XXX: we should really go from derivation to output path as is + ;; usual, currently any verification done on this derivation will + ;; cause an error. + (write-derivation ((@@ (guix derivations) make-derivation) + ;; outputs + (list (cons "out" + ((@@ (guix derivations) + make-derivation-output) + file + #f + #f + #f))) + ;; inputs sources system builder args + '() '() "" "" '() + ;; env-vars filename + '() drv) + port))) + (register-path drv) (register-path file #:references (list ref) #:deriver drv) (and (valid-path? %store file) (equal? (references %store file) (list ref)) - (null? (valid-derivers %store file)) + ;; We expect the derivation outputs to be automatically + ;; registered. + (not (null? (valid-derivers %store file))) (null? (referrers %store file)) + (equal? (with-database %default-database-file db + (registered-derivation-outputs db drv)) + `(("out" . ,file))) (list (stat:mtime (lstat file)) (stat:mtime (lstat ref))))))) -- 2.21.0 --=-=-= Content-Type: text/plain - reepca --=-=-=--