>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-name, 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? &derivation-error @@ -82,9 +61,6 @@ derivation-hash derivation-properties - 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) ;; 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)) ;;; ;;; Error conditions. @@ -121,48 +123,6 @@ derivation-missing-output-error? (output derivation-missing-output)) -;;; -;;; 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/ pairs - (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 pairs - (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) 16)))) - (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 'substitution-oracle'." inputs) (map derivation-input-sub-derivations inputs))))))) -(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 with 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=> 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 . (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 - %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)) (define %protocol-version #x163) @@ -193,6 +194,7 @@ ((_ name->int (name id) ...) (define-syntax name->int (syntax-rules (name ...) + ((_) '(name ...)) ((_ name) id) ...))))) (define-enumerate-type operation-id @@ -1740,134 +1742,7 @@ connection, and return the result." result)))) -;;; -;;; 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 fits -in SIZE bytes." - (define new (make-bytevector size 0)) - (define old-size (bytevector-length bv)) - (let loop ((i 0)) - (if (= 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=? 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 type -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 path. -This predicate is sometimes needed because files *under* a store path are not -valid inputs." - (and (store-path? path) - (not (string=? 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=> (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/guix")) - "/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 © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017 Mathieu Lirzin +;;; Copyright © 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/ pairs + (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 pairs + (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) 16)))) + +(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 with 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=> 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 © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2018 Jan Nieuwenhuizen +;;; Copyright © 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 fits +in SIZE bytes." + (define new (make-bytevector size 0)) + (define old-size (bytevector-length bv)) + (let loop ((i 0)) + (if (= 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=? 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 type +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 path. +This predicate is sometimes needed because files *under* a store path are not +valid inputs." + (and (store-path? path) + (not (string=? 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=> (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/guix")) + "/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)))) + + -- 2.21.0