diff --git a/core/src/magic.sld b/core/src/magic.sld index 5c1a909..730d2dc 100644 --- a/core/src/magic.sld +++ b/core/src/magic.sld @@ -6,7 +6,7 @@ (scheme base) (scheme file) (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path) (zilch zexpr) - (srfi 132) + (srfi 128) (srfi 132) (srfi 146) (srfi 152) (chicken base) (chicken format) socket) (export @@ -18,7 +18,7 @@ store-path-path store-path-build store-path-materialize store-path-realisation store-path-for-text store-path-for-fod store-path-for-drv store-path-for-impure-drv store-path-for-ca-drv store-path-for-ca-drv* - store-path-open + store-path-realised store-path-open zilch-magic-counters) @@ -172,39 +172,72 @@ (for-each (lambda (item) (when (eq? (member item left) #f) (set! left (cons item left)))) right) (list-sort string start-index 0))) + + (define context-to-build '()) + (define drv-output-map #f) + + (define (process-output output-name output drv) + (define needs-building #f) + (when (and (derivation-output-placeholder? output) (string-contains path (derivation-output-path output))) + (unless drv-output-map + (set! drv-output-map (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path drv)))) + (unless (assoc output-name drv-output-map) + (daemon-wop-build-paths (*daemon*) (vector (string-append (derivation-path drv) "!" output-name))) + (set! drv-output-map (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path drv)))) + (let* ((known-path (cdr (assoc output-name drv-output-map))) + (is-replaced (replace-placeholder (derivation-output-path output) known-path 0))) + (when (and is-replaced (not (file-exists? known-path))) + (set! needs-building #t)))) + (when (or needs-building (not (or (derivation-output-placeholder? output) (file-exists? (derivation-output-path output))))) + (set! context-to-build (cons (string-append (derivation-path drv) "!" output-name) context-to-build)))) + (for-each + (lambda (drv-outputs) + (set! drv-output-map #f) + (for-each + (lambda (output-name) + (process-output output-name (cdr (assoc output-name (derivation-outputs (car drv-outputs)))) (car drv-outputs))) + (cdr drv-outputs))) + drv-context) + (values path context-to-build)) + + (define (zexp-ctx-has-placeholder drv-context) + (if (null? drv-context) + #f + (let ((drv (caar drv-context)) + (outputs (cdar drv-context)) + (has-placeholder #f)) + (for-each (lambda (output) (set! has-placeholder (or has-placeholder (derivation-output-placeholder? (cdr (assoc output (derivation-outputs drv))))))) outputs) + (or has-placeholder (zexp-ctx-has-placeholder (cdr drv-context)))))) + + (define (store-path-realised path) + (define ctx (zexp-unwrap (zexp (zexp-unquote path)))) + (define val (zexp-evaluation-value ctx)) + (define to-build '()) + (if (string? val) + (let-values (((resolved resolved-to-build) (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))) + (set! val resolved) + (set! to-build resolved-to-build)) + (when (zexp-ctx-has-placeholder (zexp-evaluation-drvs ctx)) + (error "store-path-realised: expression has dependencies on placeholder context, but isn't a string" (list path val)))) + (when (and (string? val) (not (file-exists? val)) (not (null? to-build))) + (daemon-wop-build-paths (*daemon*) (list->vector to-build))) + val) + ;; Ensures the `` exists, then opens an input port to allow reading from it. (define (store-path-open path) (increment-counter 2) - (if (store-path? path) - (let ((out-path (store-path-realisation path))) - (unless (and out-path (file-exists? out-path)) (store-path-materialize path) (store-path-build path)) - (unless out-path (set! out-path (store-path-realisation path))) - (open-input-file out-path)) - (let* ((ctx (zexp-unwrap (zexp (zexp-unquote path)))) (val (zexp-evaluation-value ctx))) - - ; TODO(puck): big hack to make file->store work - (for-each - (lambda (drv) - (for-each - (lambda (output) - (when (and (string=? (string-append (derivation-output-path (cdr output)) "/-") val) - (not (or (not (derivation-output-hash (cdr output))) - (bytevector? (derivation-output-hash (cdr output)))))) - (daemon-wop-build-paths (*daemon*) (vector (string-append (derivation-path (car drv)) "!" (car output)))) - (set! val (string-append (cdr (assoc (car output) (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path (car drv))))) "/-")))) - (derivation-outputs (car drv)))) - (zexp-evaluation-drvs ctx)) - - (unless (file-exists? val) - (for-each - (lambda (path) - (for-each - (lambda (output) - (daemon-wop-build-paths (*daemon*) (vector (string-append (derivation-path (car path)) "!" output)))) - (cdr path))) - (zexp-evaluation-drvs ctx))) - - (open-input-file val)))) + (define output-path (store-path-realised path)) + (open-input-file output-path)) (zexp-add-unquote-handler (lambda (val)