(zilch lang ninja): support swapping out the build phase of nixpkgs-style drv

Change-Id: I6a6a69649c5c37c67dbe05a0795356b78caff528

lang/ninja/default.nix

@@ -7,8 +7,9 @@
     chickenPackages.chicken
     r7rs
     json
-    srfi-152
     srfi-113
+    srfi-132
+    srfi-152
     srfi-207
     (callPackage ../../core {})
     (callPackage ../../planner {})

lang/ninja/src/build.sld

@@ -364,7 +364,7 @@
 
     (define edge-ref
      (lambda (path)
-       (define edge (mapping-ref/default edges path #f))
+       (define edge (mapping-ref edges path (lambda () (error "Target doesn't exist" path))))
        (cons (if (promise? (car edge)) (force (car edge)) (car edge)) (force (cdr edge)))))
     (define defaults (build-file-default-targets file))
     (values edge-ref defaults))))

lang/ninja/src/config.sld

@@ -1,12 +1,13 @@
 (define-library (zilch lang ninja config)
  (import
   (scheme base) (scheme eval)
-  (zilch nixpkgs) (zilch vfs))
+  (zilch magic) (zilch nixpkgs) (zilch vfs)
+  (prefix (only scheme eval) scheme-))
 
  (export
   ninja-build-config?
-  ninja-build-config-environment ninja-build-config-root-dir
+  ninja-build-config-environment ninja-build-config-environment-drv
-  ninja-build-config-patches ninja-build-config-targets
+  ninja-build-config-root-dir ninja-build-config-patches ninja-build-config-targets
 
   set-ninja-build-config-root-dir! set-ninja-build-config-environment!
 
@@ -14,9 +15,10 @@
 
  (begin
    (define-record-type <ninja-build-config>
-    (make-ninja-build-config environment root-dir patches targets)
+    (make-ninja-build-config environment environment-drv root-dir patches targets)
     ninja-build-config?
     (environment ninja-build-config-environment set-ninja-build-config-environment!)
+    (environment-drv ninja-build-config-environment-drv set-ninja-build-config-environment-drv!)
     (root-dir ninja-build-config-root-dir set-ninja-build-config-root-dir!)
     (patches ninja-build-config-patches set-ninja-build-config-patches!)
     (targets ninja-build-config-targets set-ninja-build-config-targets!))
@@ -28,7 +30,11 @@
      (else
       (case (car data)
        ((#:env #:environment)
-        (set-ninja-build-config-environment! conf (if (string? (list-ref data 1)) (environment-for-derivation (cdar (nixpkgs-eval (list-ref data 1)))) (list-ref data 1)))
+        (if (string? (list-ref data 1))
+         (let ((drv (cdar (nixpkgs-eval (list-ref data 1)))))
+           (set-ninja-build-config-environment! conf (environment-for-derivation drv))
+           (set-ninja-build-config-environment-drv! conf (store-path-drv drv)))
+         (set-ninja-build-config-environment! conf (list-ref data 1)))
         (parse-config-inner conf (cddr data)))
        ((#:root)
         (set-ninja-build-config-root-dir! conf (if (string? (list-ref data 1)) (vfs-from-directory (list-ref data 1)) (list-ref data 1)))
@@ -41,7 +47,7 @@
             ((string? patch-base)
              (lambda (target) patch-base))
             ((list? patch-base)
-             (eval patch-base (environment '(scheme base) '(zilch lang ninja))))
+             (scheme-eval patch-base))
             (else patch-base))))
          (set-ninja-build-config-patches! conf (cons processed-patch (ninja-build-config-patches conf))))
         (parse-config-inner conf (cddr data)))
@@ -58,4 +64,4 @@
    (define (parse-ninja-config config)
     (unless (list? config)
      (error "expected Zilch Ninja config to be a list"))
-    (parse-config-inner (make-ninja-build-config #f #f '() #f) config))))
+    (parse-config-inner (make-ninja-build-config #f #f #f '() #f) config))))

lang/ninja/src/nixpkgs.sld

@@ -0,0 +1,182 @@
+(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 nix drv)
+   (zilch zexpr)
+   (srfi 132) (srfi 152))
+
+ (export
+  setup-ninja-environment
+  build-nixpkgs-drv-reproducibly)
+
+ (begin
+  (define coreutils (cdr (assoc "out" (nixpkgs "coreutils"))))
+
+  ; 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\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)
+   (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 kv 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-")
+
+  ; 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 (setup-ninja-environment conf)
+    (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))
+
+    ; Override output environment variables with our placeholders.
+    (set-ninja-build-config-environment! conf #~,(map (lambda (v) (or (assoc (car v) placeholders) v)) #$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))
+        placeholders)
+       '("zilch_out"))))
+
+    ; This VFS contains two directories: `src` (source tree) and `build` (Ninja build files).
+    (define configured-vfs (vfs-from-store configured-drv))
+
+    (set-ninja-build-config-root-dir! conf configured-vfs)
+
+    (define ninja-file
+     (read-ninja-file
+      (call-with-port (store-path-open (vfs-file-ref configured-vfs "build" "build.ninja"))
+       (lambda (p) (read-bytevector (* 20 1024 1024) p)))))
+
+    ; Process the build.ninja file.
+    (define-values (edge-ref defaults) (process-ninja-file ninja-file conf "build"))
+
+    (values initial-drv configured-drv placeholders edge-ref defaults))
+
+  (define (build-nixpkgs-drv-reproducibly conf)
+    (define-values (initial-drv configured-drv placeholders edge-ref defaults) (setup-ninja-environment conf))
+
+    ; 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))
+
+    ; 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\n"
+          "installPhase=zilchInstall; checkPhase=mesonCheckPhase\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"
+          "zilchInstall() {\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"
+          "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.
+    (patch-drv initial-drv
+     (append
+      `(("buildCommand" . ,postbuild-builder))
+      placeholders)
+     (map car placeholders)))))

lang/ninja/zilch-lang-ninja.egg

@@ -1,7 +1,7 @@
 ((version "0.0.1")
  (synopsis "Nix. Noppes. Nada.")
  (author "puck")
- (dependencies r7rs json zilch zilch.planner srfi-207)
+ (dependencies r7rs json zilch zilch.planner srfi-132 srfi-152 srfi-207)
  (component-options
   (csc-options "-X" "r7rs" "-X" "zilch.zexpr" "-R" "r7rs" "-optimize-level" "3"))
  (components
@@ -11,4 +11,7 @@
     (source "src/build.sld")
     (component-dependencies zilch.lang.ninja zilch.lang.ninja.config))
   (extension zilch.lang.ninja.config
-    (source "src/config.sld"))))
+    (source "src/config.sld"))
+  (extension zilch.lang.ninja.nixpkgs
+    (source "src/nixpkgs.sld")
+    (component-dependencies zilch.lang.ninja zilch.lang.ninja.build zilch.lang.ninja.config))))