summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/config.scm.in6
-rw-r--r--guix/docker.scm6
-rw-r--r--guix/gexp.scm196
-rw-r--r--guix/man-db.scm6
-rw-r--r--guix/profiles.scm68
-rw-r--r--guix/records.scm31
-rw-r--r--guix/scripts/pack.scm41
-rw-r--r--guix/scripts/system.scm8
-rw-r--r--guix/self.scm25
-rw-r--r--guix/store/database.scm234
-rw-r--r--guix/store/deduplication.scm148
11 files changed, 642 insertions, 127 deletions
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 8f2c4abd8e..dfe5fe0dbf 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +30,7 @@
%store-directory
%state-directory
+ %store-database-directory
%config-directory
%guix-register-program
@@ -80,6 +82,10 @@
(or (getenv "NIX_STATE_DIR")
(string-append %localstatedir "/guix")))
+(define %store-database-directory
+ (or (and=> (getenv "NIX_DB_DIR") canonicalize-path)
+ (string-append %state-directory "/db")))
+
(define %config-directory
;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
(or (getenv "GUIX_CONFIGURATION_DIRECTORY")
diff --git a/guix/docker.scm b/guix/docker.scm
index a75534c33b..b869901599 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -26,6 +26,7 @@
delete-file-recursively
with-directory-excursion
invoke))
+ #:use-module (json) ;guile-json
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module ((texinfo string-utils)
@@ -34,9 +35,6 @@
#:use-module (ice-9 match)
#:export (build-docker-image))
-;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
-(module-use! (current-module) (resolve-interface '(json)))
-
;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
(define docker-id
(compose bytevector->base16-string sha256 string->utf8))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index c6d70e4e36..153b29bd42 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -33,6 +33,7 @@
#:export (gexp
gexp?
with-imported-modules
+ with-extensions
gexp-input
gexp-input?
@@ -118,10 +119,11 @@
;; "G expressions".
(define-record-type <gexp>
- (make-gexp references modules proc)
+ (make-gexp references modules extensions proc)
gexp?
(references gexp-references) ;list of <gexp-input>
(modules gexp-self-modules) ;list of module names
+ (extensions gexp-self-extensions) ;list of lowerable things
(proc gexp-proc)) ;procedure
(define (write-gexp gexp port)
@@ -492,19 +494,20 @@ whether this should be considered a \"native\" input or not."
(set-record-type-printer! <gexp-output> write-gexp-output)
-(define (gexp-modules gexp)
- "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
-false, meaning that GEXP is a plain Scheme object, return the empty list."
+(define (gexp-attribute gexp self-attribute)
+ "Recurse on GEXP and the expressions it refers to, summing the items
+returned by SELF-ATTRIBUTE, a procedure that takes a gexp."
(if (gexp? gexp)
(delete-duplicates
- (append (gexp-self-modules gexp)
+ (append (self-attribute gexp)
(append-map (match-lambda
(($ <gexp-input> (? gexp? exp))
- (gexp-modules exp))
+ (gexp-attribute exp self-attribute))
(($ <gexp-input> (lst ...))
(append-map (lambda (item)
(if (gexp? item)
- (gexp-modules item)
+ (gexp-attribute item
+ self-attribute)
'()))
lst))
(_
@@ -512,6 +515,17 @@ false, meaning that GEXP is a plain Scheme object, return the empty list."
(gexp-references gexp))))
'())) ;plain Scheme data type
+(define (gexp-modules gexp)
+ "Return the list of Guile module names GEXP relies on. If (gexp? GEXP) is
+false, meaning that GEXP is a plain Scheme object, return the empty list."
+ (gexp-attribute gexp gexp-self-modules))
+
+(define (gexp-extensions gexp)
+ "Return the list of Guile extensions (packages) GEXP relies on. If (gexp?
+GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty
+list."
+ (gexp-attribute gexp gexp-self-extensions))
+
(define* (lower-inputs inputs
#:key system target)
"Turn any package from INPUTS into a derivation for SYSTEM; return the
@@ -577,6 +591,7 @@ names and file names suitable for the #:allowed-references argument to
(modules '())
(module-path %load-path)
(guile-for-build (%guile-for-build))
+ (effective-version "2.2")
(graft? (%graft?))
references-graphs
allowed-references disallowed-references
@@ -595,6 +610,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store,
compiled, and made available in the load path during the execution of
EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
+EFFECTIVE-VERSION determines the string to use when adding extensions of
+EXP (see 'with-extensions') to the search path---e.g., \"2.2\".
+
GRAFT? determines whether packages referred to by EXP should be grafted when
applicable.
@@ -630,7 +648,7 @@ The other arguments are as for 'derivation'."
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda
- ;; TODO: Remove 'derivation?' special cases.
+ ;; TODO: Remove 'derivation?' special cases.
((file-name (? derivation? drv))
(cons file-name (derivation->output-path drv)))
((file-name (? derivation? drv) sub-drv)
@@ -639,7 +657,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing)))
graphs))
- (mlet* %store-monad (;; The following binding forces '%current-system' and
+ (define (extension-flags extension)
+ `("-L" ,(string-append (derivation->output-path extension)
+ "/share/guile/site/" effective-version)
+ "-C" ,(string-append (derivation->output-path extension)
+ "/lib/guile/" effective-version "/site-ccache")))
+
+ (mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
;; time.
(graft? (set-grafting graft?))
@@ -660,6 +684,11 @@ The other arguments are as for 'derivation'."
#:target target))
(builder (text-file script-name
(object->string sexp)))
+ (extensions -> (gexp-extensions exp))
+ (exts (mapm %store-monad
+ (lambda (obj)
+ (lower-object obj system))
+ extensions))
(modules (if (pair? %modules)
(imported-modules %modules
#:system system
@@ -672,6 +701,7 @@ The other arguments are as for 'derivation'."
(compiled-modules %modules
#:system system
#:module-path module-path
+ #:extensions extensions
#:guile guile-for-build
#:deprecation-warnings
deprecation-warnings)
@@ -704,6 +734,7 @@ The other arguments are as for 'derivation'."
`("-L" ,(derivation->output-path modules)
"-C" ,(derivation->output-path compiled))
'())
+ ,@(append-map extension-flags exts)
,builder)
#:outputs outputs
#:env-vars env-vars
@@ -713,6 +744,7 @@ The other arguments are as for 'derivation'."
,@(if modules
`((,modules) (,compiled) ,@inputs)
inputs)
+ ,@(map list exts)
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@@ -861,6 +893,17 @@ environment."
(identifier-syntax modules)))
body ...))
+(define-syntax-parameter current-imported-extensions
+ ;; Current list of extensions.
+ (identifier-syntax '()))
+
+(define-syntax-rule (with-extensions extensions body ...)
+ "Mark the gexps defined in BODY... as requiring EXTENSIONS in their
+execution environment."
+ (syntax-parameterize ((current-imported-extensions
+ (identifier-syntax extensions)))
+ body ...))
+
(define-syntax gexp
(lambda (s)
(define (collect-escapes exp)
@@ -957,6 +1000,7 @@ environment."
(refs (map escape->ref escapes)))
#`(make-gexp (list #,@refs)
current-imported-modules
+ current-imported-extensions
(lambda #,formals
#,sexp)))))))
@@ -1071,12 +1115,21 @@ last one is created from the given <scheme-file> object."
(system (%current-system))
(guile (%guile-for-build))
(module-path %load-path)
+ (extensions '())
(deprecation-warnings #f))
"Return a derivation that builds a tree containing the `.go' files
corresponding to MODULES. All the MODULES are built in a context where
they can refer to each other."
(define total (length modules))
+ (define build-utils-hack?
+ ;; To avoid a full rebuild, we limit the fix below to the case where
+ ;; MODULE-PATH is different from %LOAD-PATH. This happens when building
+ ;; modules for 'compute-guix-derivation' upon 'guix pull'. TODO: Make
+ ;; this unconditional on the next rebuild cycle.
+ (and (member '(guix build utils) modules)
+ (not (equal? module-path %load-path))))
+
(mlet %store-monad ((modules (imported-modules modules
#:system system
#:guile guile
@@ -1122,7 +1175,47 @@ they can refer to each other."
(setvbuf (current-output-port)
(cond-expand (guile-2.2 'line) (else _IOLBF)))
+ (ungexp-splicing
+ (if build-utils-hack?
+ (gexp ((define mkdir-p
+ ;; Capture 'mkdir-p'.
+ (@ (guix build utils) mkdir-p))))
+ '()))
+
+ ;; Add EXTENSIONS to the search path.
+ ;; TODO: Remove the outer 'ungexp-splicing' on the next rebuild cycle.
+ (ungexp-splicing
+ (if (null? extensions)
+ '()
+ (gexp ((set! %load-path
+ (append (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ '((ungexp-native-splicing extensions)))
+ %load-path))
+ (set! %load-compiled-path
+ (append (map (lambda (extension)
+ (string-append extension "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ '((ungexp-native-splicing extensions)))
+ %load-compiled-path))))))
+
(set! %load-path (cons (ungexp modules) %load-path))
+
+ (ungexp-splicing
+ (if build-utils-hack?
+ ;; Above we loaded our own (guix build utils) but now we may
+ ;; need to load a compile a different one. Thus, force a
+ ;; reload.
+ (gexp ((let ((utils (ungexp
+ (file-append modules
+ "/guix/build/utils.scm"))))
+ (when (file-exists? utils)
+ (load utils)))))
+ '()))
+
(mkdir (ungexp output))
(chdir (ungexp modules))
(process-directory "." (ungexp output) 0))))
@@ -1154,20 +1247,34 @@ they can refer to each other."
(module-ref (resolve-interface '(gnu packages guile))
'guile-2.2))
-(define* (load-path-expression modules #:optional (path %load-path))
+(define* (load-path-expression modules #:optional (path %load-path)
+ #:key (extensions '()))
"Return as a monadic value a gexp that sets '%load-path' and
'%load-compiled-path' to point to MODULES, a list of module names. MODULES
are searched for in PATH."
(mlet %store-monad ((modules (imported-modules modules
#:module-path path))
(compiled (compiled-modules modules
+ #:extensions extensions
#:module-path path)))
(return (gexp (eval-when (expand load eval)
(set! %load-path
- (cons (ungexp modules) %load-path))
+ (cons (ungexp modules)
+ (append (map (lambda (extension)
+ (string-append extension
+ "/share/guile/site/"
+ (effective-version)))
+ '((ungexp-native-splicing extensions)))
+ %load-path)))
(set! %load-compiled-path
(cons (ungexp compiled)
- %load-compiled-path)))))))
+ (append (map (lambda (extension)
+ (string-append extension
+ "/lib/guile/"
+ (effective-version)
+ "/site-ccache"))
+ '((ungexp-native-splicing extensions)))
+ %load-compiled-path))))))))
(define* (gexp->script name exp
#:key (guile (default-guile))
@@ -1176,7 +1283,9 @@ are searched for in PATH."
imported modules in its search path. Look up EXP's modules in MODULE-PATH."
(mlet %store-monad ((set-load-path
(load-path-expression (gexp-modules exp)
- module-path)))
+ module-path
+ #:extensions
+ (gexp-extensions exp))))
(gexp->derivation name
(gexp
(call-with-output-file (ungexp output)
@@ -1205,35 +1314,38 @@ the resulting file.
When SET-LOAD-PATH? is true, emit code in the resulting file to set
'%load-path' and '%load-compiled-path' to honor EXP's imported modules.
Lookup EXP's modules in MODULE-PATH."
- (match (if set-load-path? (gexp-modules exp) '())
- (() ;zero modules
- (gexp->derivation name
- (gexp
- (call-with-output-file (ungexp output)
- (lambda (port)
- (for-each (lambda (exp)
- (write exp port))
- '(ungexp (if splice?
- exp
- (gexp ((ungexp exp)))))))))
- #:local-build? #t
- #:substitutable? #f))
- ((modules ...)
- (mlet %store-monad ((set-load-path (load-path-expression modules
- module-path)))
- (gexp->derivation name
- (gexp
- (call-with-output-file (ungexp output)
- (lambda (port)
- (write '(ungexp set-load-path) port)
- (for-each (lambda (exp)
- (write exp port))
- '(ungexp (if splice?
- exp
- (gexp ((ungexp exp)))))))))
- #:module-path module-path
- #:local-build? #t
- #:substitutable? #f)))))
+ (define modules (gexp-modules exp))
+ (define extensions (gexp-extensions exp))
+
+ (if (or (not set-load-path?)
+ (and (null? modules) (null? extensions)))
+ (gexp->derivation name
+ (gexp
+ (call-with-output-file (ungexp output)
+ (lambda (port)
+ (for-each (lambda (exp)
+ (write exp port))
+ '(ungexp (if splice?
+ exp
+ (gexp ((ungexp exp)))))))))
+ #:local-build? #t
+ #:substitutable? #f)
+ (mlet %store-monad ((set-load-path
+ (load-path-expression modules module-path
+ #:extensions extensions)))
+ (gexp->derivation name
+ (gexp
+ (call-with-output-file (ungexp output)
+ (lambda (port)
+ (write '(ungexp set-load-path) port)
+ (for-each (lambda (exp)
+ (write exp port))
+ '(ungexp (if splice?
+ exp
+ (gexp ((ungexp exp)))))))))
+ #:module-path module-path
+ #:local-build? #t
+ #:substitutable? #f))))
(define* (text-file* name #:rest text)
"Return as a monadic value a derivation that builds a text file containing
diff --git a/guix/man-db.scm b/guix/man-db.scm
index 732aef1083..4cef874f8b 100644
--- a/guix/man-db.scm
+++ b/guix/man-db.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +19,7 @@
(define-module (guix man-db)
#:use-module (guix zlib)
#:use-module ((guix build utils) #:select (find-files))
+ #:use-module (gdbm) ;gdbm-ffi
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
@@ -44,9 +45,6 @@
;;;
;;; Code:
-;; Load 'gdbm-ffi' at run time to simplify the job of 'imported-modules' & co.
-(module-autoload! (current-module) '(gdbm) '(gdbm-open GDBM_WRCREAT))
-
(define-record-type <mandb-entry>
(mandb-entry file-name name section synopsis kind)
mandb-entry?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index fd7e5b922c..9bddf88162 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1196,41 +1196,39 @@ the entries in MANIFEST."
(define build
(with-imported-modules modules
- #~(begin
- (add-to-load-path (string-append #$gdbm-ffi "/share/guile/site/"
- (effective-version)))
-
- (use-modules (guix man-db)
- (guix build utils)
- (srfi srfi-1)
- (srfi srfi-19))
-
- (define (compute-entries)
- (append-map (lambda (directory)
- (let ((man (string-append directory "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- '#$(manifest-inputs manifest)))
-
- (define man-directory
- (string-append #$output "/share/man"))
-
- (mkdir-p man-directory)
-
- (format #t "Creating manual page database...~%")
- (force-output)
- (let* ((start (current-time))
- (entries (compute-entries))
- (_ (write-mandb-database (string-append man-directory
- "/index.db")
- entries))
- (duration (time-difference (current-time) start)))
- (format #t "~a entries processed in ~,1f s~%"
- (length entries)
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
- (force-output)))))
+ (with-extensions (list gdbm-ffi) ;for (guix man-db)
+ #~(begin
+ (use-modules (guix man-db)
+ (guix build utils)
+ (srfi srfi-1)
+ (srfi srfi-19))
+
+ (define (compute-entries)
+ (append-map (lambda (directory)
+ (let ((man (string-append directory "/share/man")))
+ (if (directory-exists? man)
+ (mandb-entries man)
+ '())))
+ '#$(manifest-inputs manifest)))
+
+ (define man-directory
+ (string-append #$output "/share/man"))
+
+ (mkdir-p man-directory)
+
+ (format #t "Creating manual page database...~%")
+ (force-output)
+ (let* ((start (current-time))
+ (entries (compute-entries))
+ (_ (write-mandb-database (string-append man-directory
+ "/index.db")
+ entries))
+ (duration (time-difference (current-time) start)))
+ (format #t "~a entries processed in ~,1f s~%"
+ (length entries)
+ (+ (time-second duration)
+ (* (time-nanosecond duration) (expt 10 -9))))
+ (force-output))))))
(gexp->derivation "manual-database" build
diff --git a/guix/records.scm b/guix/records.scm
index c71cfcfe32..da3ecdaaf8 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -63,22 +63,25 @@
(set-exception-printer! 'record-abi-mismatch-error
print-record-abi-mismatch-error)
-(define (current-abi-identifier type)
- "Return an identifier unhygienically derived from TYPE for use as its
+(eval-when (expand load eval)
+ ;; The procedures below are needed both at run time and at expansion time.
+
+ (define (current-abi-identifier type)
+ "Return an identifier unhygienically derived from TYPE for use as its
\"current ABI\" variable."
- (let ((type-name (syntax->datum type)))
- (datum->syntax
- type
- (string->symbol
- (string-append "% " (symbol->string type-name)
- " abi-cookie")))))
-
-(define (abi-check type cookie)
- "Return syntax that checks that the current \"application binary
+ (let ((type-name (syntax->datum type)))
+ (datum->syntax
+ type
+ (string->symbol
+ (string-append "% " (symbol->string type-name)
+ " abi-cookie")))))
+
+ (define (abi-check type cookie)
+ "Return syntax that checks that the current \"application binary
interface\" (ABI) for TYPE is equal to COOKIE."
- (with-syntax ((current-abi (current-abi-identifier type)))
- #`(unless (eq? current-abi #,cookie)
- (throw 'record-abi-mismatch-error #,type))))
+ (with-syntax ((current-abi (current-abi-identifier type)))
+ #`(unless (eq? current-abi #,cookie)
+ (throw 'record-abi-mismatch-error #,type)))))
(define-syntax make-syntactic-constructor
(syntax-rules ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 35b8a7e729..76729d8e10 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -340,28 +340,25 @@ the image."
guile-json))
(define build
- (with-imported-modules `(,@(source-module-closure '((guix docker))
- #:select? not-config?)
- (guix build store-copy)
- ((guix config) => ,config))
- #~(begin
- ;; Guile-JSON is required by (guix docker).
- (add-to-load-path
- (string-append #+json "/share/guile/site/"
- (effective-version)))
-
- (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
-
- (setenv "PATH" (string-append #$archiver "/bin"))
-
- (build-docker-image #$output
- (call-with-input-file "profile"
- read-reference-graph)
- #$profile
- #:system (or #$target (utsname:machine (uname)))
- #:symlinks '#$symlinks
- #:compressor '#$(compressor-command compressor)
- #:creation-time (make-time time-utc 0 1)))))
+ ;; Guile-JSON is required by (guix docker).
+ (with-extensions (list json)
+ (with-imported-modules `(,@(source-module-closure '((guix docker))
+ #:select? not-config?)
+ (guix build store-copy)
+ ((guix config) => ,config))
+ #~(begin
+ (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
+
+ (setenv "PATH" (string-append #$archiver "/bin"))
+
+ (build-docker-image #$output
+ (call-with-input-file "profile"
+ read-reference-graph)
+ #$profile
+ #:system (or #$target (utsname:machine (uname)))
+ #:symlinks '#$symlinks
+ #:compressor '#$(compressor-command compressor)
+ #:creation-time (make-time time-utc 0 1))))))
(gexp->derivation (string-append name ".tar"
(compressor-extension compressor))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 5d0df14924..766cab1aad 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -393,9 +393,11 @@ it atomically, and then run OS's activation script."
"~Y-~m-~d ~H:~M")))
(define* (profile-boot-parameters #:optional (profile %system-profile)
- (numbers (generation-numbers profile)))
- "Return a list of 'boot-parameters' for the generations of PROFILE specified by
-NUMBERS, which is a list of generation numbers."
+ (numbers
+ (reverse (generation-numbers profile))))
+ "Return a list of 'boot-parameters' for the generations of PROFILE specified
+by NUMBERS, which is a list of generation numbers. The list is ordered from
+the most recent to the oldest profiles."
(define (system->boot-parameters system number time)
(unless-file-not-found
(let* ((params (read-boot-parameters-file system))
diff --git a/guix/self.scm b/guix/self.scm
index 4378a3dee5..3503fbda43 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -82,6 +82,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("guile-json" (ref '(gnu packages guile) 'guile-json))
("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
("guile-git" (ref '(gnu packages guile) 'guile-git))
+ ("guile-gdbm-ffi" (ref '(gnu packages guile) 'guile-gdbm-ffi))
+ ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt))
("zlib" (ref '(gnu packages compression) 'zlib))
("gzip" (ref '(gnu packages compression) 'gzip))
@@ -92,6 +94,8 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh))
("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git))
+ ("guile2.0-gdbm-ffi" (ref '(gnu packages guile) 'guile2.0-gdbm-ffi))
+ ;; XXX: No "guile2.0-sqlite3".
(_ #f)))) ;no such package
@@ -215,12 +219,23 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
"guile-git"
"guile2.0-git"))
+ (define guile-gdbm-ffi
+ (package-for-guile guile-version
+ "guile-gdbm-ffi"
+ "guile2.0-gdbm-ffi"))
+
+
+ (define guile-sqlite3
+ (package-for-guile guile-version
+ "guile-sqlite3"
+ "guile2.0-sqlite3"))
(define dependencies
(match (append-map (lambda (package)
(cons (list "x" package)
- (package-transitive-inputs package)))
- (list guile-git guile-json guile-ssh))
+ (package-transitive-propagated-inputs package)))
+ (list guile-git guile-json guile-ssh
+ guile-gdbm-ffi guile-sqlite3))
(((labels packages _ ...) ...)
packages)))
@@ -573,7 +588,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'."
`(#:local-build? #f ;allow substitutes
;; Don't annoy people about _IONBF deprecation.
- #:env-vars (("GUILE_WARN_DEPRECATED" . "no")))))
+ ;; Initialize 'terminal-width' in (system repl debug)
+ ;; to a large-enough value to make backtrace more
+ ;; verbose.
+ #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
+ ("COLUMNS" . "200")))))
;;;
diff --git a/guix/store/database.scm b/guix/store/database.scm
new file mode 100644
index 0000000000..3623c0e7a0
--- /dev/null
+++ b/guix/store/database.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix store database)
+ #:use-module (sqlite3)
+ #:use-module (guix config)
+ #:use-module (guix serialization)
+ #:use-module (guix store deduplication)
+ #:use-module (guix base16)
+ #:use-module (guix build syscalls)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 match)
+ #:export (sqlite-register
+ register-path
+ reset-timestamps))
+
+;;; Code for working with the store database directly.
+
+
+(define-syntax-rule (with-database file db exp ...)
+ "Open DB from FILE and close it when the dynamic extent of EXP... is left."
+ (let ((db (sqlite-open file)))
+ (dynamic-wind noop
+ (lambda ()
+ exp ...)
+ (lambda ()
+ (sqlite-close db)))))
+
+(define (last-insert-row-id db)
+ ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
+ ;; Work around that.
+ (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();"
+ #:cache? #t))
+ (result (sqlite-fold cons '() stmt)))
+ (sqlite-finalize stmt)
+ (match result
+ ((#(id)) id)
+ (_ #f))))
+
+(define path-id-sql
+ "SELECT id FROM ValidPaths WHERE path = :path")
+
+(define* (path-id db path)
+ "If PATH exists in the 'ValidPaths' table, return its numerical
+identifier. Otherwise, return #f."
+ (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t)))
+ (sqlite-bind-arguments stmt #:path path)
+ (let ((result (sqlite-fold cons '() stmt)))
+ (sqlite-finalize stmt)
+ (match result
+ ((#(id) . _) id)
+ (_ #f)))))
+
+(define update-sql
+ "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
+:deriver, narSize = :size WHERE id = :id")
+
+(define insert-sql
+ "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
+VALUES (:path, :hash, :time, :deriver, :size)")
+
+(define* (update-or-insert db #:key path deriver hash nar-size time)
+ "The classic update-if-exists and insert-if-doesn't feature that sqlite
+doesn't exactly have... they've got something close, but it involves deleting
+and re-inserting instead of updating, which causes problems with foreign keys,
+of course. Returns the row id of the row that was modified or inserted."
+ (let ((id (path-id db path)))
+ (if id
+ (let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
+ (sqlite-bind-arguments stmt #:id id
+ #:path path #:deriver deriver
+ #:hash hash #:size nar-size #:time time)
+ (sqlite-fold cons '() stmt)
+ (sqlite-finalize stmt)
+ (last-insert-row-id db))
+ (let ((stmt (sqlite-prepare db insert-sql #:cache? #t)))
+ (sqlite-bind-arguments stmt
+ #:path path #:deriver deriver
+ #:hash hash #:size nar-size #:time time)
+ (sqlite-fold cons '() stmt) ;execute it
+ (sqlite-finalize stmt)
+ (last-insert-row-id db)))))
+
+(define add-reference-sql
+ "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
+FROM ValidPaths WHERE path = :reference")
+
+(define (add-references db referrer references)
+ "REFERRER is the id of the referring store item, REFERENCES is a list
+containing store items being referred to. Note that all of the store items in
+REFERENCES must already be registered."
+ (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
+ (for-each (lambda (reference)
+ (sqlite-reset stmt)
+ (sqlite-bind-arguments stmt #:referrer referrer
+ #:reference reference)
+ (sqlite-fold cons '() stmt) ;execute it
+ (sqlite-finalize stmt)
+ (last-insert-row-id db))
+ references)))
+
+;; XXX figure out caching of statement and database objects... later
+(define* (sqlite-register #:key db-file path (references '())
+ deriver hash nar-size)
+ "Registers this stuff in a database specified by DB-FILE. PATH is the string
+path of some store item, REFERENCES is a list of string paths which the store
+item PATH refers to (they need to be already registered!), DERIVER is a string
+path of the derivation that created the store item PATH, HASH is the
+base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
+\"sha256:\") after being converted to nar form, and nar-size is the size in
+bytes of the store item denoted by PATH after being converted to nar form."
+ (with-database db-file db
+ (let ((id (update-or-insert db #:path path
+ #:deriver deriver
+ #:hash hash
+ #:nar-size nar-size
+ #:time (time-second (current-time time-utc)))))
+ (add-references db id references))))
+
+
+;;;
+;;; High-level interface.
+;;;
+
+;; TODO: Factorize with that in (gnu build install).
+(define (reset-timestamps file)
+ "Reset the modification time on FILE and on all the files it contains, if
+it's a directory."
+ (let loop ((file file)
+ (type (stat:type (lstat file))))
+ (case type
+ ((directory)
+ (utime file 0 0 0 0)
+ (let ((parent file))
+ (for-each (match-lambda
+ (("." . _) #f)
+ ((".." . _) #f)
+ ((file . properties)
+ (let ((file (string-append parent "/" file)))
+ (loop file
+ (match (assoc-ref properties 'type)
+ ((or 'unknown #f)
+ (stat:type (lstat file)))
+ (type type))))))
+ (scandir* parent))))
+ ((symlink)
+ ;; FIXME: Implement bindings for 'futime' to reset the timestamps on
+ ;; symlinks.
+ #f)
+ (else
+ (utime file 0 0 0 0)))))
+
+;; TODO: make this canonicalize store items that are registered. This involves
+;; setting permissions and timestamps, I think. Also, run a "deduplication
+;; pass", whatever that involves. Also, handle databases not existing yet
+;; (what should the default behavior be? Figuring out how the C++ stuff
+;; currently does it sounds like a lot of grepping for global
+;; variables...). Also, return #t on success like the documentation says we
+;; should.
+
+(define* (register-path path
+ #:key (references '()) deriver prefix
+ state-directory (deduplicate? #t))
+ ;; Priority for options: first what is given, then environment variables,
+ ;; then defaults. %state-directory, %store-directory, and
+ ;; %store-database-directory already handle the "environment variables /
+ ;; defaults" question, so we only need to choose between what is given and
+ ;; those.
+ "Register PATH as a valid store file, with REFERENCES as its list of
+references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
+given, it must be the name of the directory containing the new store to
+initialize; if STATE-DIRECTORY is given, it must be a string containing the
+absolute file name to the state directory of the store being initialized.
+Return #t on success.
+
+Use with care as it directly modifies the store! This is primarily meant to
+be used internally by the daemon's build hook."
+ (let* ((db-dir (cond
+ (state-directory
+ (string-append state-directory "/db"))
+ (prefix
+ ;; If prefix is specified, the value of NIX_STATE_DIR
+ ;; (which affects %state-directory) isn't supposed to
+ ;; affect db-dir, only the compile-time-customized
+ ;; default should.
+ (string-append prefix %localstatedir "/guix/db"))
+ (else
+ %store-database-directory)))
+ (store-dir (if prefix
+ ;; same situation as above
+ (string-append prefix %storedir)
+ %store-directory))
+ (to-register (if prefix
+ (string-append %storedir "/" (basename path))
+ ;; note: we assume here that if path is, for
+ ;; example, /foo/bar/gnu/store/thing.txt and prefix
+ ;; isn't given, then an environment variable has
+ ;; been used to change the store directory to
+ ;; /foo/bar/gnu/store, since otherwise real-path
+ ;; would end up being /gnu/store/thing.txt, which is
+ ;; probably not the right file in this case.
+ path))
+ (real-path (string-append store-dir "/" (basename path))))
+ (let-values (((hash nar-size)
+ (nar-sha256 real-path)))
+ (reset-timestamps real-path)
+ (sqlite-register
+ #:db-file (string-append db-dir "/db.sqlite")
+ #:path to-register
+ #:references references
+ #:deriver deriver
+ #:hash (string-append "sha256:"
+ (bytevector->base16-string hash))
+ #:nar-size nar-size)
+
+ (when deduplicate?
+ (deduplicate real-path hash #:store store-dir)))))
diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm
new file mode 100644
index 0000000000..4b4ac01f64
--- /dev/null
+++ b/guix/store/deduplication.scm
@@ -0,0 +1,148 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+;;; This houses stuff we do to files when they arrive at the store - resetting
+;;; timestamps, deduplicating, etc.
+
+(define-module (guix store deduplication)
+ #:use-module (guix hash)
+ #:use-module (guix build utils)
+ #:use-module (guix base16)
+ #:use-module (srfi srfi-11)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 ftw)
+ #:use-module (guix serialization)
+ #:export (nar-sha256
+ deduplicate))
+
+;; Would it be better to just make WRITE-FILE give size as well? I question
+;; the general utility of this approach.
+(define (counting-wrapper-port output-port)
+ "Some custom ports don't implement GET-POSITION at all. But if we want to
+figure out how many bytes are being written, we will want to use that. So this
+makes a wrapper around a port which implements GET-POSITION."
+ (let ((byte-count 0))
+ (make-custom-binary-output-port "counting-wrapper"
+ (lambda (bytes offset count)
+ (set! byte-count
+ (+ byte-count count))
+ (put-bytevector output-port bytes
+ offset count)
+ count)
+ (lambda ()
+ byte-count)
+ #f
+ (lambda ()
+ (close-port output-port)))))
+
+(define (nar-sha256 file)
+ "Gives the sha256 hash of a file and the size of the file in nar form."
+ (let-values (((port get-hash) (open-sha256-port)))
+ (let ((wrapper (counting-wrapper-port port)))
+ (write-file file wrapper)
+ (force-output wrapper)
+ (force-output port)
+ (let ((hash (get-hash))
+ (size (port-position wrapper)))
+ (close-port wrapper)
+ (values hash size)))))
+
+(define (tempname-in directory)
+ "Gives an unused temporary name under DIRECTORY. Not guaranteed to still be
+unused by the time you create anything with that name, but a good shot."
+ (let ((const-part (string-append directory "/.tmp-link-"
+ (number->string (getpid)))))
+ (let try ((guess-part
+ (number->string (random most-positive-fixnum) 16)))
+ (if (file-exists? (string-append const-part "-" guess-part))
+ (try (number->string (random most-positive-fixnum) 16))
+ (string-append const-part "-" guess-part)))))
+
+(define* (get-temp-link target #:optional (link-prefix (dirname target)))
+ "Like mkstemp!, but instead of creating a new file and giving you the name,
+it creates a new hardlink to TARGET and gives you the name. Since
+cross-filesystem hardlinks don't work, the temp link must be created on the
+same filesystem - where in that filesystem it is can be controlled by
+LINK-PREFIX."
+ (let try ((tempname (tempname-in link-prefix)))
+ (catch 'system-error
+ (lambda ()
+ (link target tempname)
+ tempname)
+ (lambda (args)
+ (if (= (system-error-errno args) EEXIST)
+ (try (tempname-in link-prefix))
+ (throw 'system-error args))))))
+
+;; There are 3 main kinds of errors we can get from hardlinking: "Too many
+;; things link to this" (EMLINK), "this link already exists" (EEXIST), and
+;; "can't fit more stuff in this directory" (ENOSPC).
+
+(define (replace-with-link target to-replace)
+ "Atomically replace the file TO-REPLACE with a link to TARGET. Note: TARGET
+and TO-REPLACE must be on the same file system."
+ (let ((temp-link (get-temp-link target (dirname to-replace))))
+ (rename-file temp-link to-replace)))
+
+(define-syntax-rule (false-if-system-error (errors ...) exp ...)
+ "Given ERRORS, a list of system error codes to ignore, evaluates EXP... and
+return #f if any of the system error codes in the given list are thrown."
+ (catch 'system-error
+ (lambda ()
+ exp ...)
+ (lambda args
+ (if (member (system-error-errno args) (list errors ...))
+ #f
+ (apply throw args)))))
+
+(define* (deduplicate path hash #:key (store %store-directory))
+ "Check if a store item with sha256 hash HASH already exists. If so,
+replace PATH with a hardlink to the already-existing one. If not, register
+PATH so that future duplicates can hardlink to it. PATH is assumed to be
+under STORE."
+ (let* ((links-directory (string-append store "/.links"))
+ (link-file (string-append links-directory "/"
+ (bytevector->base16-string hash))))
+ (mkdir-p links-directory)
+ (if (file-is-directory? path)
+ ;; Can't hardlink directories, so hardlink their atoms.
+ (for-each (lambda (file)
+ (unless (member file '("." ".."))
+ (deduplicate file (nar-sha256 file)
+ #:store store)))
+ (scandir path))
+ (if (file-exists? link-file)
+ (false-if-system-error (EMLINK)
+ (replace-with-link link-file path))
+ (catch 'system-error
+ (lambda ()
+ (link path link-file))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EEXIST)
+ ;; Someone else put an entry for PATH in
+ ;; LINKS-DIRECTORY before we could. Let's use it.
+ (false-if-system-error (EMLINK)
+ (replace-with-link path link-file)))
+ ((= errno ENOSPC)
+ ;; There's not enough room in the directory index for
+ ;; more entries in .links, but that's fine: we can
+ ;; just stop.
+ #f)
+ (else (apply throw args))))))))))
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-10 13:18:05 +0000