store: Add queries for references & co.
* guix/store.scm (operation-id)[query-valid-derivers]: New value.
  (references, referrers, valid-derivers, query-derivation-outputs): New
  procedures.
* tests/store.scm ("references", "derivers"): New tests.
			
			
This commit is contained in:
		
							parent
							
								
									149acc2981
								
							
						
					
					
						commit
						fae31edcec
					
				
					 2 changed files with 53 additions and 1 deletions
				
			
		|  | @ -66,6 +66,10 @@ | ||||||
|             substitutable-paths |             substitutable-paths | ||||||
|             substitutable-path-info |             substitutable-path-info | ||||||
| 
 | 
 | ||||||
|  |             references | ||||||
|  |             referrers | ||||||
|  |             valid-derivers | ||||||
|  |             query-derivation-outputs | ||||||
|             live-paths |             live-paths | ||||||
|             dead-paths |             dead-paths | ||||||
|             collect-garbage |             collect-garbage | ||||||
|  | @ -126,7 +130,8 @@ | ||||||
|   (query-path-from-hash-part 29) |   (query-path-from-hash-part 29) | ||||||
|   (query-substitutable-path-infos 30) |   (query-substitutable-path-infos 30) | ||||||
|   (query-valid-paths 31) |   (query-valid-paths 31) | ||||||
|   (query-substitutable-paths 32)) |   (query-substitutable-paths 32) | ||||||
|  |   (query-valid-derivers 33)) | ||||||
| 
 | 
 | ||||||
| (define-enumerate-type hash-algo | (define-enumerate-type hash-algo | ||||||
|   ;; hash.hh |   ;; hash.hh | ||||||
|  | @ -597,6 +602,27 @@ name--it is the caller's responsibility to ensure that it is an absolute | ||||||
| file name.  Return #t on success." | file name.  Return #t on success." | ||||||
|   boolean) |   boolean) | ||||||
| 
 | 
 | ||||||
|  | (define references | ||||||
|  |   (operation (query-references (store-path path)) | ||||||
|  |              "Return the list of references of PATH." | ||||||
|  |              store-path-list)) | ||||||
|  | 
 | ||||||
|  | (define referrers | ||||||
|  |   (operation (query-referrers (store-path path)) | ||||||
|  |              "Return the list of path that refer to PATH." | ||||||
|  |              store-path-list)) | ||||||
|  | 
 | ||||||
|  | (define valid-derivers | ||||||
|  |   (operation (query-valid-derivers (store-path path)) | ||||||
|  |              "Return the list of valid \"derivers\" of PATH---i.e., all the | ||||||
|  | .drv present in the store that have PATH among their outputs." | ||||||
|  |              store-path-list)) | ||||||
|  | 
 | ||||||
|  | (define query-derivation-outputs  ; avoid name clash with `derivation-outputs' | ||||||
|  |   (operation (query-derivation-outputs (store-path path)) | ||||||
|  |              "Return the list of outputs of PATH, a .drv file." | ||||||
|  |              store-path-list)) | ||||||
|  | 
 | ||||||
| (define-operation (has-substitutes? (store-path path)) | (define-operation (has-substitutes? (store-path path)) | ||||||
|   "Return #t if binary substitutes are available for PATH, and #f otherwise." |   "Return #t if binary substitutes are available for PATH, and #f otherwise." | ||||||
|   boolean) |   boolean) | ||||||
|  |  | ||||||
|  | @ -23,6 +23,7 @@ | ||||||
|   #:use-module (guix base32) |   #:use-module (guix base32) | ||||||
|   #:use-module (guix packages) |   #:use-module (guix packages) | ||||||
|   #:use-module (guix derivations) |   #:use-module (guix derivations) | ||||||
|  |   #:use-module (gnu packages) | ||||||
|   #:use-module (gnu packages bootstrap) |   #:use-module (gnu packages bootstrap) | ||||||
|   #:use-module (ice-9 match) |   #:use-module (ice-9 match) | ||||||
|   #:use-module (srfi srfi-1) |   #:use-module (srfi srfi-1) | ||||||
|  | @ -79,6 +80,31 @@ | ||||||
|            (> freed 0) |            (> freed 0) | ||||||
|            (not (file-exists? p)))))) |            (not (file-exists? p)))))) | ||||||
| 
 | 
 | ||||||
|  | (test-assert "references" | ||||||
|  |   (let* ((t1 (add-text-to-store %store "random1" | ||||||
|  |                                 (random-text) '())) | ||||||
|  |          (t2 (add-text-to-store %store "random2" | ||||||
|  |                                 (random-text) (list t1)))) | ||||||
|  |     (and (equal? (list t1) (references %store t2)) | ||||||
|  |          (equal? (list t2) (referrers %store t1)) | ||||||
|  |          (null? (references %store t1)) | ||||||
|  |          (null? (referrers %store t2))))) | ||||||
|  | 
 | ||||||
|  | (test-assert "derivers" | ||||||
|  |   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) | ||||||
|  |          (s (add-to-store %store "bash" #t "sha256" | ||||||
|  |                           (search-bootstrap-binary "bash" | ||||||
|  |                                                    (%current-system)))) | ||||||
|  |          (d (derivation %store "the-thing" (%current-system) | ||||||
|  |                         s `("-e" ,b) `(("foo" . ,(random-text))) | ||||||
|  |                         `((,b) (,s)))) | ||||||
|  |          (o (derivation-path->output-path d))) | ||||||
|  |     (and (build-derivations %store (list d)) | ||||||
|  |          (equal? (query-derivation-outputs %store d) | ||||||
|  |                  (list o)) | ||||||
|  |          (equal? (valid-derivers %store o) | ||||||
|  |                  (list d))))) | ||||||
|  | 
 | ||||||
| (test-assert "no substitutes" | (test-assert "no substitutes" | ||||||
|   (let* ((s  (open-connection)) |   (let* ((s  (open-connection)) | ||||||
|          (d1 (package-derivation s %bootstrap-guile (%current-system))) |          (d1 (package-derivation s %bootstrap-guile (%current-system))) | ||||||
|  |  | ||||||
		Reference in a new issue