Initial commit

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)))))