zilch/lang/ninja/src/nixpkgs.sld

;; Helpers to work with Zilch around Nixpkgs derivations.
(define-library (zilch lang ninja nixpkgs)
 (import
   (scheme base) (chicken format) (scheme lazy)
   (zilch lang ninja) (zilch lang ninja build)
   (zilch lang ninja config)
   (zilch magic) (zilch nixpkgs) (zilch vfs)
   (zilch file)
   (zilch nix drv) (zilch nix hash)
   (zilch lib hash) (zilch lib rewrite)
   (zilch zexpr)
   (srfi 26) (srfi 128) (srfi 132) (srfi 146) (srfi 152) (srfi 207))

 (export
  setup-ninja-environment
  build-nixpkgs-drv-reproducibly
  determine-data-flow
  virtual-path-for make-virtual-path
    
  <finalized-drv> finalized-drv?
  finalized-drv-output-store-paths finalized-drv-depfile
  finalized-drv-rewritten-drvs finalized-drv-config)
  

 (begin
  (define coreutils (cdr (assoc "out" (nixpkgs "coreutils"))))

  (define rewrite-hooks
   (string-append
    "__zilch_rewrite_sed=\"\"\n"
    "echo \"$__zilch_rewrites\" | while read -d ' ' rewrite_from; do\n"
    " read -d ' ' rewrite_to\n"
    " __zilch_rewrite_sed=\"$__zilch_rewrite_sed s|$rewrite_from|$rewrite_to|g\"\n"
    "done || true\n"
    "echo \"$__zilch_rewrites\" | while read -d ' ' rewrite_from; do\n"
    " read -d ' ' rewrite_to\n"
    " cp --no-preserve=ownership -rf \"$rewrite_from\" \"$rewrite_to\"\n"
    " chmod -R ugo+rw \"$rewrite_to\"\n"
    " find \"$rewrite_to\" -type f -exec sed -i -e \"$__zilch_rewrite_sed\" \"{}\" \";\" || exit 1\n"
    " find \"$rewrite_to\" -type l | while read link; do\n"
    "  target=\"$(readlink \"$link\")\"; rewritten=\"$(printf \"%s\" \"$target\" | sed -e \"$__zilch_rewrite_sed\")\"\n"
    "  rm \"$link\" && ln -s \"$rewritten\" \"$link\" || exit 1\n"
    " done\n"
    "done || true\n"
    "unset __zilch_rewrites __zilch_rewrite_sed\n"))

  ; Shellcode to run instead of the default stdenv genericBuild();
  ; This takes the source and configuration of our derivation and prepares
  ; a proper environment to build inside.
  (define configure-builder
    (string-append
     "export DETERMINISTIC_BUILD=1\n"
     "export PYTHONHASHSEED=0\n"
     "zilchPreConfigure() {\n"
      " cd $NIX_BUILD_TOP; mkdir bdir; mv $sourceRoot bdir/src; sourceRoot=bdir/src; cd $sourceRoot\n"
     "}\n"
     "mesonBuildDir=$NIX_BUILD_TOP/bdir/build cmakeBuildDir=$NIX_BUILD_TOP/bdir/build cmakeDir=\"$NIX_BUILD_TOP/bdir/src/${cmakeDir:-.}\"\n"
     "phases=\"${prePhases[*]:-} unpackPhase patchPhase ${preConfigurePhases[*]:-} zilchPreConfigure configurePhase ${preBuildPhases[*]:-}\"\n"
     "for curPhase in ${phases[*]}; do runPhase \"$curPhase\"; done\n"
     "find . '(' -name cmake_trace.txt -o -name meson-log.txt -o -name CMakeConfigureLog.yaml ')' -delete\n"
     "find . -name '*.bin' -exec strip -S '{}' ';' || true\n"
     "rm -rf meson-info\n"
     "cd $NIX_BUILD_TOP; mv bdir $zilch_out"))

  ; Patch the passed in .drv by appending to the environment
  ; and changing the list of outputs.
  (define (patch-drv drv append-env outputs rewrites)
   (define ctx (zexp-unwrap (zexp (zexp-unquote append-env))))
   (define new-env (list))
   (for-each
    (lambda (kv)
     (define mem (assoc (car kv) (zexp-evaluation-value ctx)))
     (cond
       (mem (set! new-env (cons mem new-env)))
       ((member (car kv) '("allowedReferences" "disallowedReferences" "allowedRequisites" "disallowedRequisites")) #f)
       (else (set! new-env (cons (cons (car kv) (rewrite-bytevector-or-string (cdr kv) rewrites)) new-env)))))
    (derivation-env drv))
   (for-each
    (lambda (kv)
      (unless (assoc (car kv) new-env) (set! new-env (cons kv new-env))))
    (zexp-evaluation-value ctx))

   (define reprocessed
     (make-input-addressed-derivation
      (derivation-name drv)
      (derivation-system drv)
      (list-sort
       (lambda (l r) (string<? (derivation-path (car l)) (derivation-path (car r))))
       (append (zexp-evaluation-drvs ctx) (derivation-input-drvs drv)))
      (list-sort string<?
       (append (zexp-evaluation-srcs ctx) (derivation-input-src drv)))
      (cons (derivation-builder drv) (derivation-args drv))
      new-env
      (or outputs (map car (derivation-outputs drv)))))

   (map (lambda (l) (cons (car l) (make-store-path reprocessed (car l) #f))) (derivation-outputs reprocessed)))

  (define base-placeholder "zilchplaceholderdonotuseanywhere-")
 
  ;; Generate a placeholder for a virtualised path.
  ;; This is similar to `make-placeholder`, but outputs
  ;; a string that is of the shape `/nix/store/{invalid hash}-{discriminator}`,
  ;; where the hash starts with `tz`, to make it invalid base32.
  (define (make-virtual-path discriminator)
    (define data (string-append "zilch!" discriminator))
    (define hash (as-base32 (hash-compress (sha256 (string->utf8 data)))))
    (string-set! hash 0 #\t)
    (string-set! hash 1 #\z)
    (string-append "/nix/store/" hash "-" discriminator))

  ;; Generate a placeholder for a virtualised path, like `make-virtual-path`,
  ;; but based on the input store path string.
  (define (virtual-path-for store-path)
    (define index (string-contains store-path "-"))
    (make-virtual-path (string-copy store-path (+ 1 index))))

  ; Create a placeholder store path that is unique
  (define (make-fake-store-path name output)
    (when (> (string-length output) 32)
      (set! output (string-copy output 0 32)))

    (string-append "/nix/store/" output (string-copy base-placeholder (string-length output)) name (if (string=? output "out") "" (string-append "-" output))))

  (define-record-type <finalized-drv>
    (make-finalized-drv output-store-paths export-depfile rewritten-drvs config)
    finalized-drv?
    (output-store-paths finalized-drv-output-store-paths)
    (export-depfile finalized-drv-export-depfile)
    (rewritten-drvs finalized-drv-rewritten-drvs)
    (config finalized-drv-config))

  (define (finalized-drv-depfile drv)
    ((finalized-drv-export-depfile drv)))

  ;; Takes a `<ninja-build-config>` representing a Nixpkgs derivation, and
  ;; preprocesses the derivation such that it can be reconstituted once Zilch
  ;; has taken over the Ninja build requirements.
  ;;
  ;; This procedure is used internally, and shouldn't be relied upon; it 
  ;; encodes many specific parts that are unlikely to be useful by external
  ;; parties.
  ;;
  ;; Returns 7 values:
  ;;
  ;; - The initial Nixpkgs derivation as `<derivation>`
  ;; - The Nixpkgs derivation after running all phases up to and including
  ;;   configuration
  ;; - An alist of output names to placeholder store paths
  ;; - The `edge-ref`, `defaults`, and `export-depfile` values from calling
  ;;   `process-ninja-file`
  ;; - A list of store path -> store path rewrites.
  (define (setup-ninja-environment conf secondary-roots)
    (define initial-drv (ninja-build-config-environment-drv conf))
    (when (store-path? initial-drv)
      (set! initial-drv (store-path-drv initial-drv)))
    (define name (derivation-name initial-drv))
    (define placeholders (map (lambda (output-and-info) (cons (car output-and-info) (make-fake-store-path name (car output-and-info)))) (derivation-outputs initial-drv)))

    (define existing-env (ninja-build-config-environment conf))
    
    (define rewrites (list))
    (define rewrite-extra "")
    (for-each
     (lambda (secondary-root)
      (mapping-for-each
       (lambda (orig-path virtual-path)
        (set! rewrites (cons (cons (string->utf8 orig-path) (string->utf8 virtual-path)) rewrites))
        (set! rewrite-extra (string-append rewrite-extra orig-path " " virtual-path "\n")))
       (drv-rewrite-source-paths secondary-root)))
     secondary-roots)

    ; Override output environment variables with our placeholders.
    (set-ninja-build-config-environment! conf #~,(map (lambda (v) (or (assoc (car v) placeholders) (cons (car v) (rewrite-bytevector-or-string (cdr v) rewrites)))) #$existing-env))

    ; Take the initially requested .drv, replace its buildCommand, and set a single ("zilch_out") output path.
    (define configured-drv
     (cdar
      (patch-drv initial-drv
       (append
        `(("buildCommand" . ,configure-builder)
          ("addInputsHook" . ,rewrite-hooks)
          ("__zilch_rewrites" . ,rewrite-extra))
        placeholders)
       '("zilch_out")
       rewrites)))

    ; This VFS contains two directories: `src` (source tree) and `build` (Ninja build files).
    (define configured-vfs (vfs-from-store configured-drv))
    
    (when (ninja-build-config-override-source conf)
      (let
        ((filtered (mapping-filter! (lambda (path val) (not (or (string=? "src" (car path)) (string-prefix? "src/" (car path))))) (vfs-contents configured-vfs))))
        (mapping-for-each
         (lambda (p v)
          (set! filtered
           (mapping-set! filtered
            (cons (if (string=? (car p) "") "src" (string-append "src/" (car p))) (cdr p))
            v)))
         (vfs-contents (ninja-build-config-override-source conf)))
        (set! configured-vfs (make-vfs filtered))))

    (set-ninja-build-config-root-dir! conf configured-vfs)

    (define (read-file-at-path path)
      (set! path (string-append "build/" path))
      (define last-slash (string-contains-right path "/"))
      (call-with-port (store-path-open (vfs-file-ref configured-vfs (string-copy path 0 last-slash) (string-copy path (+ 1 last-slash))))
       (lambda (p) (read-bytevector (* 20 1024 1024) p))))
    (define ninja-file
     (read-ninja-file (read-file-at-path "build.ninja") read-file-at-path))

    ; Process the build.ninja file.
    (define-values (edge-ref defaults export-depfile) (process-ninja-file ninja-file conf "build" secondary-roots))

    (values initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites))

  (define (process-secondary-root parent-conf secondary-root)
    (define conf (cdr secondary-root))
    (define drv-name (car secondary-root))

    (define matching-drv #f)
    (let loop ((drv-list (derivation-input-drvs (ninja-build-config-environment-drv parent-conf))))
      (cond
       ((null? drv-list) (error "Cannot find matching derivation for rewrite" drv-name))
       ((string=? (derivation-name (caar drv-list)) drv-name)
        (set! matching-drv (caar drv-list)))
       (else (loop (cdr drv-list)))))
    (define (disc-name out-name)
      (if (string=? out-name "out") drv-name (string-append drv-name "-" out-name)))

    (define future-rewrites (map (lambda (a) (cons (derivation-output-path (cdr a)) (make-virtual-path (disc-name (car a))))) (derivation-outputs matching-drv)))
    (define output-map (alist->mapping (make-default-comparator) (map (lambda (a) (cons (car a) (make-virtual-path (disc-name (car a))))) (derivation-outputs matching-drv))))
    ; secondary-root is (name . #<ninja-build-config>)
    (define its-secondary-roots (map (cute process-secondary-root conf <>) (ninja-build-config-rewrites conf)))
    (define-values (initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites) (setup-ninja-environment conf its-secondary-roots))
    (define vfses (mapping-map (lambda (k v) (values k (mapping (make-default-comparator)))) (make-default-comparator) output-map))
    (define (transform-obj obj)
      (cond
       ((and (pair? obj) (eq? (car obj) 'marker))
        (let ((obj-edge (edge-ref (cdr obj))))
         (or (and (cdr obj-edge) (built-edge-lib-placeholder (cdr obj-edge)))
             (car obj-edge))))
       (else obj)))
    (define extra-paths '())
    (mapping-for-each
     (lambda (key obj)
       (define base-store-path (mapping-ref output-map (car key)))
       (define full-path (string-append base-store-path "/" (if (string=? "" (cadr key)) (cddr key) (string-append (cadr key) "/" (cddr key)))))
       (if (or (string-suffix? ".hh" (cddr key)) (string-suffix? ".h" (cddr key)) (string-suffix? ".hpp" (cddr key)))
        (set! extra-paths (cons (cons full-path (transform-obj obj)) extra-paths))
        (set! vfses (mapping-set! vfses (car key) (mapping-set! (mapping-ref vfses (car key)) (cdr key) (transform-obj obj))))))
     (determine-data-flow conf))
    (set! vfses (mapping-map/monotone! (lambda (k v) (values k (vfs-to-store (make-vfs v)))) (make-default-comparator) vfses))
    (define finalized (delay (finalize-drv conf its-secondary-roots initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites)))
    (make-drv-rewrite output-map finalized vfses extra-paths))
  ;; Takes a `<ninja-build-config>` representing a Nixpkgs derivation, and
  ;; build it using Zilch.
  ;;
  ;; Returns two values:
  ;;
  ;; - An alist of output name to store paths, representing the built
  ;;   derivation
  ;; - A procedure that, when called, returns a mapping of output path to
  ;;   necessary inputs generated from the depfile data. This can be stored in
  ;;   a file for later rebuilds.
  (define (build-nixpkgs-drv-reproducibly conf)
    (define secondary-roots (map (cute process-secondary-root conf <>) (ninja-build-config-rewrites conf)))
    (define-values (initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites) (setup-ninja-environment conf secondary-roots))
    (finalize-drv conf secondary-roots initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites))

  ;; "Finalizes" a previously setup Ninja environment, running the install and fixup hooks.
  (define (finalize-drv conf secondary-roots initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites)
    ; Build all store paths necessary for installing. This assumes Meson.
    (define preinstall-state (force (built-edge-out-drv (cdr (edge-ref "all")))))

    (define fix-placeholders-command "")
    (define copy-in-place-command "")

    ; Append the necessary commands to fix up the fake store paths post-install but pre-everything-else.
    (for-each
     (lambda (plc)
       (set! fix-placeholders-command
         (string-append fix-placeholders-command
          "zilchFixPlaceholder \"" (cdr plc) "\" \"$" (car plc) "\"\n"))
       (set! copy-in-place-command
         (string-append copy-in-place-command
          "cp -rf ../out" (cdr plc) " \"$" (car plc) "\" || mkdir \"$" (car plc) "\"\n")))
     placeholders)

    ; Turn the original `src` and `build` into a known store path.
    (define realised-store (store-path-devirtualise configured-drv))

    ; Turn the `.drv` containing all the paths that are built into a known store path.
    ; This is necessary because these paths may be CA, and we can't guarantee daemon support for that past this point.
    (define realised-built (store-path-devirtualise preinstall-state))

    ; Take each output store path, then copy it over to the expected place
    ; then later run a fixup to the original store path at placeholder state
    (define prepared-store-paths (list))
    (define rewrite-placeholder-fixes (list))
    (define (fixup-single-secondary-root single-drv-item)
      (define drv-name (virtual-path-for (store-path-path single-drv-item)))
      (set! prepared-store-paths (cons #~,(string-append "cp -rf " #$single-drv-item " " drv-name "\n") prepared-store-paths))
      (set! rewrite-placeholder-fixes (cons #~,(string-append "zilchFixPlaceholder " drv-name " " #$single-drv-item "\n") rewrite-placeholder-fixes)))
    (define (prepare-secondary-root secondary-root)
      ; alist of output name -> store path
      (define realised (finalized-drv-output-store-paths (force (drv-rewrite-finalized-drv secondary-root))))
      (map (lambda (v) (fixup-single-secondary-root (cdr v))) realised))
    (for-each prepare-secondary-root secondary-roots)

    ; Prepare the post-build builder. This puts everything in its place and runs the post-build phases from the original .drv.
    (define postbuild-builder
      #~,(string-append
          "zilchPlace() {\n"
           "cd $NIX_BUILD_TOP; cp -rf --no-preserve=ownership " #$realised-store " bdir\n"
           "chmod ugo+rw -R bdir\n"
           "cp -rf --no-preserve=ownership " #$realised-built "/* bdir/build\n"
           "cd bdir/build\n"
          "}\n"
          "mesonBuildDir=$NIX_BUILD_TOP/bdir/build cmakeBuildDir=$NIX_BUILD_TOP/bdir/build cmakeDir=\"$NIX_BUILD_TOP/bdir/src/${cmakeDir:-.}\"\n"
          "zilchFixPlaceholder() {\n"
          " find ../out -type f -exec sed -i -e \"s|$1|$2|g\" \"{}\" \";\" || exit 1\n"
          " find \"../out\" -type l | while read link; do\n"
          "  target=\"$(readlink \"$link\")\"; rewritten=\"$(printf \"%s\" \"$target\" | sed -e \"s|$1|$2|g\")\"\n"
          "  rm \"$link\" && ln -s \"$rewritten\" \"$link\" || exit 1\n"
          " done\n"
          "}\n"
          "zilchFixup() {\n"
          fix-placeholders-command
          #$(apply string-append #$rewrite-placeholder-fixes)
          copy-in-place-command
          "}\n"
          "zilchMesonInstall() {\n"
          " runHook preInstall\n"
          " local flagsArray=()\n"
          " if [[ -n \"$mesonInstallTags\" ]]; then\n"
          "  flagsArray+=(\"--tags\" \"$(concatStringsSep \",\" mesonInstallTags)\")\n"
          " fi\n"
          " concatTo flagsArray mesonInstallFlags mesonInstallFlagsArray\n"
          " DESTDIR=$NIX_BUILD_TOP/bdir/out meson install --no-rebuild \"${flagsArray[@]}\"\n"
          " zilchFixup\n"
          " runHook postInstall\n"
          "}\n"
          "zilchCmakeInstall() {\n"
          " runHook preInstall\n"
          " DESTDIR=$NIX_BUILD_TOP/bdir/out cmake --install .\n"
          " zilchFixup\n"
          " runHook postInstall\n"
          "}\n"
          "if [[ $(type -t mesonInstallPhase) == function ]]; then\n"
          "  installPhase=zilchMesonInstall; checkPhase=mesonCheckPhase\n"
          "else\n"
          "  installPhase=zilchCmakeInstall; checkPhase=ninjaCheckPhase\n"
          "fi\n"
          "phases=\"zilchPlace checkPhase ${preInstallPhases[*]:-} installPhase ${preFixupPhases[*]:-} fixupPhase installCheckPhase ${preDistPhases[*]:-} distPhase ${postPhases[*]:-}\"\n"
          "for curPhase in ${phases[*]}; do runPhase \"$curPhase\"; done\n"))

    ; Patch the original .drv to run the postbuild-builder command.
    (define store-paths
     (patch-drv initial-drv
      (append
       `(("buildCommand" . ,postbuild-builder)
         ("addInputsHook" . ,#~,(apply string-append #$prepared-store-paths)))
       placeholders)
      (map car placeholders)
      rewrites))
    (make-finalized-drv store-paths export-depfile secondary-roots conf))
  
  ;; Build the derivation, but with stubbed out header and .so files.
  ;; This is used to determine the dataflow, to make cross-project incremental
  ;; builds work.
  ;; Returns a single SRFI-146 mapping, containing keys of shape `(output . (dir . name))`,
  ;; and values either a zexpr-y store path, or a pair `(marker . <name of the build output>)`
  (define (determine-data-flow conf)
    (define-values (initial-drv configured-drv placeholders edge-ref defaults export-depfile rewrites) (setup-ninja-environment conf '()))

    (define edges (built-edge-phony-inputs (cdr (edge-ref "all"))))

    (define fix-placeholders-command "")
    (define copy-in-place-command "")

    ; Append the necessary commands to fix up the fake store paths post-install but pre-everything-else.
    (for-each
     (lambda (plc)
       (set! fix-placeholders-command
         (string-append fix-placeholders-command
          "zilchFixPlaceholder \"" (cdr plc) "\" \"$" (car plc) "\"\n"))
       (set! copy-in-place-command
         (string-append copy-in-place-command
          "cp -rf ../out" (cdr plc) " \"$" (car plc) "\" || mkdir \"$" (car plc) "\"\n")))
     placeholders)

    ; Turn the original `src` and `build` into a known store path.
    (define realised-store (store-path-devirtualise configured-drv))

    (define make-all-placeholder-files
     (string-join (map (lambda (v) (string-append "zilchMakeFile \"" v "\"\n")) edges) "\n"))

    ; Prepare the post-build builder. This puts everything in its place and runs the post-build phases from the original .drv.
    (define postbuild-builder
      #~,(string-append
          "zilchMakeFile() {\n"
           "mkdir -p bdir/build/$(dirname \"$1\")\n"
           "rm bdir/build/\"$1\" || true\n"
           "echo \"ZILCH MARKER FILE ->$1\" > bdir/build/\"$1\"\n"
          "}\n"
          "zilchPlace() {\n"
           "cd $NIX_BUILD_TOP; cp -rf --no-preserve=ownership " #$realised-store " bdir\n"
           "chmod ugo+rw -R bdir\n"
           "(cd " #$realised-store "/src; find . -type f '(' -name '*.h' -o -name '*.hh' -o -name '*.hpp' -o -name '*.so' ')') | while read f; do zilchMakeFile \"../src/$f\"; done\n"
           make-all-placeholder-files
           "cd bdir/build\n"
          "}\n"
          "mesonBuildDir=$NIX_BUILD_TOP/bdir/build cmakeBuildDir=$NIX_BUILD_TOP/bdir/build cmakeDir=\"$NIX_BUILD_TOP/bdir/src/${cmakeDir:-.}\"\n"
          "zilchFixPlaceholder() {\n"
          " find ../out -type f -exec sed -i -e \"s|$1|$2|g\" \"{}\" \";\" || exit 1\n"
          " find \"../out\" -type l | while read link; do\n"
          "  target=\"$(readlink \"$link\")\"; rewritten=\"$(printf \"%s\" \"$target\" | sed -e \"s|$1|$2|g\")\"\n"
          "  rm \"$link\" && ln -s \"$rewritten\" \"$link\" || exit 1\n"
          " done\n"
          "}\n"
          "zilchFixup() {\n"
          fix-placeholders-command
          copy-in-place-command
          "}\n"
          "zilchMesonInstall() {\n"
          " runHook preInstall\n"
          " local flagsArray=()\n"
          " if [[ -n \"$mesonInstallTags\" ]]; then\n"
          "  flagsArray+=(\"--tags\" \"$(concatStringsSep \",\" mesonInstallTags)\")\n"
          " fi\n"
          " concatTo flagsArray mesonInstallFlags mesonInstallFlagsArray\n"
          " DESTDIR=$NIX_BUILD_TOP/bdir/out meson install --no-rebuild \"${flagsArray[@]}\"\n"
          " zilchFixup\n"
          " runHook postInstall\n"
          "}\n"
          "zilchCmakeInstall() {\n"
          " runHook preInstall\n"
          " DESTDIR=$NIX_BUILD_TOP/bdir/out cmake --install .\n"
          " zilchFixup\n"
          " runHook postInstall\n"
          "}\n"
          "if [[ $(type -t mesonInstallPhase) == function ]]; then\n"
          "  installPhase=zilchMesonInstall; checkPhase=mesonCheckPhase\n"
          "else\n"
          "  installPhase=zilchCmakeInstall; checkPhase=ninjaCheckPhase\n"
          "fi\n"
          "phases=\"zilchPlace checkPhase ${preInstallPhases[*]:-} installPhase ${preFixupPhases[*]:-} fixupPhase installCheckPhase ${preDistPhases[*]:-} distPhase ${postPhases[*]:-}\"\n"
          "for curPhase in ${phases[*]}; do runPhase \"$curPhase\"; done\n"))

    ; Patch the original .drv to run the postbuild-builder command.
    (define patched-drv
     (patch-drv initial-drv
      (append
       `(("buildCommand" . ,postbuild-builder))
       placeholders)
      (map car placeholders) '()))
    (define (get-file-marker fptr)
      (call-with-port (store-path-open fptr)
       (lambda (p)
        (define header (read-string 20 p))
        (and (string=? header "ZILCH MARKER FILE ->")
         (let ((str (read-string 99999 p)))
           (string-copy str 0 (- (string-length str) 1)))))))
    (define output (mapping (make-default-comparator)))
    (define (process-output name-data-pair)
      (define name (car name-data-pair))
      (define store-path (cdr name-data-pair))
      (define vfs (vfs-from-store store-path))
      (mapping-for-each
       (lambda (path val)
         ; TODO(puck): this depends on vfs-from-store internals
        (define is-file (z-file? val))
        (define marker (and is-file (get-file-marker val)))
        (if marker
          (set! output (mapping-set! output (cons name path) (cons 'marker marker)))
          (set! output (mapping-set! output (cons name path) val))))
       (vfs-contents vfs)))
    (for-each process-output patched-drv)
    output)))

    ; TODO(puck): for each output, do the necessary dance of figuring out where it came from. read first N bytes, compare, then do the thing. output a big alist and do the dataflow dance?