mirror of
https://codeberg.org/guix/guix.git
synced 2026-01-25 12:05:19 -06:00
14499efc25
* 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 <derivation> 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.
128 lines
4.9 KiB
Scheme
128 lines
4.9 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2017, 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 (test-store-database)
|
||
#: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))
|
||
|
||
;; Test the (guix store database) module.
|
||
|
||
(define %store
|
||
(open-connection-for-tests))
|
||
|
||
|
||
(test-begin "store-database")
|
||
|
||
(test-equal "register-path"
|
||
'(1 1)
|
||
(let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
|
||
"-fake")))
|
||
(when (valid-path? %store file)
|
||
(delete-paths %store (list file)))
|
||
(false-if-exception (delete-file file))
|
||
|
||
(let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
|
||
(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))
|
||
;; 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)))))))
|
||
|
||
(test-equal "new database"
|
||
(list 1 2)
|
||
(call-with-temporary-output-file
|
||
(lambda (db-file port)
|
||
(delete-file db-file)
|
||
(with-database db-file db
|
||
(sqlite-register db
|
||
#:path "/gnu/foo"
|
||
#:references '()
|
||
#:deriver "/gnu/foo.drv"
|
||
#:hash (string-append "sha256:" (make-string 64 #\e))
|
||
#:nar-size 1234)
|
||
(sqlite-register db
|
||
#:path "/gnu/bar"
|
||
#:references '("/gnu/foo")
|
||
#:deriver "/gnu/bar.drv"
|
||
#:hash (string-append "sha256:" (make-string 64 #\a))
|
||
#:nar-size 4321)
|
||
(let ((path-id (@@ (guix store database) path-id)))
|
||
(list (path-id db "/gnu/foo")
|
||
(path-id db "/gnu/bar")))))))
|
||
|
||
(test-assert "register-path with unregistered references"
|
||
;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error
|
||
;; when we try to add references that are not registered yet. Better safe
|
||
;; than sorry.
|
||
(call-with-temporary-output-file
|
||
(lambda (db-file port)
|
||
(delete-file db-file)
|
||
(catch 'sqlite-error
|
||
(lambda ()
|
||
(with-database db-file db
|
||
(sqlite-register db #:path "/gnu/foo"
|
||
#:references '("/gnu/bar")
|
||
#:deriver "/gnu/foo.drv"
|
||
#:hash (string-append "sha256:" (make-string 64 #\e))
|
||
#:nar-size 1234))
|
||
#f)
|
||
(lambda args
|
||
(pk 'welcome-exception! args)
|
||
#t)))))
|
||
|
||
(test-end "store-database")
|