puck/zilch
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit

Browse source
This commit is contained in:
puck 2024-10-03 23:57:22 +00:00
commit 55a1efa08f
60 changed files with 5485 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

23
core/default.nix Normal file
View file

@ -0,0 +1,23 @@
{ chickenPackages, libsodium, callPackage }:
(callPackage ../lib/build-chicken-parallel {}) {
name = "zilch";
src = ./.;
buildInputs = with chickenPackages.chickenEggs; [
chickenPackages.chicken
socket
r7rs
vector-lib
srfi-18
srfi-60
srfi-128
srfi-132
srfi-146
srfi-151
srfi-152
srfi-180
trace
libsodium # TODO(puck): don't propagate this
];
}

237
core/src/file.sld Normal file
View file

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

56
core/src/lib/getopt.sld Normal file
View file

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

41
core/src/lib/hash.scm Normal file
View file

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

209
core/src/magic.sld Normal file
View file

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

79
core/src/nix/binproto.sld Normal file
View file

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

215
core/src/nix/daemon.sld Normal file
View file

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

510
core/src/nix/drv.sld Normal file
View file

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

56
core/src/nix/hash.sld Normal file
View file

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

64
core/src/nix/path.sld Normal file
View file

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

37
core/src/nixpkgs.sld Normal file
View file

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

167
core/src/statusbar.sld Normal file
View file

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

183
core/src/zexpr.sld Normal file
View file

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

41
core/zilch.egg Normal file
View file

@ -0,0 +1,41 @@
((version "0.0.1")
(synopsis "Nix. Noppes. Nada.")
(author "puck")
(dependencies socket r7rs vector-lib srfi-60 srfi-128 srfi-132 srfi-146 srfi-151 srfi-152 srfi-180 trace)
(component-options
(csc-options "-X" "r7rs" "-R" "r7rs" "-optimize-level" "3"))
(components
(extension zilch.nix.hash
(source "src/nix/hash.sld"))
(extension zilch.nix.binproto
(source "src/nix/binproto.sld"))
(extension zilch.lib.hash
(source "src/lib/hash.scm")
(csc-options "-L" "-lsodium"))
(extension zilch.nix.path
(source "src/nix/path.sld")
(component-dependencies zilch.lib.hash zilch.nix.hash))
(extension zilch.magic
(source "src/magic.sld")
(component-dependencies
zilch.lib.hash zilch.nix.daemon zilch.nix.drv zilch.nix.path zilch.zexpr))
(extension zilch.zexpr
(source "src/zexpr.sld")
(component-dependencies zilch.nix.drv))
(extension zilch.file
(source "src/file.sld")
(component-dependencies zilch.magic zilch.nix.binproto zilch.nix.daemon zilch.nix.drv zilch.zexpr))
(extension zilch.nixpkgs
(source "src/nixpkgs.sld")
(component-dependencies zilch.magic zilch.nix.drv zilch.nix.hash))
(extension zilch.nix.daemon
(source "src/nix/daemon.sld")
(component-dependencies zilch.lib.hash zilch.nix.binproto))
(extension zilch.nix.drv
(source "src/nix/drv.sld")
(component-dependencies zilch.lib.hash zilch.nix.hash zilch.nix.path))
(extension zilch.statusbar
(source "src/statusbar.sld")
(component-dependencies zilch.magic))
(extension zilch.lib.getopt
(source "src/lib/getopt.sld"))))