Initial commit

core/src/file.sld

@@ -0,0 +1,237 @@
+(define-library (zilch file)
+  (import
+    (scheme base) (scheme case-lambda)
+    (zilch magic) (zilch nix binproto) (zilch nix daemon) (zilch nix drv) (zilch zexpr)
+    (chicken base) (chicken format)
+    (srfi 128) (srfi 132) (srfi 146) (srfi 151))
+  (export zfile zsymlink zdir 
+          zfile->store)
+
+  (begin
+    (define-record-type <z-file>
+      (make-z-file contents executable cache)
+      z-file?
+      (contents z-file-contents)
+      (executable z-file-executable)
+      (cache z-file-cache z-file-set-cache))
+
+    (define-record-printer (<z-file> file out)
+      (if (z-file-executable file)
+        (fprintf out "#<z-file (executable)>")
+        (fprintf out "#<z-file>")))
+
+    (define-record-type <z-directory>
+      (make-z-directory contents cache)
+      z-directory?
+      (contents z-directory-contents)
+      (cache z-directory-cache z-directory-set-cache))
+
+    (define-record-printer (<z-directory> dir out)
+      (fprintf out "#<z-directory")
+      (for-each (lambda (kv) (fprintf out " ~S -> ~S" (car kv) (cdr kv))) (z-directory-contents dir))
+      (fprintf out ">"))
+
+    (define-record-type <z-symlink>
+      (make-z-symlink target cache)
+      z-symlink?
+      (target z-symlink-target)
+      (cache z-symlink-cache z-symlink-set-cache))
+
+    (define-record-printer (<z-symlink> symlink out)
+      (fprintf out "#<z-symlink -> ~S>" (z-symlink-target symlink)))
+
+    (define (env-pair<? l r) (string<? (car l) (car r)))
+
+    ;; `(zfile CONTENTS [EXECUTABLE])`
+    ;;
+    ;; Create a `<z-file>` object with given contents and optional `executable` flag.
+    ;; The contents may either be a string or a `<zexp>`.
+    (define zfile
+      (case-lambda
+        ((contents) (make-z-file contents #f #f))
+        ((contents executable) (make-z-file contents executable #f))))
+
+    ;; Create a `<z-symlink>` record. The target may be any string, *or* a `<zexp>` containing one.
+    (define (zsymlink target) (make-z-symlink target #f))
+
+    ;; `(zdir CONTENTS)`
+    ;;
+    ;; Create a `<z-directory>` record. The contents is an alist of file name -> zfile/zsymlink/zdir.
+    ;; For simplicity, one can also write e.g. `(zdir "key" value "key2" value)`.
+    (define zdir
+      (case-lambda
+        ((contents) (make-z-directory (list-sort env-pair<? contents) #f))
+        (rest (do
+                ((out '()))
+                ((eq? rest '()) (make-z-directory (list-sort env-pair<? out) #f))
+                (set! out (cons (cons (car rest) (cadr rest)) out))
+                (set! rest (cddr rest))))))
+   
+    ; Here is where the weirdness starts.
+    ; To make it possible to build store paths that depend on non-fixed-output dependencies,
+    ; with as little system-specific dependencies as possible, this is implemented in a bit of a weird way.
+    ; To do this, it uses the builtin:unpack-channel builder. This builder unpacks a tarball or zip file
+    ; (or other formats, in some older versions of CppNix and Lix) and moves the one top-level file to a known name.
+    ; To do this, we implement a tiny ustar serializer.
+
+    ; First, build the baseline header used for every item in the tarball. This has precalculated checksums, so is cheap to modify and rechecksum.
+    (define baseline-ustar-header (make-bytevector 512 0))
+    ; TODO(puck): should we default to 0 instead?
+    (do ((i 100 (+ i 1))) ((= i 157) #f) (bytevector-u8-set! baseline-ustar-header i 32))
+    (for-each (lambda (i) (bytevector-u8-set! baseline-ustar-header i 0)) '(108 116 136 329 337))
+    ; TODO(puck): are these needed still?
+    (for-each (lambda (i) (bytevector-u8-set! baseline-ustar-header i (char->integer #\a))) '(0 157))
+    (bytevector-copy! baseline-ustar-header 257 (string->utf8 "ustar\x00;00"))
+    ; We subtract 32*21 here to exclude the mode, size, and typeflag fields from the baseline checksum.
+    (define baseline-ustar-header-checksum
+      (do ((i 0 (+ i 1)) (csum 0 csum))
+          ((= i 512) (- csum (* 32 21)))
+          (set! csum (+ csum (bytevector-u8-ref baseline-ustar-header i)))))
+
+    ;; Write a tar header with specified mode, content length, and type byte.
+    ;; For simplicity, all paths and link paths must be defined in PAX attributes.
+    (define (make-ustar-header mode size type)
+        (define output (bytevector-copy baseline-ustar-header))
+        (define octal-mode (number->string mode 8))
+        (bytevector-copy! output 100 (string->utf8 octal-mode))
+        (define octal-size (number->string size 8))
+        (bytevector-copy! output 124 (string->utf8 octal-size))
+        (bytevector-u8-set! output 156 (char->integer type))
+   
+        (define csum (+ baseline-ustar-header-checksum (char->integer type)))
+        (do ((i 100 (+ i 1))) ((= i 108) #f) (set! csum (+ csum (bytevector-u8-ref output i))))
+        (do ((i 124 (+ i 1))) ((= i 136) #f) (set! csum (+ csum (bytevector-u8-ref output i))))
+        (define octal-csum (number->string csum 8))
+        (bytevector-copy! output 148 (string->utf8 octal-csum))
+
+        output)
+   
+    ;; PAX extended attributes contain the length of the entire line, including the length bytes.
+    ;; Calculate the length of " {key}={value}\n" and the length of that length in decimal.
+    ;; If adding the length of the length would make the length overflow, add one more byte; then
+    ;; return the full serialized key-value pair as a string.
+    (define make-pax-extended-header
+      (case-lambda
+       ((key value) (make-pax-extended-header key value (string-length value)))
+       ((key value value-length)
+        (define kv-length (+ (string-length key) value-length 3))
+        (define length-length (string-length (number->string kv-length)))
+        (unless (eqv? length-length (string-length (number->string (+ length-length kv-length)))) (set! length-length (+ 1 length-length)))
+        (string-append (number->string (+ length-length kv-length)) " " key "=" value "\n"))))
+
+    (define padding-block (make-bytevector 512 0))
+    (define (write-padding len)
+        (define rem (bitwise-and len 511))
+        (unless (= rem 0)
+          (write-bytevector padding-block (current-output-port) 0 (- 512 rem))))
+   
+    (define (unwrap-zexp-to-placeholder zexp)
+      (define contents-zexp (zexp-unwrap zexp))
+      (define contents (zexp-evaluation-value contents-zexp))
+      (zexp-context-register-items (zexp-evaluation-drvs contents-zexp) (zexp-evaluation-srcs contents-zexp))
+      (when (string? contents)
+        (set! contents (string->utf8 contents)))
+      (define placeholder-mapping (mapping (make-default-comparator)))
+      (define has-mapping #f)
+      (for-each
+       (lambda (drv)
+        (for-each
+         (lambda (output)
+           (define output-obj (cdr (assoc output (derivation-outputs (car drv)))))
+           (when (derivation-output-placeholder? output-obj)
+             (set! placeholder-mapping (mapping-set! placeholder-mapping (derivation-output-path output-obj) (derivation-output-path-length (car drv) output)))
+             (set! has-mapping #t)))
+         (cdr drv)))
+       (zexp-evaluation-drvs contents-zexp))
+      (define contents-length (bytevector-length contents))
+      (define sliced (make-bytevector 53))
+      (when has-mapping
+       (do ((i 0 (+ 1 i)) (ref #f #f))
+           ((> i (- (bytevector-length contents) 53)) #f)
+           (when (= (bytevector-u8-ref contents i) #x2F)
+            (bytevector-copy! sliced 0 contents i (+ i 53))
+            (set! ref (mapping-ref/default placeholder-mapping (utf8->string sliced) #f))
+            (when ref (set! contents-length (+ (- contents-length 53) ref))))))
+      (values contents contents-length))
+
+    (define (write-pax-directory path)
+        (define header (string->utf8 (make-pax-extended-header "path" path)))
+        (write-bytevector (make-ustar-header 0 (bytevector-length header) #\x))
+        (write-bytevector header)
+        (write-padding (bytevector-length header))
+        (write-bytevector (make-ustar-header #o777 0 #\5)))
+
+    (define (write-pax-file path executable contents-zexp)
+        (define-values (contents contents-length) (unwrap-zexp-to-placeholder contents-zexp))
+        (define header (string->utf8 (make-pax-extended-header "path" path)))
+        (write-bytevector (make-ustar-header 0 (bytevector-length header) #\x))
+        (write-bytevector header)
+        (write-padding (bytevector-length header))
+        (write-bytevector (make-ustar-header (if executable #o555 #o444) contents-length #\0))
+        (if (bytevector? contents) (write-bytevector contents) (write-string contents))
+        (write-padding contents-length))
+
+    (define (write-pax-symlink path linkpath-zexp)
+        (define-values (linkpath linkpath-length) (unwrap-zexp-to-placeholder linkpath-zexp))
+        (define header (string->utf8 (string-append (make-pax-extended-header "path" path) (make-pax-extended-header "linkpath" (utf8->string linkpath) linkpath-length))))
+        (define total-len (+ (bytevector-length header) (- linkpath-length (bytevector-length linkpath))))
+        (write-bytevector (make-ustar-header 0 total-len #\x))
+        (write-bytevector header)
+        (write-padding total-len)
+        (write-bytevector (make-ustar-header #o777 0 #\2)))
+   
+    ;; Serialize the specified structure as a ustar-style (with pax extensions) tape archive to the standard output port. The filename is specified by `name`.
+    (define (serialize-as-tar f name)
+      (cond
+        ((z-file? f) (write-pax-file name (z-file-executable f) (z-file-contents f)))
+        ((z-directory? f)
+         (write-pax-directory name)
+         (map (lambda (entry) (serialize-as-tar (cdr entry) (string-append name "/" (car entry)))) (z-directory-contents f)))
+        ((z-symlink? f) (write-pax-symlink name (z-symlink-target f)))))
+   
+    ;; Serialize a file-like (`zfile`, `zsymlink`, `zdir`) to a `<store-path>`.
+    ;; This function should not depend on the system of the builder.
+    ;; TODO(puck): due to limitations, whatever you pass in ends up at `<store-path>/-` instead.
+    (define (zfile->store val)
+     (define cached
+       (cond
+         ((z-file? val) (z-file-cache val))
+         ((z-directory? val) (z-directory-cache val))
+         ((z-symlink? val) (z-symlink-cache val))))
+     (unless cached
+      (set! cached
+       (let*
+        ((bvport (open-output-bytevector))
+         (serialized (zexp-with-context (lambda () (parameterize ((current-output-port bvport)) (serialize-as-tar val "-")))))
+         (bv (get-output-bytevector bvport))
+         (intermediate #f)
+         (drv #f))
+        (close-port bvport)
+        ;(set! intermediate
+        ;  (zexp-with-injected-context
+        ;     (zexp
+        ;        (zexp-unquote (store-path-for-text "file" bv)))
+        ;     (cadr serialized)
+        ;     (car (cddr serialized))))
+        (set! drv
+          (store-path-for-ca-drv* "zilchfile" "builtin"
+            (zexp ("builtin:unpack-channel"))
+            (zexp (("src" . ".attr-1s42g1c76fxb77skzq0b4wdhcrg8jmzb54czmxvh1qm7psgsbcni")
+                   ("contents" . (zexp-unquote (call-with-port (open-output-bytevector) (lambda (port) (parameterize ((current-output-port port)) (serialize-as-tar val "-")) (get-output-bytevector port)))))
+                   ("passAsFile" . "contents")
+                   ("channelName" . "-")))
+            '("out")))
+        (cdar drv))))
+     (cond
+       ((z-file? val) (z-file-set-cache val cached))
+       ((z-directory? val) (z-directory-set-cache val cached))
+       ((z-symlink? val) (z-symlink-set-cache val cached)))
+     cached)
+
+   
+    (zexp-add-unquote-handler
+      (lambda (val)
+        (if (or (z-file? val) (z-symlink? val) (z-directory? val))
+            (string-append (zexp-unquote (zfile->store val)) "/-")
+            #f)))))
+

core/src/lib/getopt.sld

@@ -0,0 +1,56 @@
+(define-library (zilch lib getopt)
+  (import (scheme base) (scheme write))
+  (export getopt)
+
+  (begin
+    ; format: (option [requires value] [single char])
+    ; (single-char char) (required? bool) (value bool) (predicate func)
+    (define (is-long-option value) (and (> (string-length value) 3) (string=? (string-copy value 0 2) "--")))
+    (define (is-short-option value) (and (> (string-length value) 1) (char=? (string-ref value 0) #\-) (not (char=? (string-ref value 1) #\-))))
+   
+    (define (find-long-option options val)
+      (cond
+        ((eq? options '()) #f)
+        ((string=? (symbol->string (caar options)) val) (car options))
+        (else (find-long-option (cdr options) val))))
+
+    (define (find-short-option options val)
+      (cond
+        ((eq? options '()) #f)
+        ((and (> (length (car options)) 2) (list-ref (car options) 2) (char=? (list-ref (car options) 2) val)) (car options))
+        (else (find-short-option (cdr options) val))))
+
+    (define (getopt options vals help)
+      (do ((i 0 (+ i 1)) (outputs '() outputs) (rest '() rest))
+          ((>= i (vector-length vals)) (values outputs (reverse rest)))
+          (define val (vector-ref vals i))
+          (define option #f)
+          (cond
+             ;; If we see a "--" entry, take the rest, as this is the end of options.
+             ((string=? val "--")
+              (set! rest (append (reverse (vector->list vals (+ i 1))) rest))
+              (set! i (vector-length vals)))
+
+             ;; If this looks like a long option, look it up + find the argument
+             ((is-long-option val)
+              (set! option (find-long-option options (string-copy val 2)))
+              (unless option (help (string-append "Unknown option " val)))
+              (if (cadr option) ; requires parameter
+                  (begin
+                     (set! outputs (cons (cons (car option) (vector-ref vals (+ i 1))) outputs))
+                     (set! i (+ i 1)))
+                  (set! outputs (cons (cons (car option) #f) outputs))))
+
+             ((is-short-option val)
+              (do ((j 1 (+ j 1))) ((>= j (string-length val)) #f)
+                  (set! option (find-short-option options (string-ref val j)))
+                  (unless option (help (string-append "Unknown option -" (string (string-ref val j)))))
+                  (if (and (cadr option) (< j (- (string-length val) 1))) (help (string-append "Option -" (string (string-ref val j)) " (long option --" (symbol->string (car option)) ") requires argument, but isn't last")))
+                  (if (cadr option)
+                      (begin
+                         (set! outputs (cons (cons (car option) (vector-ref vals (+ i 1))) outputs))
+                         (set! i (+ i 1)))
+                      (set! outputs (cons (cons (car option) #f) outputs)))))
+             (else (set! rest (cons val rest))))))))
+
+        

core/src/lib/hash.scm

@@ -0,0 +1,41 @@
+(define-library (zilch lib hash)
+ (import
+   (scheme base) (scheme write)
+   (chicken foreign)
+   (srfi 151))
+ (export sha256 hex)
+
+ (begin
+   (foreign-declare "#include <sodium/crypto_hash_sha256.h>")
+  
+   (define sodium-sha256 (foreign-lambda void "crypto_hash_sha256" nonnull-u8vector nonnull-u8vector unsigned-integer64))
+   (define sodium-sha256-init (foreign-lambda void "crypto_hash_sha256_init" (nonnull-scheme-pointer "crypto_hash_sha256_state")))
+   (define sodium-sha256-update (foreign-lambda void "crypto_hash_sha256_update" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector unsigned-integer64))
+   (define sodium-sha256-final (foreign-lambda void "crypto_hash_sha256_final" (nonnull-scheme-pointer "crypto_hash_sha256_state") nonnull-u8vector))
+
+   (define (sha256 buf)
+     (define out (make-bytevector 32))
+     (cond
+       ((bytevector? buf) (sodium-sha256 out buf (bytevector-length buf)))
+       ((string? buf) (set! buf (string->utf8 buf)) (sodium-sha256 out buf (bytevector-length buf)))
+       ((input-port? buf)
+        (let
+          ((state (make-bytevector (foreign-type-size "crypto_hash_sha256_state") 0))
+           (bbuf (make-bytevector 32 0)))
+          (sodium-sha256-init state)
+          (do
+           ((bytes-read 0 (read-bytevector! bbuf buf)))
+           ((eof-object? bytes-read) (sodium-sha256-final state out))
+           (sodium-sha256-update state bbuf bytes-read))))
+       (else (error "unknown object type passed to ((zilch lib hash) sha256)")))
+    out)
+  
+   (define hexit "0123456789abcdef")
+
+   (define (hex bv)
+     (define out (make-string (* (bytevector-length bv) 2) #\!))
+     (do ((i 0 (+ i 1)))
+         ((>= i (bytevector-length bv)) out)
+       (let* ((val (bytevector-u8-ref bv i)) (q (arithmetic-shift val -4)) (r (bitwise-and val #xF)))
+         (string-set! out (* i 2) (string-ref hexit q))
+         (string-set! out (+ (* i 2) 1) (string-ref hexit r)))))))

core/src/magic.sld

@@ -0,0 +1,209 @@
+;; Defines procedures to interact with the Nix store by way of zexpressions.
+;; This library defines the `<store-path>` record type, which can be used in zexps.
+;; A `<store-path>` unquotes in `zexp`s as its store path.
+(define-library (zilch magic)
+  (import
+    (scheme base) (scheme file)
+    (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path)
+    (zilch zexpr)
+    (srfi 132)
+    (chicken base) (chicken format) socket)
+
+  (export
+    *daemon* *use-ca*
+    <store-path>
+    make-store-path store-path?
+    store-path-drv store-path-output
+
+    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
+   
+    zilch-magic-counters)
+
+  (begin
+   (define *daemon*
+     (make-parameter
+       (parameterize
+        ((socket-send-buffer-size 4096) (socket-send-size 4096) (socket-receive-timeout #f) (socket-send-timeout #f))
+        (let ((unix-socket (socket af/unix sock/stream)))
+             (socket-connect unix-socket (unix-address "/nix/var/nix/daemon-socket/socket"))
+             (let-values (((in-port out-port) (socket-i/o-ports unix-socket)))
+                         (make-daemon-link in-port out-port))))))
+   (daemon-wop-handshake (*daemon*))
+
+   (define *use-ca* (make-parameter #t))
+   
+   ;; A vector of counters, counting the amount of derivations made, built, and read
+   (define zilch-magic-counters (vector 0 0 0))
+   
+   (define (increment-counter index)
+     (vector-set! zilch-magic-counters index (+ 1 (vector-ref zilch-magic-counters index))))
+ 
+   ;; Represents a reference to an output path of a derivation, or a source file.
+   ;; if output is "", drv is the store path to a source file.
+   (define-record-type <store-path>
+     (make-store-path drv output written)
+     store-path?
+     (drv store-path-drv)
+     (output store-path-output)
+     (written store-path-written set-store-path-written!))
+   
+   (define-record-printer (<store-path> rt out)
+     (if (eqv? (store-path-output rt) "")
+       (fprintf out "#<store path ~A>" (store-path-path rt))
+       (fprintf out "#<store path ~A (~A!~A)>" (store-path-path rt) (derivation-path (store-path-drv rt)) (store-path-output rt))))
+
+   ;; Returns the store path for the output associated with this `<store-path>`.
+   (define (store-path-path path)
+     (derivation-output-path (cdr (assoc (store-path-output path) (derivation-outputs (store-path-drv path))))))
+   
+   (define (store-path-materialize path)
+     (unless (store-path-written path)
+       (write-drv-to-daemon (store-path-drv path))
+       (set-store-path-written! path #t)))
+   
+   (define (store-path-realisation path)
+     (define drv (store-path-drv path))
+     (define output (store-path-output path))
+     (define drv-output (cdr (assoc output (derivation-outputs drv))))
+     (if (or (not (derivation-output-hash drv-output)) (bytevector? (derivation-output-hash drv-output)))
+       (derivation-output-path drv-output)
+       (begin
+         (store-path-materialize path)
+         (let ((outputs (daemon-wop-query-derivation-output-map (*daemon*) (derivation-path drv))))
+           (cdr (assoc output outputs))))))
+
+   ;; Requests that the daemon build this store path.
+   (define (store-path-build path)
+     (increment-counter 1)
+     (daemon-wop-build-paths (*daemon*) (vector (string-append (derivation-path (store-path-drv path)) "!" (store-path-output path)))))
+
+   ;; Writes the `<derivation>` to the Nix store, via the currently specified `*daemon*`.
+   (define (write-drv-to-daemon drv)
+       (define path (derivation-path drv))
+       (unless (file-exists? path)
+        (let ((out (open-output-string)))
+            (derivation-serialize drv out)
+            (daemon-wop-add-text-to-store (*daemon*) (string-append (derivation-name drv) ".drv") (get-output-string out) (derivation-path-references drv))))
+       (make-store-path path "" #t))
+
+   ;; Returns a store path representing the text..
+   (define (store-path-for-text name text)
+     (increment-counter 0)
+     (define goal-path (make-text-path "sha256" (sha256 text) name '()))
+     (unless (file-exists? goal-path) (daemon-wop-add-text-to-store (*daemon*) name text '()))
+     (make-store-path goal-path "" #t))
+
+   ;; Returns a `<store-path>` for a fixed output derivation.
+   (define (store-path-for-fod name platform builder env hash-algo hash-value hash-recursive)
+     (increment-counter 0)
+     (define collected-env (zexp-unwrap env))
+     (define collected-builder (zexp-unwrap builder))
+
+     (define input-drvs (merge-drvs (zexp-evaluation-drvs collected-env) (zexp-evaluation-drvs collected-builder)))
+     (define input-srcs (merge-srcs (zexp-evaluation-srcs collected-env) (zexp-evaluation-srcs collected-builder)))
+     (define drv (make-fixed-output-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) hash-algo hash-value hash-recursive))
+     (make-store-path drv "out" #f))
+
+   ;; Returns an alist of output -> `<store-path>` for an input-addressed derivation.
+   (define (store-path-for-drv name platform builder env outputs)
+     (increment-counter 0)
+     (define collected-env (zexp-unwrap env))
+     (define collected-builder (zexp-unwrap builder))
+
+     (define input-drvs (merge-drvs (zexp-evaluation-drvs collected-env) (zexp-evaluation-drvs collected-builder)))
+     (define input-srcs (merge-srcs (zexp-evaluation-srcs collected-env) (zexp-evaluation-srcs collected-builder)))
+     (define drv (make-input-addressed-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) outputs))
+     (map (lambda (l) (cons (car l) (make-store-path drv (car l) #f))) (derivation-outputs drv)))
+
+   ;; Returns an alist of output -> `<store-path>` for an impure derivation.
+   (define (store-path-for-impure-drv name platform builder env outputs)
+     (increment-counter 0)
+     (define collected-env (zexp-unwrap env))
+     (define collected-builder (zexp-unwrap builder))
+
+     (define input-drvs (merge-drvs (zexp-evaluation-drvs collected-env) (zexp-evaluation-drvs collected-builder)))
+     (define input-srcs (merge-srcs (zexp-evaluation-srcs collected-env) (zexp-evaluation-srcs collected-builder)))
+     (define drv (make-impure-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) outputs))
+     (map (lambda (l) (cons (car l) (make-store-path drv (car l) #f))) (derivation-outputs drv)))
+
+   ;; Returns an alist of output -> `<store-path>` for a content-addressed derivation.
+   (define (store-path-for-ca-drv name platform builder env outputs)
+     (increment-counter 0)
+     (define collected-env (zexp-unwrap env))
+     (define collected-builder (zexp-unwrap builder))
+
+     (define input-drvs (merge-drvs (zexp-evaluation-drvs collected-env) (zexp-evaluation-drvs collected-builder)))
+     (define input-srcs (merge-srcs (zexp-evaluation-srcs collected-env) (zexp-evaluation-srcs collected-builder)))
+     (define drv (make-ca-derivation name platform input-drvs input-srcs (zexp-evaluation-value collected-builder) (zexp-evaluation-value collected-env) outputs))
+     (map (lambda (l) (cons (car l) (make-store-path drv (car l) #f))) (derivation-outputs drv)))
+   
+   (define (store-path-for-ca-drv* name platform builder env outputs)
+     (if (*use-ca*) (store-path-for-ca-drv name platform builder env outputs)
+                    (store-path-for-drv name platform builder env outputs)))
+
+   (define (merge-drvs left right)
+     ; Create a new pair for the head of each drvs list
+     (define drvs (map (lambda (l) (cons (car l) (cdr l))) left))
+
+     (for-each
+       (lambda (item)
+         (define left (assoc (car item) drvs derivation-equal?))
+         (if left
+           (for-each
+             (lambda (output)
+               (unless (member output (cdr left))
+                 (set-cdr! left (cons output (cdr left)))))
+             (cdr item))
+           (set! drvs (cons item drvs))))
+       right)
+     (list-sort (lambda (l r) (string<? (derivation-path (car l)) (derivation-path (car r)))) (map (lambda (a) (cons (car a) (list-sort string<? (cdr a)))) drvs)))
+
+   (define (merge-srcs left right)
+     (for-each (lambda (item) (when (eq? (member item left) #f) (set! left (cons item left)))) right)
+     (list-sort string<? left))
+
+   ;; Ensures the `<store-path>` 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))))
+
+   (zexp-add-unquote-handler
+     (lambda (val)
+       (if (store-path? val)
+           (begin
+             (if (string=? (store-path-output val) "")
+                 (begin (zexp-context-register-items '() (list (store-path-drv val))) (store-path-drv val))
+                 (begin (store-path-materialize val) (zexp-context-register-items `((,(store-path-drv val) ,(store-path-output val))) '()) (store-path-path val))))
+           #f)))))

core/src/nix/binproto.sld

@@ -0,0 +1,79 @@
+;; A series of operations that can be used to write data to ports in
+;; Nix-compatible ways.
+(define-library (zilch nix binproto)
+  (import (scheme base) (srfi 151))
+  (export
+    port-write-u64 port-read-u64
+    port-write-bytevector port-read-bytevector
+    port-write-string port-read-string
+    port-write-structured)
+
+  (begin
+    ;; Writes a little-endian 64-bit integer VAL to PORT.
+    (define (port-write-u64 val port)
+      (define bv
+        (bytevector
+          (bitwise-and #xFF val)
+          (bitwise-and #xFF (arithmetic-shift val  -8))
+          (bitwise-and #xFF (arithmetic-shift val -16))
+          (bitwise-and #xFF (arithmetic-shift val -24))
+          (bitwise-and #xFF (arithmetic-shift val -32))
+          (bitwise-and #xFF (arithmetic-shift val -40))
+          (bitwise-and #xFF (arithmetic-shift val -48))
+          (bitwise-and #xFF (arithmetic-shift val -56))))
+      (write-bytevector bv port))
+
+    ;; Reads a little-endian 64-bit integer from PORT.
+    (define (port-read-u64 port)
+      (define bv (read-bytevector 8 port))
+      (bitwise-ior
+        (arithmetic-shift (bytevector-u8-ref bv 0)  0)
+        (arithmetic-shift (bytevector-u8-ref bv 1)  8)
+        (arithmetic-shift (bytevector-u8-ref bv 2) 16)
+        (arithmetic-shift (bytevector-u8-ref bv 3) 24)
+        (arithmetic-shift (bytevector-u8-ref bv 4) 32)
+        (arithmetic-shift (bytevector-u8-ref bv 5) 40)
+        (arithmetic-shift (bytevector-u8-ref bv 6) 48)
+        (arithmetic-shift (bytevector-u8-ref bv 7) 56)))
+
+    ;; Writes a little-endian 64-bit integer containing the length of the
+    ;; bytevector, followed by the bytevector, as well as padding to align the
+    ;; output to 8 bytes.
+    (define (port-write-bytevector bv port)
+      (port-write-u64 (bytevector-length bv) port)
+      (write-bytevector bv port)
+      (define leftover-padding (- 8 (bitwise-and 7 (bytevector-length bv))))
+      (if (< leftover-padding 8) (write-bytevector (make-bytevector leftover-padding 0) port)))
+
+    ;; Reads a little-endian 64-bit integer containing the length of the
+    ;; bytevector, the bytevector, and padding to align it to 8 bytes.
+    (define (port-read-bytevector port)
+      (define count (port-read-u64 port))
+      (define data (read-bytevector count port))
+      (define leftover-padding (- 8 (bitwise-and 7 count)))
+      (when (< leftover-padding 8) (read-bytevector leftover-padding port))
+      data)
+
+    ;; Identical to  `(port-write-bytevector (string->utf8 VAL) PORT)`.
+    (define (port-write-string str port)
+      (if (bytevector? str) (port-write-bytevector str port) (port-write-bytevector (string->utf8 str) port)))
+
+    ;; Identical to  `(utf8->string (port-read-bytevector PORT))`.
+    (define (port-read-string port)
+      (utf8->string (port-read-bytevector port)))
+
+    ;; Writes an S-expression in NAR style to the port.
+    ;;
+    ;; NAR files are encoded as a list of strings, as written by 
+    ;; `port-write-string`. A list is represented as the literal string "(",
+    ;; followed by its contents, and finished with a ")".
+    ;;
+    ;; This can be used to easily serialize an in-memory representation of a
+    ;; NAR file to a format Nix accepts.
+    (define (port-write-structured val port)
+      (cond
+        ((list? val) (port-write-string "(" port) (for-each (lambda (l) (port-write-structured l port)) val) (port-write-string ")" port))
+        ((symbol? val) (port-write-string (symbol->string val) port))
+        ((string? val) (port-write-string val port))
+        ((bytevector? val) (port-write-bytevector val port))
+        (else (error "port-write-structured: cannot write unknown object"))))))

core/src/nix/daemon.sld

@@ -0,0 +1,215 @@
+;; An implementation of the client side of the Nix daemon protocol.
+;;
+;; Currently implements protocol 1.21, from around Nix 2.4.
+(define-library (zilch nix daemon)
+  (import (scheme base) (scheme write) (zilch lib hash) srfi-151
+          (zilch nix binproto) socket
+          (chicken format))
+
+  (export
+          <daemon-link> make-daemon-link daemon-link?
+          daemon-link-in-port daemon-link-out-port
+
+          daemon-write-u64 daemon-read-u64
+          daemon-write-bytevector daemon-read-bytevector
+          daemon-write-string daemon-read-string
+
+          *logger*
+          daemon-wop-handshake daemon-wop-add-text-to-store
+          daemon-wop-add-to-store-nar daemon-wop-build-paths
+          daemon-wop-query-derivation-output-map)
+
+  (begin
+
+   (define-record-type <daemon-link>
+       (make-daemon-link in-port out-port)
+       daemon-link?
+       (in-port daemon-link-in-port)
+       (out-port daemon-link-out-port))
+
+   ;; Equivalent to port-{read,write}-{u64,bytevector,string} but on the <daemon-link> instead.
+   (define (daemon-write-u64 link val) (port-write-u64 val (daemon-link-out-port link)))
+   (define (daemon-write-bytevector link val) (port-write-bytevector val (daemon-link-out-port link)))
+   (define (daemon-write-string link val) (port-write-string val (daemon-link-out-port link)))
+
+   (define (daemon-read-u64 link) (port-read-u64 (daemon-link-in-port link)))
+   (define (daemon-read-bytevector link) (port-read-bytevector (daemon-link-in-port link)))
+   (define (daemon-read-string link) (port-read-string (daemon-link-in-port link)))
+   (define (daemon-flush link) (flush-output-port (daemon-link-out-port link)))
+
+   (define build-activity #f)
+   ;; Defines a parameter that contains a procedure that is called with two
+   ;; parameters: The log event type (next, write, last, error, activity-start,
+   ;; activity-stop, activity-result) and its data.
+   ;;
+   ;; Defaults to a simple logger to the current output port.
+   (define *logger*
+     (make-parameter
+       (lambda (event data)
+           (cond
+               ((eqv? event 'next) (write-string data))
+               ((eqv? event 'write) (write-string data))
+               ((eqv? event 'error) (error data))
+               ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 104)) (set! build-activity (list-ref data 1)))
+               ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 105)) (printf "[..building ~S]\n" (vector-ref (list-ref data 5) 0)))
+               ((and (eqv? event 'activity-result) (eqv? (list-ref data 2) 101)) (write-string (vector-ref (cadr (cddr data)) 0)) (newline))
+               ((and (eqv? event 'activity-result) (eqv? (list-ref data 1) build-activity) (eqv? (list-ref data 2) 105))
+                (let* ((ndata (list-ref data 3)) (done-builds (vector-ref ndata 0)) (total-builds (vector-ref ndata 1)) (running-builds (vector-ref ndata 2)))
+                  (printf "[~S/~S builds, ~S running]\n" done-builds total-builds running-builds)))))))
+
+   ;; Reads a list of log events until STDERR_LAST is called.
+   ;; This is the client-side equivalent of startWorking / stopWorking on the
+   ;; server.
+   (define (daemon-read-log-events link)
+       (define val (daemon-read-u64 link))
+       (case val
+         ((#x6f6c6d67) ((*logger*) 'next (daemon-read-string link)) (daemon-read-log-events link)) ; STDERR_NEXT
+         ((#x64617461) (daemon-write-u64 link (daemon-read-u64 link)) (daemon-read-log-events link)) ; STDERR_READ
+         ((#x64617416) ((*logger*) 'write (daemon-read-string link))  (daemon-read-log-events link)) ; STDERR_WRITE
+         ((#x616c7473) ((*logger*) 'last '()) (list)) ; STDERR_LAST
+         ((#x63787470) ((*logger*) 'error (daemon-read-string link))) ; STDERR_ERROR
+         ((#x53545254) ((*logger*) 'activity-start (daemon-read-activity-start link)) (daemon-read-log-events link)) ; STDERR_START_ACTIVITY
+         ((#x53544f50) ((*logger*) 'activity-stop (daemon-read-u64 link)) (daemon-read-log-events link))
+         ((#x52534c54) ((*logger*) 'activity-result (daemon-read-activity-result link)) (daemon-read-log-events link))
+         (else => (error (string-append "read-log-events: unknown event #x" (number->string val 16))))))
+
+   ;; Read a list of activity fields from the provided <daemon-link>.
+   (define (daemon-read-activity-fields link)
+       (letrec ((read-field (lambda (v i n)
+                             (vector-set! v i (case (daemon-read-u64 link)
+                                                 ((0) (daemon-read-u64 link))
+                                                 ((1) (daemon-read-string link))
+                                                 (else => (error "read-activity-fields: unknown field type"))))
+                             (unless (<= n 1) (read-field v (+ i 1) (- n 1))))))
+        (let*
+          ((count (daemon-read-u64 link))
+           (fields (make-vector count)))
+          (if (> count 0) (read-field fields 0 count))
+          fields)))
+
+   ;; Read an activity-start object from the provided <daemon-link>.
+   (define (daemon-read-activity-start link)
+       (define act (daemon-read-u64 link))
+       (define lvl (daemon-read-u64 link))
+       (define typ (daemon-read-u64 link))
+       (define s (daemon-read-string link))
+       (define fields (daemon-read-activity-fields link))
+       (define parent (daemon-read-u64 link))
+       `(activity-start ,act ,lvl ,typ ,s ,fields ,parent))
+
+   ;; Read an activity-result object from the provided <daemon-link>.
+   (define (daemon-read-activity-result link)
+       (define act (daemon-read-u64 link))
+       (define typ (daemon-read-u64 link))
+       (define fields (daemon-read-activity-fields link))
+       `(activity-result ,act ,typ ,fields))
+
+   ;; Read an Error object from the provided <daemon-link>.
+   (define (daemon-read-error link)
+       (letrec ((read-trace (lambda (v i n) (let*
+                                             ((pos (daemon-read-u64 link))
+                                              (hint (daemon-read-string link)))
+                                             (vector-set! v i `(,pos ,hint))
+                                             (unless (<= n 1) (read-trace v (+ i 1) (- n 1)))))))
+           (let*
+               ((type (daemon-read-string link))
+                (level (daemon-read-u64 link))
+                (name (daemon-read-string link))
+                (msg (daemon-read-string link))
+                (have-pos (daemon-read-u64 link))
+                (trace-count (daemon-read-u64 link))
+                (traces (make-vector trace-count)))
+              (if (> trace-count 0) (read-trace traces 0 trace-count))
+              `(error ,type ,level ,msg ,traces))))
+
+   ;; Send a Nix worker protocol handshake.
+   (define (daemon-wop-handshake link)
+       (daemon-write-u64 link #x6e697863)
+       (daemon-flush link)
+       (define worker-magic (daemon-read-u64 link))
+       (define protocol-version (daemon-read-u64 link))
+       (define protocol-major (bitwise-and (arithmetic-shift protocol-version -8) #xFF))
+       (define protocol-minor (bitwise-and protocol-version #xFF))
+       (unless (= worker-magic #x6478696f) (error "handshake: received wrong WORKER_MAGIC_2" worker-magic))
+       (unless (= protocol-major 1) (error "handshake: invalid major version protocol" protocol-major))
+       (daemon-write-u64 link #x115)
+       (daemon-write-u64 link 0) ; cpu affinity
+       (daemon-write-u64 link 0)
+       (daemon-flush link)
+       (daemon-read-log-events link)
+
+       ; Send wopSetOptions too, to adjust verbosity.
+       (daemon-write-u64 link 19)
+       (daemon-write-u64 link 0) ; keepFailed
+       (daemon-write-u64 link 0) ; keepGoing
+       (daemon-write-u64 link 0) ; tryFallback
+       (daemon-write-u64 link 3) ; verbosity (lvlInfo)
+       (daemon-write-u64 link 63) ; maxBuildJobs
+       (daemon-write-u64 link 0) ; maxSilentTime
+       (daemon-write-u64 link 0) ; obsolete, useBuildHook
+       (daemon-write-u64 link 0) ; verboseBuild (unused?)
+       (daemon-write-u64 link 0) ; obsolete, logType
+       (daemon-write-u64 link 0) ; obsolete, printBuildTrace
+       (daemon-write-u64 link 0) ; buildCores
+       (daemon-write-u64 link 0) ; useSubstitutes
+       (daemon-write-u64 link 0) ; settings overrides
+       (daemon-flush link)
+       (daemon-read-log-events link))
+
+
+   ;; Request to the daemon that the paths in PATHS have to be built.
+   ;; Each path may either be an output path, or `<drv>!<output name>`.
+   (define (daemon-wop-build-paths link paths)
+       (letrec ((send-paths (lambda (i)
+                                (daemon-write-string link (vector-ref paths i))
+                                (unless (>= (+ 1 i) (vector-length paths)) (send-paths (+ 1 i))))))
+            (daemon-write-u64 link 9)
+            (daemon-write-u64 link (vector-length paths))
+            (send-paths 0)
+            (daemon-write-u64 link 0)
+            (daemon-flush link)
+            (daemon-read-log-events link)
+            (daemon-read-u64 link)))
+
+   ;; Write a simple text file to the store. REFS is expected to be sorted.
+   ;; Returns the store path at which the file has been created.
+   (define (daemon-wop-add-text-to-store link suffix s refs)
+       (daemon-write-u64 link 8)
+       (daemon-write-string link suffix)
+       (daemon-write-string link s)
+       (daemon-write-u64 link (length refs))
+       (for-each (lambda (l) (daemon-write-string link l)) refs)
+       (daemon-flush link)
+       (daemon-read-log-events link)
+       (daemon-read-string link))
+
+   ;; Write a NAR (as bytevector) to the store. REFS is expected to be sorted.
+   (define (daemon-wop-add-to-store-nar link path deriver refs val ca)
+     (daemon-write-u64 link 39)
+     (daemon-write-string link path)
+     (if (eq? #f deriver) (daemon-write-string link "") (daemon-write-string link deriver))
+     (daemon-write-string link (string-append "sha256:" (hex (sha256 val))))
+     (daemon-write-u64 link (length refs))
+     (for-each (lambda (l) (daemon-write-string link l)) refs)
+     (daemon-write-u64 link 0)
+     (daemon-write-u64 link (bytevector-length val))
+     (daemon-write-u64 link 1)
+     (daemon-write-u64 link 0)
+     (daemon-write-string link ca)
+     (daemon-write-u64 link 0)
+     (daemon-write-u64 link 0)
+     (daemon-write-bytevector link val)
+     (daemon-flush link)
+     (daemon-read-log-events link))
+
+   (define (daemon-wop-query-derivation-output-map link store-path)
+     (daemon-write-u64 link 41)
+     (daemon-write-string link store-path)
+     (daemon-flush link)
+     (daemon-read-log-events link)
+     (define count (daemon-read-u64 link))
+     (do ((out '()) (i 0 (+ i 1)))
+         ((>= i count) out)
+         (let* ((name (daemon-read-string link))
+                (path (daemon-read-string link)))
+               (set! out (cons (cons name (if (string=? path "") #f path)) out)))))))

core/src/nix/drv.sld

@@ -0,0 +1,510 @@
+;; Implements the Nix .drv file format.
+(define-library (zilch nix drv)
+  (import
+    (scheme base) (scheme case-lambda) (scheme write) (scheme file)
+    (zilch lib hash) (zilch nix hash) (zilch nix path)
+    (srfi 128) (srfi 132) (srfi 146)
+    (chicken base) (chicken format))
+
+  (export
+    %derivation-compatible
+    <derivation-output> derivation-output?
+    derivation-output-path derivation-output-hash
+    derivation-output-algo derivation-output-recursive
+    derivation-output-placeholder? derivation-output-path-length
+
+    write-quoted-string
+
+    <derivation> derivation?
+    derivation-name derivation-outputs derivation-input-drvs
+    derivation-input-src derivation-system derivation-builder
+    derivation-args derivation-env derivation-equal?
+   
+    derivation-serialize derivation-path-references derivation-path derivation-read read-drv-path
+    make-fixed-output-derivation make-input-addressed-derivation make-impure-derivation make-ca-derivation)
+
+  (begin
+    ;; If `#t`, outputs environment variables not used by Nix, but required for compatibility with Nix's output.
+    ;; This adds `name`, `builder`, and `system` to the environment; as well as `outputHash`, `outputHashAlgo`,
+    ;; and `outputHashMode` for fixed-output derivations.
+    (define %derivation-compatible (make-parameter #t))
+
+    ;; Describes the output path of a derivation, along with its hash and
+    ;; whether or not it the hash is of the NAR file, if it is a content-addressed output.
+    ;; The path can be read using `(derivation-output-path)`.
+    ;;
+    ;; - `(path #u8() "" #f)` is an input-addressed derivation output. TODO(puck): empty bytevector?
+    ;; - `(path #f #f #f)` is an input-addressed derivation output. TODO(puck): empty bytevector?
+    ;; - `(path hash-value hash-algo rec)` is a content-addressed derivation output.
+    ;; - `(#f 'floating hash-algo rec)` is a floating content-addressed derivation output.
+    ;; - `(#f 'impure hash-algo rec)` is an impure content-addressed derivation output.
+    (define-record-type <derivation-output>
+      (make-derivation-output path hash algo recursive)
+      derivation-output?
+      (path derivation-output-path set-derivation-output-path!)
+      (hash derivation-output-hash)
+      (algo derivation-output-algo)
+      (recursive derivation-output-recursive))
+     
+    (define-record-printer (<derivation-output> drvout out)
+      (fprintf out "#<derivation-output ~s hash: ~s algo: ~s recursive: ~s>"
+        (derivation-output-path drvout)
+        (derivation-output-hash drvout)
+        (derivation-output-algo drvout)
+        (derivation-output-recursive drvout)))
+     
+    (define (derivation-output-placeholder? drvout)
+      (member (derivation-output-hash drvout) '(floating impure)))
+     
+    (define (derivation-output-path-length drv output-name)
+      ; /nix/store/a0a3n97c93ckfg3a920aqnycxdznbbmi-module-output
+      (+ (string-length (%store-dir)) 34 (string-length (derivation-name drv)) (if (string=? output-name "out") 0 (+ 1 (string-length output-name)))))
+
+    ;; Internal use; stores the precalculated .drv path and modulo hash.
+    (define-record-type <derivation-cached-data>
+      (make-derivation-cached-data path modulo-hash is-deferred serialized)
+      derivation-cached-data?
+      (path derivation-cached-data-path set-derivation-cached-data-path!)
+      (modulo-hash derivation-cached-data-modulo-hash set-derivation-cached-data-modulo-hash!)
+      (is-deferred derivation-cached-data-is-deferred set-derivation-cached-data-is-deferred!)
+      (serialized derivation-cached-data-serialized set-derivation-cached-data-serialized!))
+
+    (define-record-printer (<derivation-cached-data> drv out)
+      (fprintf out "#<derivation-cached-data path: ~S, hash: ~S, deferred: ~S>"
+        (derivation-cached-data-path drv)
+        (derivation-cached-data-modulo-hash drv)
+        (derivation-cached-data-is-deferred drv)))
+     
+    ;; An entire derivation.
+    ;; `outputs` is stored as an alist of output name to `<derivation-output>` object.
+    ;; `input-drvs` is stored as an alist of `<derivation>` to a (sorted) list of its outputs that are used.
+    ;; The `outputs`, `input-drvs`, `input-src`, and `env` are expected to be sorted.
+    (define-record-type <derivation>
+      (make-derivation name outputs input-drvs input-src system builder args env cached-data)
+      derivation?
+      (name derivation-name)
+
+      ; '(id . <derivation-output>)
+      (outputs derivation-outputs)
+
+      ; '(<derivation> . (first-output second-output ...))
+      (input-drvs derivation-input-drvs)
+
+      ; '(file-path file-path ...)
+      (input-src derivation-input-src)
+      (system derivation-system)
+      (builder derivation-builder)
+      (args derivation-args)
+      (env derivation-env)
+
+      (cached-data derivation-cached-data))
+
+    (define-record-printer (<derivation> drv out)
+      (fprintf out "#<derivation ~s ~s inputs: ~s ~s, ~s ~s ~s ~s, cached data ~S>"
+        (derivation-name drv)
+        (derivation-outputs drv)
+        (derivation-input-drvs drv)
+        (derivation-input-src drv)
+        (derivation-system drv)
+        (derivation-builder drv)
+        (derivation-args drv)
+        (derivation-env drv)
+        (derivation-cached-data drv)))
+
+    (define (write-delim-list start end fn val port)
+      (write-char start port)
+      (define is-first #t)
+      (for-each
+        (lambda (v)
+          (cond (is-first (set! is-first #f))
+                (else (write-char #\, port)))
+          (fn v)) val)
+      (write-char end port))
+
+    (define (mask-outputs outputs)
+      (map
+        (lambda (l)
+          (define left (car l))
+          (define right (cdr l))
+          (cons
+            left
+            (make-derivation-output
+              ""
+              (derivation-output-hash right)
+              (derivation-output-algo right)
+              (derivation-output-recursive right))))
+        outputs))
+
+    (define (mask-env env outputs)
+      (map
+        (lambda (l)
+          (if (assoc (car l) outputs)
+            (cons (car l) "")
+            l))
+        env))
+     
+    ;; Return a copy of the received `<derivation>`, but with the outputs masked out.
+    (define (mask-derivation drv)
+      (make-derivation
+        (derivation-name drv)
+        (mask-outputs (derivation-outputs drv))
+        (derivation-input-drvs drv)
+        (derivation-input-src drv)
+        (derivation-system drv)
+        (derivation-builder drv)
+        (derivation-args drv)
+        (mask-env (derivation-env drv) (derivation-outputs drv))
+        (make-derivation-cached-data #f #f #f #f)))
+
+    ;; Returns whether this `<derivation>` is considered fixed-output by Nix or not.
+    (define (drv-is-fod drv)
+      (define outs (derivation-outputs drv))
+      (define first-output (car outs))
+      (define first-output-id (car first-output))
+      (define first-output-is-hash (bytevector? (derivation-output-hash (cdr first-output))))
+      (and (= (length outs) 1) (string=? first-output-id "out") first-output-is-hash))
+
+    (define (drv-is-impure drv)
+      (eq? (derivation-output-hash (cdr (car (derivation-outputs drv)))) 'impure))
+
+    (define (env-pair< left right)
+      (string<? (car left) (car right)))
+     
+    ;; Calculate the "modulo" contents (that will have to be hashed) of a derivation.
+    (define (modulo-hash-drv-contents drv)
+      (cond
+        ((drv-is-fod drv)
+         (let ((out (cdar (derivation-outputs drv))))
+          (string->utf8 (string-append "fixed:out:" (if (derivation-output-recursive out) "r:" "") (derivation-output-algo out) ":" (hex (derivation-output-hash out)) ":" (derivation-output-path out)))))
+        ((drv-is-impure drv)
+         (string->utf8 "impure"))
+        (else
+         (let ((remapped-input-drvs '())
+               (output-port (open-output-bytevector))
+               (is-deferred #f))
+             ; TODO: this needs to merge output names too (depending on two distinct drvs with the same output hash requires merging their output names.)
+             (for-each (lambda (l)
+                        (let* ((new-hash (hex (modulo-hash-drv (car l)))))
+                              (set! is-deferred (or is-deferred (derivation-cached-data-is-deferred (derivation-cached-data (car l))) (drv-is-impure (car l))))
+                              (unless (assoc new-hash remapped-input-drvs) (set! remapped-input-drvs (cons (cons new-hash (cdr l)) remapped-input-drvs)))))
+                       (derivation-input-drvs drv))
+             (set! remapped-input-drvs (list-sort env-pair< remapped-input-drvs))
+             (derivation-serialize drv output-port remapped-input-drvs)
+             (get-output-bytevector output-port)))))
+     
+    ;; Modulo-hash a derivation. This returns a hash that will stay the same, as long as the only
+    ;; changes made (transitively) are which variant of a fixed-output derivation is used. This is
+    ;; what is used in the calculation of the output path of an input-addressed derivation.
+    (define (modulo-hash-drv drv)
+      (if (eq? (derivation-cached-data-modulo-hash (derivation-cached-data drv)) #f)
+        (let ((hash (sha256 (modulo-hash-drv-contents drv))))
+             (set-derivation-cached-data-modulo-hash! (derivation-cached-data drv) hash)
+             hash)
+        (derivation-cached-data-modulo-hash (derivation-cached-data drv))))
+     
+    ;; Creates a fixed-output derivation with specified parameters.
+    (define (make-fixed-output-derivation name platform input-drvs input-srcs builder env hash-algo hash-value recursive)
+      (define output-path (make-fixed-output-path recursive hash-algo hash-value name))
+      (define output (make-derivation-output output-path hash-value hash-algo recursive))
+      (define new-items `(("out" . ,output-path)))
+      (when (%derivation-compatible)
+            (set! new-items
+                  `(("outputHash" . ,(hex hash-value))
+                    ("outputHashAlgo" . ,hash-algo)
+                    ("outputHashMode" . ,(if recursive "recursive" "flat"))
+                    ("name" . ,name)
+                    ("builder" . ,(car builder))
+                    ("system" . ,platform)
+                    . ,new-items)))
+      (make-derivation name (list (cons "out" output)) input-drvs input-srcs platform (car builder) (cdr builder) (list-sort env-pair< (append new-items env)) (make-derivation-cached-data #f #f #f #f)))
+
+    (define (sanity-check-drv orig-drv)
+      (define tmp-drv (mask-derivation orig-drv))
+      (define modulo-hash (modulo-hash-drv tmp-drv))
+      (define name (derivation-name orig-drv))
+      (for-each
+        (lambda (output)
+          (unless (string=? (derivation-output-path (cdr output)) (make-output-path "sha256" modulo-hash (car output) name))
+            (fprintf (current-error-port) "meow ~S\n" (utf8->string (derivation-cached-data-serialized (derivation-cached-data tmp-drv))))
+            (error "Derivation output path mismatch: " (make-output-path "sha256" modulo-hash (car output) name) " vs " (derivation-output-path (cdr output)))))
+        (derivation-outputs orig-drv)))
+
+    ;; Creates an input-addressed derivation with specified parameters.
+    (define (make-input-addressed-derivation name platform input-drvs input-srcs builder env outputs)
+      (define compat-env (if (%derivation-compatible) `(("name" . ,name) ("builder" . ,(car builder)) ("system" . ,platform)) '()))
+
+      (define tmp-outputs (list-sort env-pair< (map (lambda (l) (cons l (make-derivation-output #f #f #f #f))) outputs)))
+      (define tmp-env (list-sort env-pair< (apply append (list (map (lambda (l) (cons l "")) outputs)
+                                                               compat-env
+                                                               env))))
+
+      (define tmp-drv (make-derivation name tmp-outputs input-drvs input-srcs platform (car builder) (cdr builder) tmp-env (make-derivation-cached-data #f #f #f #f)))
+      (define modulo-hash (modulo-hash-drv tmp-drv))
+      (define is-deferred (derivation-cached-data-is-deferred (derivation-cached-data tmp-drv)))
+
+      (define new-outputs (list-sort env-pair< (map (lambda (l) (cons l (make-derivation-output
+                                                                         (if is-deferred #f (make-output-path "sha256" modulo-hash l name)) #f #f #f))) outputs)))
+      (define new-env (list-sort env-pair< (apply append (list (map (lambda (l) (cons l (make-output-path "sha256" modulo-hash l name))) outputs) compat-env env))))
+
+      (define drv (make-derivation name new-outputs input-drvs input-srcs platform (car builder) (cdr builder) new-env (make-derivation-cached-data #f #f (derivation-cached-data-is-deferred (derivation-cached-data tmp-drv)) #f)))
+      (sanity-check-drv drv)
+      drv)
+
+    ;; Creates an impure addressed derivation with specified parameters.
+    (define (make-impure-derivation name platform input-drvs input-srcs builder nenv noutputs)
+      (define compat-env (if (%derivation-compatible) `(("name" . ,name) ("builder" . ,(car builder)) ("system" . ,platform)) '()))
+
+      (define outputs (list-sort env-pair< (map (lambda (l) (cons l (make-derivation-output
+                                                                     #f 'impure "sha256" #t))) noutputs)))
+      (define env (list-sort env-pair< (apply append (list (map (lambda (l) (cons (car l) (make-placeholder (car l)))) outputs) compat-env nenv))))
+
+      (define drv (make-derivation name outputs input-drvs input-srcs platform (car builder) (cdr builder) env (make-derivation-cached-data #f #f #t #f)))
+      (define pathhash (string-copy (derivation-path drv) (+ 1 (string-length (%store-dir))) (+ 33 (string-length (%store-dir)))))
+      (for-each (lambda (pair) (set-derivation-output-path! (cdr pair) (make-upstream-output-placeholder pathhash name (car pair)))) (derivation-outputs drv))
+      drv)
+
+    ;; Creates a content-addressed derivation with specified parameters.
+    (define (make-ca-derivation name platform input-drvs input-srcs builder nenv noutputs)
+      (define compat-env (if (%derivation-compatible) `(("name" . ,name) ("builder" . ,(car builder)) ("system" . ,platform)) '()))
+
+      (define outputs (list-sort env-pair< (map (lambda (l) (cons l (make-derivation-output
+                                                                     #f 'floating "sha256" #t))) noutputs)))
+      (define env (list-sort env-pair< (apply append (list (map (lambda (l) (cons (car l) (make-placeholder (car l)))) outputs) compat-env nenv))))
+
+      (define drv (make-derivation name outputs input-drvs input-srcs platform (car builder) (cdr builder) env (make-derivation-cached-data #f #f #t #f)))
+      (define pathhash (string-copy (derivation-path drv) (+ 1 (string-length (%store-dir))) (+ 33 (string-length (%store-dir)))))
+      (for-each (lambda (pair) (set-derivation-output-path! (cdr pair) (make-upstream-output-placeholder pathhash name (car pair)))) (derivation-outputs drv))
+      drv)
+
+    (define (write-derivation-output pair)
+      (define output-name (car pair))
+      (define output (cdr pair))
+      (write-paren-list write-quoted-string
+        (list output-name
+          (if (member (derivation-output-hash output) '(impure floating)) "" (or (derivation-output-path output) ""))
+          (string-append (if (derivation-output-recursive output) "r:" "") (or (derivation-output-algo output) ""))
+          (cond
+            ((bytevector? (derivation-output-hash output)) (hex (derivation-output-hash output)))
+            ((eq? (derivation-output-hash output) 'impure) "impure")
+            ((eq? (derivation-output-hash output) 'floating) "")
+            ((not (derivation-output-hash output)) "")
+            (else (error "unknown derivation output hash type"))))))
+     
+    ;; Returns a sorted list of store paths that the `.drv` file of this derivation depends on.
+    (define (derivation-path-references drv)
+      (define input-drv-paths (map (lambda (l) (if (string? (car l)) (car l) (derivation-path (car l)))) (derivation-input-drvs drv)))
+      (list-sort string<? (append input-drv-paths (derivation-input-src drv))))
+
+    ;; Returns the store path belonging to this derivation's `.drv` file.
+    (define (derivation-path drv)
+      (if (eq? (derivation-cached-data-path (derivation-cached-data drv)) #f)
+        (let ((drv-output-port (open-output-bytevector)))
+             (derivation-serialize drv drv-output-port)
+             (define path (make-text-path "sha256" (sha256 (get-output-bytevector drv-output-port)) (string-append (derivation-name drv) ".drv") (derivation-path-references drv)))
+             (set-derivation-cached-data-path! (derivation-cached-data drv) path)
+             path)
+        (derivation-cached-data-path (derivation-cached-data drv))))
+
+    (define (derivation-equal? left right)
+      (define left-cached-path (derivation-cached-data-path (derivation-cached-data left)))
+      (define right-cached-path (derivation-cached-data-path (derivation-cached-data right)))
+      (define left-serialized (derivation-cached-data-serialized (derivation-cached-data left)))
+      (define right-serialized (derivation-cached-data-serialized (derivation-cached-data right)))
+
+      (or (eqv? left right)
+          (and left-cached-path right-cached-path (string=? left-cached-path right-cached-path))
+          (and left-serialized right-serialized (eqv? left-serialized right-serialized))
+          (and
+            (string=? (derivation-name left) (derivation-name right))
+            (string=? (derivation-system left) (derivation-system right))
+            (string=? (derivation-builder left) (derivation-builder right))
+            (equal? (derivation-input-src left) (derivation-input-src right))
+            (equal? (derivation-outputs left) (derivation-outputs right))
+            (equal? (derivation-args left) (derivation-args right))
+            (equal? (derivation-env left) (derivation-env right))
+            (and
+              (= (length (derivation-input-drvs left)) (length (derivation-input-drvs right)))
+              (let ((eq #f))
+                (for-each (lambda (l r) (and (equal? (cdr l) (cdr r)) (derivation-equal? (car l) (car r)))) (derivation-input-drvs left) (derivation-input-drvs right)))))))
+
+    (define write-paren-list
+      (case-lambda
+        ((fn val) (write-delim-list #\( #\) fn val (current-output-port)))
+        ((fn val port) (write-delim-list #\( #\) fn val port))))
+
+    (define write-bracket-list
+      (case-lambda
+        ((fn val) (write-delim-list #\[ #\] fn val (current-output-port)))
+        ((fn val port) (write-delim-list #\[ #\] fn val port))))
+
+    (define write-quoted-string
+      (case-lambda
+        ((val) (write-quoted-string val (current-output-port)))
+        ((val port) 
+         (write-char #\" port)
+         (do
+           ((buf (if (string? val) (string->utf8 val) val))
+            (start 0)
+            (i 0 (+ i 1)))
+           ((= i (bytevector-length buf)) (when (or (= start 0) (< start i)) (write-bytevector buf port start i)))
+           (define x (bytevector-u8-ref buf i))
+           (cond ((= x #x22) (when (< start i) (write-bytevector buf port start i)) (set! start (+ 1 i)) (write-string "\\\"" port))
+                 ((= x #x5C) (when (< start i) (write-bytevector buf port start i)) (set! start (+ 1 i)) (write-string "\\\\" port))
+                 ((= x #x0A) (when (< start i) (write-bytevector buf port start i)) (set! start (+ 1 i)) (write-string "\\n" port))
+                 ((= x #x0D) (when (< start i) (write-bytevector buf port start i)) (set! start (+ 1 i)) (write-string "\\r" port))
+                 ((= x #x09) (when (< start i) (write-bytevector buf port start i)) (set! start (+ 1 i)) (write-string "\\t" port))))
+         (write-char #\" port))))
+
+    (define (read-static-string strval port)
+      (define read-data (read-string (string-length strval) port))
+      (unless (string=? read-data strval) (error (string-append "Expected `" strval "', got `" read-data "'"))))
+
+    (define (parse-hash-algo hashstr)
+      (cond
+        ((< (string-length hashstr) 2) (cons hashstr #f))
+        ((string=? (string-copy hashstr 0 2) "r:")
+         (cons (string-copy hashstr 2) #t))
+        (else (cons hashstr #f))))
+
+    (define (read-paren-list fn port)
+      (read-static-string "(" port)
+      (do ((tail '())) ((= (peek-u8 port) #x29) (read-u8 port) (reverse tail))
+          (set! tail (cons (fn) tail))
+          (when (= (peek-u8 port) #x2C) (read-u8 port))))
+
+    (define (read-bracket-list fn port)
+      (read-static-string "[" port)
+      (do ((tail '())) ((= (peek-u8 port) #x5D) (read-u8 port) (reverse tail))
+          (set! tail (cons (fn) tail))
+          (when (= (peek-u8 port) #x2C) (read-u8 port))))
+
+    (define (drv-name-from-path path)
+      (do ((i 0 (+ i 1)))
+          ((or (= i (string-length path)) (char=? (string-ref path i) #\-)) (string-copy path (+ i 1) (- (string-length path) 4)))))
+
+    (define read-drv-paths (mapping (make-default-comparator)))
+
+    ;; Reads a .drv file from the passed in path, and caches it for
+    ;; later reuse.
+    (define (read-drv-path path)
+      (define already-read (mapping-ref/default read-drv-paths path #f))
+      (if already-read
+          already-read
+          (let* ((read-val (call-with-port (open-input-file path) (lambda (port) (derivation-read port (drv-name-from-path path)))))
+                 (new-path (derivation-path read-val)))
+           (unless (string=? new-path path) (error (string-append "derivation path mismatch: " path " orig, " new-path " new")))
+           (unless (drv-is-fod read-val) (sanity-check-drv read-val))
+           (set! read-drv-paths (mapping-set! read-drv-paths path read-val))
+           read-val)))
+
+
+    (define (dehex strval)
+      (do ((outval (make-bytevector (/ (string-length strval) 2)))
+           (i 0 (+ i 1)))
+          ((= i (bytevector-length outval)) outval)
+          (bytevector-u8-set! outval i (string->number (string-copy strval (* i 2) (* (+ i 1) 2)) 16))))
+
+    (define (read-quoted-string port)
+      (read-static-string "\"" port)
+      (do ((buf (make-bytevector 32)) (cap 32) (len 0))
+          ((= (peek-u8 port) #x22) (read-u8 port) (utf8->string (bytevector-copy buf 0 len)))
+
+          (define val (read-u8 port))
+          (when (= val #x5C)
+            (set! val (read-u8 port))
+            (cond
+              ((= val #x6E) (set! val #x0A))
+              ((= val #x72) (set! val #x0D))
+              ((= val #x74) (set! val #x09))))
+          (when (= len cap)
+            (let ((newbuf (make-bytevector (* 2 cap))))
+                (bytevector-copy! newbuf 0 buf)
+                (set! buf newbuf)
+                (set! cap (bytevector-length newbuf))))
+          (bytevector-u8-set! buf len val)
+          (set! len (+ 1 len))))
+
+    ;; `(derivation-read port name [read-drv-path])`
+    ;; Reads a `<derivation>` from the `port`. If `read-drv-path` is set, will be used to read dependencies of this derivation,
+    ;; rather than the default of reading from the local Nix store.
+    (define derivation-read
+      (case-lambda
+        ((port name) (derivation-read port name read-drv-path))
+        ((port name read-drv)
+         (read-static-string "Derive(" port); )
+         (define drv-outputs
+           (read-bracket-list
+             (lambda ()
+               (define data (read-paren-list (lambda () (read-quoted-string port)) port))
+               (define path (cadr data))
+               (define output-name (car data))
+               (define hash-algo-recursive (parse-hash-algo (list-ref data 2)))
+               (define hash-value-hex (list-ref data 3))
+               (if (string=? hash-value-hex "")
+                   (cons output-name (make-derivation-output path #f #f #f))
+                   (cons output-name (make-derivation-output path (dehex hash-value-hex) (car hash-algo-recursive) (cdr hash-algo-recursive))))) port))
+         (read-static-string "," port)
+         (define input-drvs
+           (read-bracket-list
+             (lambda ()
+               (read-static-string "(" port)
+               (define drv (read-drv (read-quoted-string port)))
+               (read-static-string "," port)
+               (define outputs (read-bracket-list (lambda () (read-quoted-string port)) port))
+               (read-static-string ")" port)
+               (cons drv outputs)) port))
+         (read-static-string "," port)
+         (define input-srcs (read-bracket-list (lambda () (read-quoted-string port)) port))
+         (read-static-string "," port)
+         (define system (read-quoted-string port))
+         (read-static-string "," port)
+         (define builder-argv0 (read-quoted-string port))
+         (read-static-string "," port)
+         (define builder-args (read-bracket-list (lambda () (read-quoted-string port)) port))
+         (read-static-string "," port)
+         (define environ (read-bracket-list (lambda () (define data (read-paren-list (lambda () (read-quoted-string port)) port)) (cons (car data) (cadr data))) port))
+         (read-static-string ")" port)
+         (make-derivation name drv-outputs input-drvs input-srcs system builder-argv0 builder-args environ (make-derivation-cached-data #f #f #f #f)))))
+
+    (define (derivation-serialize-internal drv port masked)
+      (parameterize ((current-output-port port))
+        (write-string "Derive(")
+        (write-bracket-list write-derivation-output (derivation-outputs drv))
+        (write-u8 #x2C)
+        (write-bracket-list
+          (lambda (l)
+            (write-u8 #x28)
+            (write-quoted-string (if (string? (car l)) (car l) (derivation-path (car l))))
+            (write-u8 #x2C)
+            (write-bracket-list write-quoted-string (cdr l))
+            (write-u8 #x29)) masked)
+        (write-u8 #x2C)
+        (write-bracket-list write-quoted-string  (derivation-input-src drv))
+        (write-u8 #x2C)
+        (write-quoted-string (derivation-system drv))
+        (write-u8 #x2C)
+        (write-quoted-string (derivation-builder drv))
+        (write-u8 #x2C)
+        (write-bracket-list write-quoted-string (derivation-args drv))
+        (write-u8 #x2C)
+        (write-bracket-list (lambda (l) (write-paren-list write-quoted-string (list (car l) (cdr l)))) (derivation-env drv))
+        (write-u8 #x29)))
+
+    ;; `(derivation-serialize drv [port] [masked])`
+    ;;
+    ;; Writes the derivation to the specified port, or current-output-port if none is supplied.
+    ;; If masked is set, writes the derivation using the passed-in input derivations, rather than the default one.
+    (define derivation-serialize
+      (case-lambda
+        ((drv) (derivation-serialize drv (current-output-port)))
+        ((drv port) (derivation-serialize drv port (derivation-input-drvs drv)))
+        ((drv port masked)
+         (if masked (derivation-serialize-internal drv port masked)
+           (if (derivation-cached-data-serialized (derivation-cached-data drv))
+               (write-bytevector (derivation-cached-data-serialized (derivation-cached-data drv)) port)
+               (call-with-port (open-output-bytevector)
+                 (lambda (nport)
+                   (derivation-serialize-internal drv nport #f)
+                   (set-derivation-cached-data-serialized! (derivation-cached-data drv) (get-output-bytevector nport))
+                   (write-bytevector (get-output-bytevector nport) port))))))))))
+

core/src/nix/hash.sld

@@ -0,0 +1,56 @@
+;; Nix hash helpers.
+(define-library (zilch nix hash)
+  (import (scheme base) (srfi 151))
+  (export as-base32 from-base32 hash-compress)
+
+  (begin
+    (define base16-table "0123456789abcdef")
+    (define base32-table "0123456789abcdfghijklmnpqrsvwxyz")
+
+    ;; XORs the last 12 bytes of the hash with the first 12.
+    (define (hash-compress hash)
+      (do ((output-hash (make-bytevector 20 0)) (i 0 (+ i 1)))
+          ((= i (bytevector-length hash)) output-hash)
+          (bytevector-u8-set! output-hash (floor-remainder i 20) (bitwise-xor (bytevector-u8-ref output-hash (floor-remainder i 20)) (bytevector-u8-ref hash i)))))
+
+    ;; Turns bytevector HASH to a Nix-style (reversed base32) format.
+    (define (as-base32 hash)
+      (do ((len (+ (floor-quotient (- (* 8 (bytevector-length hash)) 1) 5) 1)) (tail '()) (i 0 (+ i 1)))
+          ((= i len) (list->string tail))
+          (let*
+            ((offset-bits (* i 5))
+             (offset-bytes (floor-quotient offset-bits 8))
+             (offset (floor-remainder offset-bits 8))
+             (first-byte (arithmetic-shift (bitwise-and #xFF (bytevector-u8-ref hash offset-bytes)) (- 0 offset)))
+             (second-byte (arithmetic-shift (bitwise-and #xFF (if (< (+ offset-bytes 1) (bytevector-length hash)) (bytevector-u8-ref hash (+ offset-bytes 1)) 0)) (- 8 offset))))
+            (set! tail (cons (string-ref base32-table (bitwise-and #x1F (bitwise-ior first-byte second-byte))) tail)))))
+
+    (define (char-index chr)
+      (do ((i 0 (+ i 1)))
+          ((or (= i 32) (char=? (string-ref base32-table i) chr))
+           (when (= i 32) (error "unknown character in nixbase32 string" chr))
+           i)))
+
+    ;; Returns a nix-base32 string decoded into a bytevector.
+    (define (from-base32 hash)
+      (do ((i 0 (+ i 1))
+           (strlen (string-length hash))
+           (output (make-bytevector (floor-quotient (* (string-length hash) 5) 8) 0)))
+          ((= i (string-length hash)) output)
+          (let*
+            ((digit (char-index (string-ref hash (- (- strlen 1) i))))
+             (offset-bits (* i 5))
+             (offset-bytes (floor-quotient offset-bits 8))
+             (offset (floor-remainder offset-bits 8)))
+            (bytevector-u8-set! output offset-bytes
+             (bitwise-and #xFF
+              (bitwise-ior
+               (bytevector-u8-ref output offset-bytes)
+               (arithmetic-shift digit offset))))
+            (if (= (+ offset-bytes 1) (bytevector-length output))
+              (unless (= 0 (arithmetic-shift digit (- offset 8))) (error "invalid nixbase32 string: hash has trailing bits" hash))
+              (begin
+               (bytevector-u8-set! output (+ offset-bytes 1)
+                 (bitwise-ior
+                  (bytevector-u8-ref output (+ offset-bytes 1))
+                  (arithmetic-shift digit (- offset 8)))))))))))

core/src/nix/path.sld

@@ -0,0 +1,64 @@
+;; A series of helpers that help create store paths.
+;; 
+;; These helpers all use the `%store-dir` parameter as base store directory.
+(define-library (zilch nix path)
+  (import
+    (scheme base)
+    (zilch lib hash) (zilch nix hash))
+
+  (export
+    %store-dir
+    impure-placeholder make-upstream-output-placeholder make-placeholder
+    make-store-path-from-parts make-text-path make-fixed-output-path make-output-path)
+
+  (begin
+    ;; The path to the store dir, as a parameter.
+    (define %store-dir (make-parameter "/nix/store"))
+
+    (define impure-placeholder (sha256 "impure"))
+
+    (define (make-upstream-output-placeholder drv-hash-string drv-name output-name)
+      (string-append "/" (as-base32 (sha256 (string-append "nix-upstream-output:" drv-hash-string ":" drv-name (if (string=? output-name "out") "" (string-append "-" output-name)))))))
+
+    ;; Makes a placeholder path, which is substituted with the path of the output.
+    (define (make-placeholder output-name)
+      (string-append "/" (as-base32 (sha256 (string->utf8 (string-append "nix-output:" output-name))))))
+
+    ;; Takes a list of references, and joins them together, separated (and
+    ;; prepended) by a colon.
+    (define (fold-references references collected)
+      (cond
+        ((eqv? references '()) collected)
+        (else (fold-references (cdr references) (string-append collected ":" (car references))))))
+
+    ;; Creates an arbitrary Nix store path.
+    (define (make-store-path-from-parts type hash-algo hash-val name)
+      (let*
+        ((inner (string-append type ":" hash-algo ":" (hex hash-val) ":" (%store-dir) ":" name))
+         (hashed (as-base32 (hash-compress (sha256 (string->utf8 inner))))))
+        (string-append (%store-dir) "/" hashed "-" name)))
+
+    ;; Creates a store path belonging to a derivation output. HASH-ALGO and
+    ;; HASH-VAL encode the (masked) modulo hash of the derivation.
+    (define (make-output-path hash-algo hash-val output-name name)
+      (make-store-path-from-parts
+        (string-append "output:" output-name)
+        hash-algo hash-val
+        (if (string=? output-name "out") name (string-append name "-" output-name))))
+
+    ;; Creates a store path belonging to a text file. Text files may only
+    ;; depend on other text files, and are used in input-srcs rather than
+    ;; input-drvs. refs is expected to be sorted.
+    (define (make-text-path hash-algo hash-value name refs)
+      (make-store-path-from-parts (fold-references refs "text") hash-algo hash-value name))
+
+    ;; Creates a fixed-output store path.
+    (define (make-fixed-output-path recursive hash-algo hash-value name)
+      (if (and recursive (string=? hash-algo "sha256"))
+        (make-store-path-from-parts "source" hash-algo hash-value name)
+        (make-store-path-from-parts "output:out"
+          "sha256"
+          (sha256
+            (string->utf8
+               (string-append "fixed:out:" (if recursive "r:" "") hash-algo ":" (hex hash-value) ":")))
+          name)))))

core/src/nixpkgs.sld

@@ -0,0 +1,37 @@
+(define-library (zilch nixpkgs)
+  (import
+    (scheme base)
+    (zilch magic) (zilch nix drv) (zilch nix hash)
+    (chicken process))
+  (export nix-prefetch-url nixpkgs)
+
+  (begin
+    (define (read-from-nixpkgs path)
+      (define-values (stdout stdin pid) (process "nix-instantiate" `("--argstr" "path" ,path "-E" "{path}: let nixpkgs = import <nixpkgs> {}; in nixpkgs.${path}.out")))
+      (close-port stdin)
+      (define drvpath (read-line stdout))
+      (define-values (_ _ _) (process-wait pid #t))
+      (close-port stdout)
+      drvpath)
+   
+    ;; Returns the hash (as bytevector) of prefetching the specified URL.
+    (define (nix-prefetch-url name url)
+      (define-values (stdout stdin pid) (process "nix-prefetch-url" `("--name" ,name "--" ,url)))
+      (close-port stdin)
+      (define hash (read-line stdout))
+      (define-values (_ _ _) (process-wait pid #t))
+      (close-port stdout)
+      (from-base32 hash))
+
+    (define eval-cache '())
+
+    ;; Read a derivation out of nixpkgs.
+    (define (nixpkgs path)
+      (define val (assoc path eval-cache))
+      (if (not (eq? val #f))
+          (cdr val)
+          (let* ((drv-path (read-from-nixpkgs path))
+                 (drv (read-drv-path drv-path))
+                 (data (map (lambda (l) (cons (car l) (make-store-path drv (car l) #t))) (derivation-outputs drv))))
+            (set! eval-cache (cons (cons path data) eval-cache))
+            data)))))

core/src/statusbar.sld

@@ -0,0 +1,167 @@
+(define-library (zilch statusbar)
+  (import
+    (scheme base) (scheme write)
+    (srfi 18) (srfi 128) (srfi 146) (srfi 151) (srfi 152)
+    (chicken base) (chicken format) (chicken port) (chicken process signal)
+    (zilch magic))
+
+  (export
+    statusbar-logger)
+
+  (begin
+    (define (buffered-port mutex write-output-line redraw-status-bar close-this-port)
+      (define line-buffer (make-bytevector 1024 0))
+      (define line-buffer-location 0)
+      (define (append-to-buffer data start end)
+          (when (>= (+ line-buffer-location (- end start)) (bytevector-length line-buffer))
+            (let ((new-buffer (make-bytevector (* 2 (bytevector-length line-buffer)) 0)))
+                 (bytevector-copy! new-buffer 0 line-buffer 0 line-buffer-location)
+                 (set! line-buffer new-buffer)))
+          (bytevector-copy! line-buffer line-buffer-location data start end)
+          (set! line-buffer-location (+ line-buffer-location (- end start))))
+
+      (define (write-data buf start)
+        (define newline-location
+          (do ((i start (+ i 1)))
+              ((or (>= i (bytevector-length buf)) (= (bytevector-u8-ref buf i) #x0A))
+               (if (>= i (bytevector-length buf)) #f i))))
+        (if newline-location
+          (begin
+           (append-to-buffer buf start newline-location)
+           (write-output-line line-buffer 0 line-buffer-location)
+           (set! line-buffer-location 0)
+           (write-data buf (+ 1 newline-location)))
+          (begin
+           (append-to-buffer buf start (bytevector-length buf))
+           (when start
+             (redraw-status-bar))
+           (mutex-unlock! mutex))))
+      (make-output-port (lambda (str) (mutex-lock! mutex) (write-data (string->utf8 str) 0)) close-this-port))
+
+    (define (statusbar-logger out-port err-port print-logs)
+      (define status-bar "[0/0 builds, 0 running] ...")
+      (define terminal-width 80)
+      (define-values (rows cols) (terminal-size err-port))
+      (when (> cols 0) (set! terminal-width cols))
+
+      (define (terminal-width-thread-thunk handler)
+        (handler #t)
+        (mutex-lock! out-mutex)
+        (define-values (rows cols) (terminal-size err-port))
+        (when (> cols 0) (set! terminal-width cols))
+        (mutex-unlock! out-mutex)
+        (terminal-width-thread-thunk handler))
+      (define terminal-width-thread (make-thread (lambda () (terminal-width-thread-thunk (make-signal-handler signal/winch)))))
+
+      (define (draw-status-bar)
+        (fprintf err-port "\r\x1B[2K") ; ]
+        (if (<= (string-length status-bar) terminal-width)
+          (write-string status-bar err-port)
+          (begin
+            (write-string status-bar err-port 0 (- terminal-width 3))
+            (write-string "..." err-port)))
+        (flush-output-port err-port)
+        (set! need-redraw #f))
+       
+      (define out-mutex (make-mutex))
+      (define need-redraw #f)
+      (define rerender-status-bar #f)
+      (define (redraw-thread-thunk)
+        (rerender-status-bar)
+        (mutex-lock! out-mutex)
+        (draw-status-bar)
+        (mutex-unlock! out-mutex)
+        (thread-sleep! 0.1)
+        (redraw-thread-thunk))
+      (define redraw-thread (make-thread redraw-thread-thunk "redraw thread"))
+
+      (define last-builds-activity-id #f)
+      (define last-builds-activity-data (vector 0 0 0 0))
+      (define last-activity-start-id #f)
+      (define last-activity-start "")
+
+      (define (write-err-line buf start end)
+        (if print-logs
+          (begin
+            (unless need-redraw
+              (fprintf err-port "\r\x1B[2K")) ; ]
+            (write-bytevector buf err-port start end)
+            (fprintf err-port "\n")
+            (set! need-redraw #t))
+          (begin
+            (set! last-activity-start-id #f)
+            (set! last-activity-start (utf8->string (bytevector-copy buf start end)))
+            (set! need-redraw #t))))
+
+      (define (write-out-line buf start end)
+        (unless need-redraw
+          (fprintf err-port "\r\x1B[2K")) ; ]
+        (flush-output-port err-port)
+        (write-bytevector buf out-port start end)
+        (fprintf out-port "\n")
+        (set! need-redraw #t))
+
+      (define (bypass-write buf)
+        (mutex-lock! out-mutex)
+        (write-err-line buf 0 (bytevector-length buf))
+        (draw-status-bar)
+        (set! need-redraw #f)
+        (mutex-unlock! out-mutex))
+       
+      (define (close-this-port)
+         (mutex-lock! out-mutex)
+         (thread-terminate! redraw-thread)
+         (thread-terminate! terminal-width-thread)
+         (mutex-unlock! out-mutex)
+         (fprintf err-port "\r\x1B[2K\n")
+         (close-output-port err-port)
+         (close-output-port out-port))
+
+      (define new-err-port (buffered-port out-mutex write-err-line draw-status-bar close-this-port))
+      (define new-out-port (buffered-port out-mutex write-out-line draw-status-bar close-this-port))
+      (on-exit close-this-port)
+
+      (define build-activity-mapping (mapping (make-default-comparator)))
+      (set! rerender-status-bar
+        (lambda ()
+          (mutex-lock! out-mutex)
+          (set! status-bar (sprintf "[~S drv  ~S bld  ~S ifd | nix: ~S/~S builds, ~S running] ~A"
+                                    (vector-ref zilch-magic-counters 0)
+                                    (vector-ref zilch-magic-counters 1)
+                                    (vector-ref zilch-magic-counters 2)
+                                    (vector-ref last-builds-activity-data 0)
+                                    (vector-ref last-builds-activity-data 1)
+                                    (vector-ref last-builds-activity-data 2)
+                                    last-activity-start))
+          (set! need-redraw #t)
+          (mutex-unlock! out-mutex)))
+      (define (handle-log-event event data)
+       (cond
+        ((eqv? event 'next) (bypass-write (string->utf8 data)))
+        ((eqv? event 'write) (bypass-write (string->utf8 data)))
+        ((eqv? event 'error) (error data))
+        ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 104)) (set! last-builds-activity-id (list-ref data 1)))
+        ((and (eqv? event 'activity-start) (eq? (list-ref data 3) 105))
+         (set! build-activity-mapping
+           (mapping-set! build-activity-mapping (list-ref data 1)
+             (string-drop-while (vector-ref (list-ref data 5) 0) (lambda (f) (not (char=? f #\-)))))))
+        ((eqv? event 'activity-start) (set! last-activity-start-id (list-ref data 1)) (set! last-activity-start (list-ref data 4)) (rerender-status-bar))
+        ((eqv? event 'activity-stop)
+         (set! build-activity-mapping (mapping-delete! build-activity-mapping data)))
+        ((and (eqv? event 'activity-result) (eqv? (list-ref data 2) 101))
+         (let ((drv-name (mapping-ref/default build-activity-mapping (list-ref data 1) #f)))
+              (when drv-name
+                (let ((msg (string-append drv-name "> " (vector-ref (list-ref data 3) 0))))
+                  (mutex-lock! out-mutex)
+                  (set! last-activity-start msg)
+                  (set! last-activity-start-id (list-ref data 1))
+                  (mutex-unlock! out-mutex)
+                  (when print-logs
+                    (bypass-write (string->utf8 msg)))))))
+        ((and (eqv? event 'activity-result) (eqv? (list-ref data 1) last-builds-activity-id))
+         (set! last-builds-activity-data (list-ref data 3))
+         (rerender-status-bar))))
+      (thread-start! redraw-thread)
+      (thread-start! terminal-width-thread)
+      (define (set-print-logs val) (set! print-logs val))
+      (values new-out-port new-err-port set-print-logs handle-log-event))))

core/src/zexpr.sld

@@ -0,0 +1,183 @@
+;;; Defines `zexp`, or zilch-expressions.
+;;; A zexp is a Scheme expression that may reference other zexps, or
+;;; for example `<store-path>` objects.
+(define-library (zilch zexpr)
+  (import
+    (scheme base) (scheme read) (scheme write)
+    (zilch nix drv)
+    (chicken base) (chicken format))
+
+  (cond-expand (chicken (import (chicken read-syntax))))
+
+  (export
+    <zexp> make-zexp zexp? zexp-thunk
+    <zexp-context> make-zexp-context zexp-context?
+    zexp-context-srcs set-zexp-context-srcs!
+    zexp-context-drvs set-zexp-context-drvs!
+
+    <zexp-evaluation> zexp-evaluation?
+    zexp-evaluation-value zexp-evaluation-drvs
+    zexp-evaluation-srcs
+
+    zexp-context-register-items
+    zexp zexp-quote-inner zexp-unquote
+    zexp-add-unquote-handler zexp-unwrap
+    zexp-with-injected-context zexp-with-context)
+
+  (begin
+    ;; A zexp (concept inspired from Guix g-expressions) is represented as a
+    ;; thunk that returns the quoted value, and writes the metadata (e.g. string context) necessary
+    ;; into `++*zexp-context*++`.
+
+    ;; `(make-zexp thunk printer)`
+    ;; `thunk` `(zexp-thunk zexp)` is the thunk called when evaluating the zexp.
+    ;; `printer` `(zexp-printer zexp)` is a thunk that is called with a port to print a representation of the zexp.
+    (define-record-type <zexp>
+      (make-zexp thunk printer)
+      zexp?
+      (thunk zexp-thunk)
+      (printer zexp-printer))
+
+    (define-record-printer (<zexp> zexp out)
+      (fprintf out "#<zexp val: ")
+      ((zexp-printer zexp) out)
+      (fprintf out ">"))
+
+    ;; The context used to evaluate a zexp, stored in `++*zexp-context*++` during the evaluation.
+    ;;
+    ;; Stores a list of sources in `zexp-content-srcs` (settable using `set-zexp-context-srcs!`)
+    ;; and an alist of derivations with a list of their outputs in `zexp-content-drvs` (settable using `set-zexp-context-drvs!`)
+    ;;
+    ;; Prefer using zexp-context-register-items over directly interacting with this record.
+    (define-record-type <zexp-context>
+      (make-zexp-context srcs drvs)
+      zexp-context?
+      (srcs zexp-context-srcs set-zexp-context-srcs!)
+      (drvs zexp-context-drvs set-zexp-context-drvs!))
+
+    (define-record-printer (<zexp-evaluation> zeval out)
+      (fprintf out "#<zexp-context drvs: ~s; srcs: ~s>"
+        (zexp-context-drvs zeval)
+        (zexp-context-srcs zeval)))
+
+    ;; The output of evaluating a `zexp`.
+    ;;
+    ;; drvs is an alist of derivation path to a list of outputs used.
+    ;; srcs is a list of source store paths used.
+    (define-record-type <zexp-evaluation>
+      (make-zexp-evaluation value drvs srcs)
+      zexp-evaluation?
+      (value zexp-evaluation-value)
+      (drvs zexp-evaluation-drvs)
+      (srcs zexp-evaluation-srcs))
+   
+    (define-record-printer (<zexp-evaluation> zeval out)
+      (fprintf out "#<zexp-evaluation val: ~s; drvs: ~s; srcs: ~s>"
+        (zexp-evaluation-value zeval)
+        (zexp-evaluation-drvs zeval)
+        (zexp-evaluation-srcs zeval)))
+    
+    ;; Adds any new items from a list of sources and an alist of derivations to the current `++*zexp-context*++`.
+    ;; drvs is an alist of derivation object to output. name.
+    ;; TODO(puck): 'spensive?
+    (define (zexp-context-register-items drvs srcs)
+      (define ctx (*zexp-context*))
+      (define ctx-src (and ctx (zexp-context-srcs ctx)))
+      (define ctx-drvs (and ctx (zexp-context-drvs ctx)))
+      (when ctx
+         (for-each (lambda (src)
+                       (when (eq? (member src ctx-src) #f)
+                             (set! ctx-src (cons src ctx-src))
+                             (set-zexp-context-srcs! ctx ctx-src))) srcs)
+         (for-each (lambda (drv)
+                       (define pair (assoc (car drv) ctx-drvs derivation-equal?))
+                       (if (eq? pair #f)
+                           (begin
+                            (set! ctx-drvs (cons drv ctx-drvs))
+                            (set-zexp-context-drvs! ctx ctx-drvs))
+                           (for-each (lambda (output)
+                                         (unless (member output (cdr pair)) (set-cdr! pair (cons output (cdr pair))))) (cdr drv)))) drvs)))
+
+    ;; The current zexp evaluation context. #f if not evaluating a zexp.
+    (define *zexp-context* (make-parameter #f))
+
+    ; The actual zexp "quote" equivalent.
+    (define-syntax zexp
+      (syntax-rules (unquote)
+        ((zexp-quote stuff) (make-zexp (lambda () (zexp-quote-inner stuff)) (lambda (port) (write (quote stuff) port))))))
+
+    ; If external objects want to be unquotable, they can override this procedure.
+    (define zexp-unquote-handler (lambda (v) v))
+
+    (define zexp-unquote-handlers '())
+
+    ;; Add a procedure to be called when unquotingg an unknown value.
+    ;; This procedure should return #f if the value passed in cannot be unquoted by this handler.
+    (define (zexp-add-unquote-handler handler) (set! zexp-unquote-handlers (cons handler zexp-unquote-handlers)))
+
+    (define (iter-unquote-handler val handlers)
+        (if (eq? handlers '())
+            (error "Cannot unquote this value.")
+            (let ((result ((car handlers) val)))
+                 (if (eq? result #f)
+                     (iter-unquote-handler val (cdr handlers))
+                     result))))
+
+    ;; Used in the `zexp` macro to zexp-unquote values.
+    (define (zexp-unquote val)
+      (cond
+        ((pair? val) (cons (zexp-unquote (car val)) (zexp-unquote (cdr val))))
+        ((vector? val) (vector-map (lambda (val) (zexp-unquote val)) val))
+
+        ; (zexp (zexp-unquote (zexp (foo bar)))) -> (zexp (foo bar))
+        ; TODO: keep this?
+        ((zexp? val) ((zexp-thunk val)))
+        ((or (boolean? val) (char? val) (null? val) (symbol? val) (bytevector? val) (eof-object? val) (number? val) (string? val)) val)
+        (else (iter-unquote-handler val zexp-unquote-handlers))))
+
+    ;; Unwraps a <zexp>, returning a <zexp-evaluation> containing the proper quoted expressions, and its dependencies.
+    (define (zexp-unwrap val)
+      (parameterize ((*zexp-context* (make-zexp-context '() '())))
+                    (let ((nval (zexp-unquote val)))
+                         (make-zexp-evaluation nval (zexp-context-drvs (*zexp-context*)) (zexp-context-srcs (*zexp-context*))))))
+
+    ;;; Returns a `<zexp>` that returns the same value as `<val>`, but adds the drvs/srcs as context.
+    (define (zexp-with-injected-context val drvs srcs)
+      (make-zexp (lambda () (zexp-context-register-items drvs srcs) ((zexp-thunk val))) (lambda (port) (write val port))))
+
+    (define (zexp-with-context fn)
+      (parameterize ((*zexp-context* (make-zexp-context '() '())))
+                    (let ((result (fn))) (list result  (zexp-context-drvs (*zexp-context*)) (zexp-context-srcs (*zexp-context*))))))
+
+    ; If trying to quote a pair, we return a cons with both arguments recursively quoted.
+    ; When an zexp-unquote (e.g. #~) is encountered, it is replaced with a call to the zexp-unquote procedure.
+    (define-syntax zexp-quote-inner
+      (syntax-rules (unquote unquote-splicing zexp-quote-inner zexp-unquote zexp-unquote-splicing)
+       ((zexp-quote-inner ((zexp-unquote-splicing to-splice) . right))
+        (apply
+           append
+           (list (map zexp-unquote (zexp-unquote to-splice))
+                 (zexp-quote-inner right))))
+       ((zexp-quote-inner (zexp-unquote item))
+        (zexp-unquote item))
+
+       ; (zexp-quote-inner (foo bar baz)) -> (cons (zexp-quote-inner foo) (cons (zexp-quote-inner bar) (zexp-quote-inner baz)))
+       ((zexp-quote-inner (unquote item)) item)
+       ((zexp-quote-inner ((unquote-splicing item) . right)) (append item (zexp-quote-inner right)))
+       ((zexp-quote-inner (left)) (cons (zexp-quote-inner left) '()))
+       ((zexp-quote-inner (left . right)) (cons (zexp-quote-inner left) (zexp-quote-inner right)))
+       ((zexp-quote-inner item) (quote item))))
+
+    (cond-expand
+      (chicken
+        (set-sharp-read-syntax! #\~
+          (lambda (port) (define contents (read port)) (list 'zexp contents)))
+        (set-sharp-read-syntax! #\$
+          (lambda (port)
+            (list
+              (if (char=? (peek-char port) #\@)
+                  (begin (read-char port) 'zexp-unquote-splicing)
+                  'zexp-unquote)
+              (read port))))))))
+
+