~ruther/guix-local

eddd4077a5292052d95443078ee4db9f34f2f0e2 — Ludovic Courtès 12 years ago 08184eb
store: Add 'log-file' procedure.

* guix/store.scm (log-file): New procedure.
* tests/store.scm ("log-file, derivation", "log-file, output file
  name"): New tests.
2 files changed, 49 insertions(+), 1 deletions(-)

M guix/store.scm
M tests/store.scm
M guix/store.scm => guix/store.scm +22 -1
@@ 87,7 87,8 @@
            store-path?
            derivation-path?
            store-path-package-name
            store-path-hash-part))
            store-path-hash-part
            log-file))

(define %protocol-version #x10c)



@@ 660,3 661,23 @@ syntactically valid store path."
                                "/([0-9a-df-np-sv-z]{32})-[^/]+$"))))
    (and=> (regexp-exec path-rx path)
           (cut match:substring <> 1))))

(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."
  (define state-dir                               ; XXX: factorize
    (or (getenv "NIX_STATE_DIR") %state-directory))

  (cond ((derivation-path? file)
         (let* ((base (basename file))
                (log  (string-append (dirname state-dir) ; XXX: ditto
                                     "/log/nix/drvs/"
                                     (string-take base 2) "/"
                                     (string-drop base 2) ".bz2")))
           (and (file-exists? log) log)))
        (else
         (match (valid-derivers store file)
           ((derivers ...)
            ;; Return the first that works.
            (any (cut log-file store <>) derivers))
           (_ #f)))))

M tests/store.scm => tests/store.scm +27 -0
@@ 140,6 140,33 @@
         (equal? (valid-derivers %store o)
                 (list (derivation-file-name d))))))

(test-assert "log-file, derivation"
  (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"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s)))))
    (and (build-derivations %store (list d))
         (file-exists? (pk (log-file %store (derivation-file-name d)))))))

(test-assert "log-file, output file name"
  (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"
                        s `("-e" ,b)
                        #:env-vars `(("foo" . ,(random-text)))
                        #:inputs `((,b) (,s))))
         (o (derivation->output-path d)))
    (and (build-derivations %store (list d))
         (file-exists? (pk (log-file %store o)))
         (string=? (log-file %store (derivation-file-name d))
                   (log-file %store o)))))

(test-assert "no substitutes"
  (let* ((s  (open-connection))
         (d1 (package-derivation s %bootstrap-guile (%current-system)))