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

1
.envrc Normal file
View file

@ -0,0 +1 @@
use nix

2
.gitignore vendored Normal file
View file

@ -0,0 +1,2 @@
docs/modules/ROOT/pages/*.sld.adoc
docs/modules/ROOT/pages/*.scm.adoc

14
aux/overlay.nix Normal file
View file

@ -0,0 +1,14 @@
_: prevpkgs: {
chickenPackages_5 = prevpkgs.chickenPackages_5.overrideScope (_: prevchicken: {
chickenEggs = prevchicken.chickenEggs.overrideScope (_: preveggs: {
r7rs = preveggs.r7rs.overrideAttrs (o: {
patches = (o.patches or []) ++ [ ./r7rs.patch ];
});
socket = preveggs.socket.overrideAttrs (o: {
preBuild = null;
postPatch = "echo 'touch socket-config' >> build-socket-config";
});
});
});
}

49
aux/r7rs.patch Normal file
View file

@ -0,0 +1,49 @@
diff --git a/scheme.base.scm b/scheme.base.scm
index 763e50c..35e90a0 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -43,7 +43,7 @@
(import (rename (only srfi-4 make-u8vector subu8vector u8vector
u8vector? u8vector-length u8vector-ref
u8vector-set! read-u8vector read-u8vector!
- write-u8vector)
+ write-u8vector u8vector->blob/shared)
(u8vector bytevector)
(u8vector-length bytevector-length)
(u8vector-ref bytevector-u8-ref)
@@ -51,7 +51,8 @@
(u8vector? bytevector?)
(make-u8vector make-bytevector)
(read-u8vector read-bytevector)
- (write-u8vector write-bytevector)))
+ (write-u8vector write-bytevector)
+ (u8vector->blob/shared %u8vector->blob/shared)))
;; u8-ready?
(import (rename (only scheme char-ready?)
@@ -597,10 +598,8 @@
(##sys#check-range start 0 (fx+ end 1) 'utf8->string)
(##sys#check-range end start (fx+ len 1) 'utf8->string)
(let ((s (##sys#make-string (fx- end start))))
- (do ((si 0 (fx+ si 1))
- (vi start (fx+ vi 1)))
- ((fx= vi end) s)
- (##sys#setbyte s si (bytevector-u8-ref bv vi))))))))
+ (##sys#copy-bytes (%u8vector->blob/shared bv) s start 0 (fx- end start))
+ s)))))
(case-lambda
((bv) (bv->s bv 0))
((bv start) (bv->s bv start))
@@ -614,10 +613,8 @@
(##sys#check-range start 0 (fx+ end 1) 'string->utf8)
(##sys#check-range end start (fx+ len 1) 'string->utf8)
(let ((bv (make-bytevector (fx- end start))))
- (do ((vi 0 (fx+ vi 1))
- (si start (fx+ si 1)))
- ((fx= si end) bv)
- (bytevector-u8-set! bv vi (##sys#byte s si))))))))
+ (##sys#copy-bytes s (%u8vector->blob/shared bv) start 0 (fx- end start))
+ bv)))))
(case-lambda
((s) (s->bv s 0))
((s start) (s->bv s start))

9
cli/cli.egg Normal file
View file

@ -0,0 +1,9 @@
((version "0.0.1")
(synopsis "meow")
(author "puck")
(dependencies r7rs zilch zilch-lang-go)
(component-options
(csc-options "-X" "r7rs" "-R" "r7rs" "-optimize-level" "3"))
(components
(program zilch-cli-go
(source "zilch-go.scm"))))

11
cli/default.nix Normal file
View file

@ -0,0 +1,11 @@
{ pkgs, eggDerivation, chickenPackages }:
eggDerivation {
name = "zilch-cli";
src = ./.;
buildInputs = with chickenPackages.chickenEggs; [
r7rs
(pkgs.callPackage ../core {})
(pkgs.callPackage ../lang/go {})
];
}

106
cli/zilch-go.scm Normal file
View file

@ -0,0 +1,106 @@
(import (scheme base) (scheme write) (zilch statusbar) (zilch nix daemon) (zilch lib getopt) (scheme process-context) (chicken process-context) (srfi 146) (chicken port))
(define (print-help msg)
(when msg
(write-string (string-append msg "\n\n") (current-error-port)))
(write-string "Usage: zilch-cli-go [OPTION] [PACKAGE...]
Process the given module (or the current directory, if unspecified) and
output derivations for each package given on the command line (or all
executables in the module, if unspecified)
-h, --help Print this help message.
-b, --build Build the store paths, rather than show their
derivations.
-L, --print-build-logs Print derivation logs as they come in.
-m, --module-dir DIR The directory to use as root module.
-r, --replace DIR Replace the module specified by the go.mod
with this source directory, rather than using
the upstream module. Can be specified more
than once.
--debug Crash on the first error, rather than
continuing with the next package.
" (current-error-port))
(exit (or (not msg) 1)))
(define-values (options args)
(getopt
'((help #f #\h)
(module-dir #t #\m)
(print-build-logs #f #\L)
(build #f #\b)
(replace #t #\r)
(debug #f))
(list->vector (cdr (command-line)))
print-help))
(when (assoc 'help options) (print-help #f))
(define module-dir (if (assoc 'module-dir options) (cdr (assoc 'module-dir options)) (current-directory)))
(define (set-print-logs val) #f)
(when (terminal-port? (current-error-port))
(let-values (((new-out new-err statusbar-set-print-logs logger) (statusbar-logger (current-output-port) (current-error-port) (assoc 'print-build-logs options))))
(current-output-port new-out)
(current-error-port new-err)
(set! set-print-logs statusbar-set-print-logs)
(*logger* logger)))
(define do-build (assoc 'build options))
(define do-debug (assoc 'debug options))
(import
(scheme file) (chicken file) (chicken format)
(zilch magic)
(zilch lang go mod) (zilch lang go vfs) (zilch lang go)
(zilch nix drv)
(zilch lang go))
(unless (file-exists? (string-append module-dir "/go.mod"))
(set-print-logs #t)
(fprintf (current-error-port) "Refusing to use directory ~S as it contains no go.mod.\n" module-dir)
(exit 1))
(define vfs (vfs-from-directory module-dir))
(define replaces '())
(for-each
(lambda (kv)
(when (eq? (car kv) 'replace)
(unless (file-exists? (string-append (cdr kv) "/go.mod"))
(set-print-logs #t)
(fprintf (current-error-port) "Refusing to use directory ~S as it contains no go.mod.\n" (cdr kv))
(exit 1))
(set! replaces (cons (vfs-from-directory (cdr kv)) replaces))))
options)
(define-values (module-name collected-requires) (collect-requirements-for-module vfs replaces))
(define-values (find-package find-packages-for-module) (collect-packages-from-requires collected-requires))
(define (print-package-info package-name skip-if-not-bin)
(define-values (package err)
(call-with-current-continuation
(lambda (cc)
(if do-debug
(values (find-package package-name) #f)
(with-exception-handler (lambda (err) (cc #f err)) (lambda () (values (find-package package-name) #f)))))))
(if err
(write-string (string-append package-name "\tskipped: " (error-object-message err) "\n"))
(begin
(if (string=? (go-package-name package) "main")
(let ((linked (go-package-link package)))
(write-string (string-append package-name "\t"))
(store-path-materialize linked)
(if do-build
(begin
(store-path-build linked)
(write-string (store-path-realisation linked)))
(write-string (derivation-path (store-path-drv linked))))
(newline))
(unless skip-if-not-bin
(write-string (string-append package-name "\tnot a binary\n")))))))
(if (eqv? args '())
(for-each
(lambda (package) (print-package-info package #t))
(find-packages-for-module module-name))
(for-each
(lambda (package) (print-package-info package #f))
args))

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

9
default.nix Normal file
View file

@ -0,0 +1,9 @@
with import <nixpkgs> { overlays = [ (import ./aux/overlay.nix) ]; };
pkgs.symlinkJoin {
name = "zilch-bin";
paths = [
(pkgs.callPackage ./cli {})
];
postBuild = "echo ${go_1_23} >> $out/.go";
}

4
docs/.gitignore vendored Normal file
View file

@ -0,0 +1,4 @@
/build
/node_modules
/modules/generated/pages/*
!/modules/generated/pages/.gitkeep

14
docs/antora-playbook.yml Normal file
View file

@ -0,0 +1,14 @@
site:
title: Zilch
start_page: zilch::index.adoc
content:
sources:
- url: ./..
start_path: docs
ui:
bundle:
url: https://gitlab.com/antora/antora-ui-default/-/jobs/artifacts/HEAD/raw/build/ui-bundle.zip?job=bundle-stable
snapshot: true
supplemental_files: ./supplemental

4
docs/antora.yml Normal file
View file

@ -0,0 +1,4 @@
name: zilch
version: '0.1'
nav:
- modules/ROOT/nav.adoc

10
docs/docread/default.nix Normal file
View file

@ -0,0 +1,10 @@
{ pkgs, eggDerivation, chickenPackages }:
eggDerivation {
name = "docread";
src = ./.;
buildInputs = with chickenPackages.chickenEggs; [
r7rs
(pkgs.callPackage ../../core {})
];
}

9
docs/docread/docread.egg Normal file
View file

@ -0,0 +1,9 @@
((version "0.0.1")
(synopsis "read doc comments")
(author "puck")
(dependencies r7rs zilch)
(component-options
(csc-options "-X" "r7rs" "-R" "r7rs" "-optimize-level" "3"))
(components
(program docread
(source "docread.scm"))))

88
docs/docread/docread.scm Normal file
View file

@ -0,0 +1,88 @@
(import (scheme base) (scheme file) (scheme write) (chicken read-syntax) (chicken process-context) (chicken irregex) (chicken format) (chicken process) (chicken file) (zilch zexpr))
;; Return a string version of the passed-in val, but properly quoted as s-expression.
(define (quotify val)
(call-with-port (open-output-string) (lambda (port) (write val port) (get-output-string port))))
;; Read a file, and rewrite all doc comments (comments starting with ";;") with comment s-expressions.
(define (read-file-with-rewritten-comments f)
(define port (open-input-file f))
(define str-out (open-output-string))
(write-string "(\n" str-out)
(do ((buf (string) (read-string 2048 port))) ((eof-object? buf) #f) (write-string buf str-out))
(close-input-port port)
(write-string "\n)" str-out)
(define comments-fixed
(irregex-replace/all
; Written weirdly to avoid the regexp catching itself.
; TODO(puck): only apply at the start of lines?
(string->irregex ";{2,} *([^\\n]*)" 'm)
(get-output-string str-out)
;; TODO: do we need the space here? this could also be a reader macro instead.
(lambda (m) (string-append " " (quotify (list 'comment (irregex-match-substring m 1)))))))
(call-with-port (open-input-string comments-fixed) (lambda (port) (read port))))
;; Iterate over the contents of a define-library, and collect comments on certain defines.
(define (parse-library-contents contents lib-comments)
(define comments '())
(define defines '())
(define imports '())
(define exports '())
(for-each (lambda (j)
(cond
;; Track imports and exports respectively.
((eq? (car j) 'import) (set! imports (append (cdr j) imports)))
((eq? (car j) 'export) (set! exports (append (cdr j) exports)))
((eq? (car j) 'begin)
; For each top-level object in the (begin) block...
(for-each (lambda (i)
(cond
; If we see a preprocessed comment, collect it
((and (list? i) (eq? (car i) 'comment)) (set! comments (cons (cadr i) comments)))
; If we then see either a define or a define-record-type, emit the comments.
((and (list? i) (or (eq? (car i) 'define) (eq? (car i) 'define-record-type)))
(if (list? (cadr i))
; TODO(puck): bad code
(set! defines (cons (cons (car (cadr i)) (cons (cadr i) (reverse comments))) defines))
(set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines)))
(set! comments '()))))
(cdr j)))))
contents)
(define out-path (string-append root "/docs/modules/generated/pages"))
(define first #t)
(for-each (lambda (l) (set! out-path (string-append out-path (if first "/" ".") (symbol->string l))) (set! first #f)) (car contents))
(set! out-path (string-append out-path ".adoc"))
(define out-file (open-output-file out-path))
; Print out the comments
(fprintf out-file "= `~S`\n" (car contents))
(for-each (lambda (l) (fprintf out-file "~A\n" l)) lib-comments)
(fprintf out-file "\n:toc:\n\n")
(for-each (lambda (i)
(define val (assoc i defines))
(unless (eq? val #f)
(fprintf out-file "== `+~S+`\n" (cadr val))
(for-each (lambda (l) (fprintf out-file "~A\n" l)) (cddr val))
(fprintf out-file "\n")))
exports)
(close-output-port out-file))
(define root (call-with-input-pipe "git rev-parse --show-toplevel" (lambda (p) (define path (read-string 9999999 p)) (string-copy path 0 (- (string-length path) 1)))))
(define (parse-file contents)
(define comments '())
(for-each (lambda (j)
(cond ((eq? (car j) 'define-library) (parse-library-contents (cdr j) (reverse comments)))
((eq? (car j) 'comment) (set! comments (cons (cadr j) comments))))) contents))
(define (process-file fname _)
(parse-file (read-file-with-rewritten-comments fname)))
(find-files root #:test ".*\\.(sld|scm)" #:action process-file)

32
docs/modules/ROOT/nav.adoc Normal file
View file

@ -0,0 +1,32 @@
* xref:index.adoc[]
* xref:nixexpr.adoc[]
* xref:zexp.adoc[]
* ++(zilch)++
** xref:generated:zilch.file.adoc[++(zilch file)++]
** xref:generated:zilch.magic.adoc[++(zilch magic)++]
** xref:generated:zilch.nixpkgs.adoc[++(zilch nixpkgs)++]
** xref:generated:zilch.statusbar.adoc[++(zilch statusbar)++]
** xref:generated:zilch.zexpr.adoc[++(zilch zexpr)++]
* ++(zilch lang go)++
** xref:generated:zilch.lang.go.adoc[++(zilch lang go)++]
** xref:generated:zilch.lang.go.core.adoc[++(zilch lang go core)++]
** xref:generated:zilch.lang.go.fetch.adoc[++(zilch lang go fetch)++]
** xref:generated:zilch.lang.go.mod.adoc[++(zilch lang go mod)++]
** xref:generated:zilch.lang.go.package.adoc[++(zilch lang go package)++]
** xref:generated:zilch.lang.go.stdlib.adoc[++(zilch lang go stdlib)++]
** xref:generated:zilch.lang.go.sum.adoc[++(zilch lang go sum)++]
** xref:generated:zilch.lang.go.version.adoc[++(zilch lang go version)++]
** xref:generated:zilch.lang.go.vfs.adoc[++(zilch lang go vfs)++]
* ++(zilch lib)++
** xref:generated:zilch.lib.getopt.adoc[++(zilch lib getopt)++]
** xref:generated:zilch.lib.hash.adoc[++(zilch lib hash)++]
** ++(zilch nix)++
*** xref:generated:zilch.nix.binproto.adoc[++(zilch nix binproto)++]
*** xref:generated:zilch.nix.daemon.adoc[++(zilch nix daemon)++]
*** xref:generated:zilch.nix.drv.adoc[++(zilch nix drv)++]
*** xref:generated:zilch.nix.hash.adoc[++(zilch nix hash)++]
*** xref:generated:zilch.nix.path.adoc[++(zilch nix path)++]
* xref:architecture.adoc[]

11
docs/modules/ROOT/pages/architecture.adoc Normal file
View file

@ -0,0 +1,11 @@
= Architecture
`(zilch nix binproto)` contains an implementation of the binary protocol used both
to talk to the daemon and to build NAR files.
On top of that is `(zilch nix daemon)`, which implements a version (which?) of
the Nix worker protocol.
`(zilch nix drv)` allows reading and writing .drv objects.
`(zilch nix path)` contains the helpers for building store paths of various types.

22
docs/modules/ROOT/pages/index.adoc Normal file
View file

@ -0,0 +1,22 @@
= Introduction
Zilch is an experimental testbed for implementing reproducible compilation
technologies, based on Nix, but steering clear of most of the parts of Nix
built on top of the derivation concept.
Like Guix, it is built on top of Scheme. However, unlike Guix, it does not
require a second, incompatible Nix-like daemon to be installed.
Features:
* Solid, reusable, Nix daemon protocol core
* Batteries included
* Intercompatible with Nixpkgs and other, arbitrary, Nix expressions.
== Current work
Current effort in Zilch is working on making "incremental", bitesize,
derivations to work. This is currently being implemented for Go.
== Contributing
Come join [.line-through]#us# me at `#zilch` on https://libera.chat[libera.chat]!

41
docs/modules/ROOT/pages/nixexpr.adoc Normal file
View file

@ -0,0 +1,41 @@
= Nix expression support
When `(nix reader)` is imported, it is possible to execute Nix code inline with
Scheme code. Simply wrap your Nix code in curly brackets:
[,scheme]
----
(write
(string-append
"Hello, Nix version"
{ builtins.nixVersion }))
----
The following values can be translated:
|===
| Nix | Scheme | Notes
| string | string | (Loses string context.)
| integer | number |
| float | number |
| boolean | boolean |
| lambda | procedure | (with single argument)
| list | vector or list | Depends on the status of `\*translate-list-as-vector*`
| attrset | alist |
| builtin | procedure |
| external value | symbol, other unknown objects |
|===
If a value in Nix is preceded with a comma, it is unquoted, similar to
`(unquote)` in a Scheme quasiquotation. If prefixed with a single quote, it is
`(quote)`-d.
[,scheme]
----
(define
(test-append foo)
(string-append "Hello, " foo))
(write
{ ,test-append "world!") })
----

28
docs/modules/ROOT/pages/zexp.adoc Normal file
View file

@ -0,0 +1,28 @@
= zexps
zexps, similar to g-expressions in Guix, are a way to generate
S-expressions that are taggged with store paths. But that's where
the similarity ends.
To create a zexp, you can use either the full syntax, or the reader macro:
[,scheme]
----
#~(foo bar #$baz)
; is identical to:
(zexp (foo bar (zexp-unquote baz)))
----
`(zexp-unquote VAL)` returns the value that the zexp (or any compatible record)
contains, while gathering the `zexp-unquote`d values used.
Like quasiquotation, zexps can use `unquote`, including ``zexp-unquote``d values
inside the ``unquote``d code. ``unquote``d code is evaluated when the `zexp` is evaluated.
[,scheme]
----
(define world #~,(begin (write "hello") "world"))
(define hello #~("hello" ,(string-append "very " "cute") #$world))
; When hello is used as zexp, it will also write "hello" to the output port.
----

1436
docs/package-lock.json generated Normal file
View file

File diff suppressed because it is too large Load diff

6
docs/package.json Normal file
View file

@ -0,0 +1,6 @@
{
"dependencies": {
"@antora/cli": "^3.1.9",
"@antora/site-generator": "^3.1.9"
}
}

1
docs/supplemental/js/vendor/highlight.js vendored Normal file
View file

File diff suppressed because one or more lines are too long

17
docs/supplemental/partials/header-content.hbs Normal file
View file

@ -0,0 +1,17 @@
<header class="header">
<nav class="navbar">
<div class="navbar-brand">
<div class="navbar-item">
zilch
</div>
<button class="navbar-burger" data-target="topbar-nav">
<span></span>
<span></span>
<span></span>
</button>
</div>
<div id="topbar-nav" class="navbar-menu">
</div>
</nav>
</header>

10
docs/supplemental/partials/toolbar.hbs Normal file
View file

@ -0,0 +1,10 @@
<div class="toolbar" role="navigation">
{{> nav-toggle}}
{{#with site.homeUrl}}
<a href="{{{relativize this}}}" class="home-link{{#if @root.page.home}} is-current{{/if}}"></a>
{{/with}}
{{> breadcrumbs}}
{{> page-versions}}
</div>

22
lang/go/default.nix Normal file
View file

@ -0,0 +1,22 @@
{ chickenPackages, libsodium, callPackage, xxd }:
(callPackage ../../lib/build-chicken-parallel {}) {
name = "zilch-lang-go";
src = ./.;
buildInputs = with chickenPackages.chickenEggs; [
chickenPackages.chicken
r7rs
json
srfi-152
srfi-207
(callPackage ../../core {})
xxd
];
overrides.preBuild = ''
(cat utils/parser/main.go; printf '\0') | xxd -i -n parser_source > parser_source.h
(cat utils/dirhash/main.go; printf '\0') | xxd -i -n dirhash_source > dirhash_source.h
(cat utils/unzip-one/main.go; printf '\0') | xxd -i -n unzip_one_source > unzip_one_source.h
'';
}

153
lang/go/src/core.sld Normal file
View file

@ -0,0 +1,153 @@
(define-library (zilch lang go core)
(import
(scheme base) (scheme write) (scheme process-context) (scheme lazy)
(zilch file) (zilch magic) (zilch nix drv) (zilch nix path)
(zilch nixpkgs) (zilch zexpr)
json
(chicken foreign)
(srfi 4))
(export
build-importcfg
build-embedcfg
rewrite-package-name
%goarch
env-for-goarch
defines-for-goarch
go-compile
go-generate-symabi
go-compile-assembly
go-toolchain)
(begin
(define %goarch (make-parameter "amd64"))
; Import the existing Go from nixpkgs.
(define go-toolchain (cdr (assoc "out" (nixpkgs "go_1_23"))))
;; Builds an importcfg file, containing an alist of packages to .a files,
;; and an alist of package names to actual package names.
;; `++packagefiles++` is a alist of package name to .a file (api type),
;; `++importmap++` is an alist of package name to actual package name (used in cases of e.g. replace)
(define (build-importcfg packagefiles importmap)
(call-with-port (open-output-string)
(lambda (outstr)
(write-string "# import config\n" outstr)
(for-each
(lambda (v)
(write-string "packagefile " outstr)
(write-string (car v) outstr)
(write-char #\= outstr)
(write-string (cdr v) outstr)
(write-char #\newline outstr))
packagefiles)
(for-each
(lambda (v)
(write-string "importmap " outstr)
(write-string (car v) outstr)
(write-char #\= outstr)
(write-string (cdr v) outstr)
(write-char #\newline outstr))
importmap)
(get-output-string outstr))))
;; `++patterns++` is an alist of the pattern used to match files (e.g. `++foo/++`, or `++a.*++`) to a list of filenames.
;; `++files++` is an alist of file name to actual path.
(define (build-embedcfg patterns files)
(call-with-port (open-output-string)
(lambda (outstr)
(json-write
(vector
(cons "Patterns" (list->vector patterns))
(cons "Files" (list->vector files)))
outstr)
(get-output-string outstr))))
; Clean up the package name to use in drv names.
(define (rewrite-package-name name)
(set! name (string-copy name))
(do ((x 0 (+ x 1)))
((>= x (string-length name)) name)
(when (char=? (string-ref name x) #\/) (string-set! name x #\_))
(when (char=? (string-ref name x) #\[) (string-set! name x #\_))
(when (char=? (string-ref name x) #\space) (string-set! name x #\_))
(when (char=? (string-ref name x) #\]) (string-set! name x #\_))))
;; An empty go_asm.h file used to generate symabis.
(define empty-asmhdr (zdir `(("go_asm.h" . ,(zfile "")))))
;; Environment to append to the build environment for Go.
(define (env-for-goarch)
`(("GOARCH" . ,(%goarch))))
;; Extra defines to add to `++go tool asm++` uses.
(define (defines-for-goarch)
`(
"-D" "GOOS_linux"
"-D" ,(string-append "GOARCH_" (%goarch))
,@(if (string=? (%goarch) "amd64") '("-D" "GOAMD64_v1") '())))
;; Returns an alist of three store paths; `++api++` containing the compiler's output,
;; `++code++` containing the linkobj, and `++asmhdr++` containing the headers needed for assembly
;; code to properly use Go functions and variables.
(define (go-compile std package-name importcfg symabis embeds files)
(define args
#~(
,@(if std '("-std") '())
#$@(if symabis `("-symabis" ,#$symabis) '())
#$@(if embeds `("-embedcfg" ,#$embeds) '())
"-buildid" "zilch go-compile" ; this goes into both code and __.PKGDEF, so can't be a reference to the code output, sadly
"-p" #$package-name
"-o" ,(make-placeholder "api")
"-linkobj" ,(make-placeholder "code")
"-importcfg" #$importcfg
"-nolocalimports"
"-asmhdr" ,(make-placeholder "asmhdr")
"-trimpath" ,(apply string-append (map (lambda (f) (string-append (cdr f) "=>" package-name "/" (car f) ";")) #$files))
. ,(map cdr #$files)))
(store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-src")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "compile" . #$args)
(env-for-goarch) '("api" "code" "asmhdr")))
;; Returns a store path containing the symabi for the files provided.
(define (go-generate-symabi package-name include-path files)
(define args
#~(
,@(defines-for-goarch)
"-gensymabis"
"-p" #$package-name
"-o" ,(make-placeholder "symabi")
"-I" ,(string-append #$go-toolchain "/share/go/pkg/include")
"-I" #$empty-asmhdr
,@(if include-path (list "-I" #$include-path) '())
. #$files))
(cdar (store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-asm-symabis")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "asm" . #$args)
(env-for-goarch) '("symabi"))))
;; Returns a store path containing the `++code++` of the provided assembly files.
(define (go-compile-assembly package-name include-path include-path2 files)
(define args
#~(
,@(defines-for-goarch)
"-p" #$package-name
"-o" ,(make-placeholder "code")
"-I" ,(string-append #$go-toolchain "/share/go/pkg/include")
,@(if include-path (list "-I" #$include-path) '())
,@(if include-path2 (list "-I" #$include-path2) '())
"-trimpath" ,(apply string-append (map (lambda (f) (string-append (cdr f) "=>" package-name "/" (car f) ";")) #$files))
. ,(map cdr #$files)))
(cdar (store-path-for-ca-drv*
(string-append (rewrite-package-name package-name) "-asm")
"x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "asm" . #$args)
(env-for-goarch) '("code"))))))

33
lang/go/src/fetch.sld Normal file
View file

@ -0,0 +1,33 @@
(define-library (zilch lang go fetch)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme char)
(zilch magic) (zilch zexpr)
(zilch nixpkgs)
(chicken format))
(export
fetch-with-known-url rewrite-module-name-for-url)
(begin
(define fetch-cache (call-with-input-file "/home/.zilchcache" read))
(define (fetch-with-known-url name url)
(define cache-entry (assoc url fetch-cache))
(define hash (if cache-entry
(cdr cache-entry)
(begin (printf "..fetching ~S ~S\n" name url)
(nix-prefetch-url name url #f))))
(unless cache-entry
(set! fetch-cache (cons (cons url hash) fetch-cache))
(call-with-output-file "/home/.zilchcache" (lambda (out) (write fetch-cache out))))
(store-path-for-fod name "builtin" '("builtin:fetchurl") `(("url" . ,url) ("outputHashMode" . "flat")) "sha256" hash #f))
(define (rewrite-module-name-for-url name)
(define out "")
(string-for-each
(lambda (ch)
(if
(char-upper-case? ch)
(set! out (string-append out (string #\! (char-downcase ch))))
(set! out (string-append out (string ch)))))
name)
out)))

124
lang/go/src/go.sld Normal file
View file

@ -0,0 +1,124 @@
(define-library (zilch lang go)
(import
(scheme base) (scheme write) (scheme process-context) (scheme lazy)
(chicken file) (chicken format)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(srfi-4)
(zilch lang go core))
(export
make-go-package go-package?
go-package-name go-package-import-path
go-package-api go-package-code go-package-dependencies
go-dependency-closure
go-package-compile go-package-link)
(begin
;; A go package consists of a few separate `++(zilch magic)++` store paths.
;; The `++name++` is the package name as compiled, and `++import-path++` is a nicer
;; package name for "main" packages. The `++go-package-api++` is a store path consisting
;; of a `++.a++` containing the output of the compiler's `++__.PKGDEF++` only, which
;; contains the exported types and functions, along with a slight amount of LTO and
;; inlining metadata. the `++go-package-code++` store path contains the actual assembly
;; of the package.
(define-record-type <go-package>
(make-go-package name import-path api code dependencies)
go-package?
(name go-package-name)
(import-path go-package-import-path)
(api go-package-api)
(code go-package-code)
(dependencies go-package-dependencies))
(define-record-printer (<go-package> pkg out)
(fprintf out "#<go-package ~A api: ~S code: ~S deps: ~S>"
(if (string=? (go-package-import-path pkg) (go-package-name pkg))
(go-package-name pkg)
(string-append (go-package-name pkg) " (" (go-package-import-path pkg) ")"))
(go-package-api pkg)
(go-package-code pkg)
(map go-package-name (go-package-dependencies pkg))))
;; Recursively walk over the dependencies of a `++go-package++`, prepending to the `++vals++` list.
(define (go-dependency-closure package vals)
(unless (member package vals)
(set! vals (cons package vals))
(for-each
(lambda (pkg)
(set! vals (go-dependency-closure pkg vals)))
(go-package-dependencies package)))
vals)
;; `(go-package-compile name deps source-files)`
;; or `(go-package-compile name path deps source-files assembly-files assembly-includes embed-filenames embed-patterns)`
;; Build a Zilch-defined Go package of one store path as source code, and a list of dependencies.
(define go-package-compile
(case-lambda
((name deps source-files) (go-package-compile name name deps source-files '() '() '() '()))
((name path deps source-files assembly-files assembly-includes embed-filenames embed-patterns)
(define api-importcfg
(zfile #~,(build-importcfg #$(map (lambda (pkg) (cons (go-package-import-path pkg) (go-package-api pkg))) deps) '())))
(define api-embedcfg
(zfile #~,(build-embedcfg #$embed-patterns #$embed-filenames)))
(define symabis #f)
(unless assembly-files (set! assembly-files '()))
(define path-or-name (if (string=? name "main") name path))
(define assembly-includes-dir
(if (list? assembly-includes)
(zdir (map (lambda (pair) (cons (car pair) (zsymlink (cdr pair)))) assembly-includes))
assembly-includes))
(unless (eq? assembly-files '())
(set! symabis (go-generate-symabi path-or-name assembly-includes-dir #~,(map cdr #$assembly-files))))
(define compiled-go
(go-compile #f path-or-name api-importcfg symabis api-embedcfg source-files))
(define merged-asmhdr
(zdir "go_asm.h" (zsymlink (cdr (assoc "asmhdr" compiled-go)))))
;; ISSUE: this needs the source dir for assembly imports reasons (filter out .h files?)
(define compiled-assembly
(map
(lambda (f) (go-compile-assembly path-or-name assembly-includes-dir merged-asmhdr (list f)))
assembly-files))
; Assembly code doesn't have an API, so use the Go code's API only.
(define go-api (cdr (assoc "api" compiled-go)))
; Make a list of the "code" output from the Go with the compiled assembly files.
; NOTE: .go has to be compiled in one go; but .s is compiled one file at a time.
(define all-code (cons (cdr (assoc "code" compiled-go)) compiled-assembly))
; (printf " -> (store-path-for-ca-drv* meow meow ~S ~S meow)\n" all-code (env-for-goarch))
; Use `go tool pack` to merge the code together.
(define merged-code
(if (length assembly-files)
(cdar (store-path-for-ca-drv*
(string-append "go-" (rewrite-package-name path) "-code") "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "pack" "c" ,(make-placeholder "code") . #$all-code)
(env-for-goarch)
'("code")))
(cdr (assoc "code" compiled-go))))
; (printf " -> (make-go-package ~S ~S ~S ~S ~S)\n" name path (cdr (assoc "api" compiled-go)) merged-code deps)
(make-go-package name path (cdr (assoc "api" compiled-go)) merged-code deps))))
;; Link a `++go-package++` into a binary that can be (statically) executed.
(define (go-package-link pkg)
(define code-importcfg
(zfile #~,(build-importcfg #$(map (lambda (pkg) (cons (go-package-import-path pkg) (go-package-code pkg))) (go-dependency-closure pkg '())) '())))
(cdar (store-path-for-ca-drv* (rewrite-package-name (go-package-import-path pkg)) "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "link" "-buildid" ,(string-append "zilch out=" (make-placeholder "out")) "-importcfg" #$code-importcfg "-o" ,(make-placeholder "out") #$(go-package-code pkg)) (env-for-goarch) '("out"))))))

230
lang/go/src/mod.sld Normal file
View file

@ -0,0 +1,230 @@
;; Processes go modules.
(define-library (zilch lang go mod)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 132) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
(zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go vfs) (zilch lang go sum) (zilch lang go fetch) (zilch lang go package)
(zilch lang go version)
(chicken foreign))
(export
collect-requirements-for-module collect-packages-from-requires)
(begin
(define (is-builtin str)
(not (string-index str (lambda (ch) (char=? ch #\.)))))
(define (filter proc lis)
(cond
((eq? lis '()) lis)
((proc (car lis))
(cons (car lis) (filter proc (cdr lis))))
(else (filter proc (cdr lis)))))
;; Read a go.mod file. This returns a processed json object, like `go mod edit -json` outputs by default.
(define (read-go-mod mod-file)
(call-with-port
;; TODO(puck): don't use /bin/sh here.
(store-path-open (cdar (store-path-for-ca-drv* "go.mod.json" "x86_64-linux" #~("/bin/sh" "-c" ,(string-append #$go-toolchain "/bin/go mod edit -json " #$mod-file " > $out")) '() '("out"))))
(lambda (p) (json-read p))))
(define (vector-get-kv-value key vec)
(vector-any (lambda (v) (and (string=? (car v) key) (cdr v))) vec))
;; Reads in the module rooted by the vfs, and resolves its requirements list.
;; This returns two values: the name of the root module, and a mapping of module name to a pair of its version and the vfs.
(define (collect-requirements-for-module vfs replaces)
(define sum-lines '())
(define (parse-sumfile go-sum)
(vector-for-each
(lambda (line)
(define loc (assoc (go-sum-module line) sum-lines))
(unless (go-sum-path line)
(unless loc
(set! sum-lines (cons (list (go-sum-module line)) sum-lines))
(set! loc (car sum-lines)))
(unless (assoc (go-sum-version line) (cdr loc))
(set-cdr! loc (cons (cons (go-sum-version line) (delay (vfs-from-dirhash line))) (cdr loc))))))
go-sum))
(define (add-modules-from-sum nvfs dir)
(define sumfile (vector-get-kv-value "go.sum" (vector-get-kv-value dir nvfs)))
(when sumfile
(parse-sumfile (call-with-port (store-path-open sumfile) parse-go-sum-file))))
(define collected-requires (mapping (make-default-comparator)))
(fprintf (current-error-port) "Collecting required modules\n")
(define (find-requires-from-mod vfs dir)
(define modfile (vector-get-kv-value "go.mod" (vector-get-kv-value dir vfs)))
(define pathname #f)
(when modfile
(let*
((go-mod (read-go-mod modfile))
(module-obj (vector-get-kv-value "Module" go-mod))
(path (vector-get-kv-value "Path" module-obj))
(require-data (vector-get-kv-value "Require" go-mod))
(require-list (if (list? require-data) require-data '())))
(fprintf (current-error-port) "- found ~S (requires ~S modules)\n" path (length require-list))
(for-each
(lambda (req)
(define require-path (vector-get-kv-value "Path" req))
(define require-version (vector-get-kv-value "Version" req))
(define dep (mapping-ref/default collected-requires require-path #f))
(unless dep (set! dep (cons require-version #f))
(set! collected-requires (mapping-set! collected-requires require-path dep)))
(when (and (car dep) (version<? (car dep) require-version))
(set-car! dep require-version)
(set-cdr! dep #f)))
require-list)
(set! pathname path)))
pathname)
(define root-path-name #f)
(define (handle-vfs nvfs)
(add-modules-from-sum nvfs "/")
(find-requires-from-mod nvfs "/"))
(for-each
(lambda (vfs)
(define path-name (handle-vfs vfs))
(set! collected-requires (mapping-set! collected-requires path-name (cons #f vfs))))
replaces)
; we have the right module versions and their files now. Iterate over the packages we have,
; until we have none left that need iterating. Once that's done, iterate all the packages and fetch the go.sum for them.
(define (tick)
(define found-valid #f)
(define found-missing '())
(define-values (keys values) (mapping-entries collected-requires))
(for-each
(lambda (key value)
(unless (cdr value)
(let* ((module-data (assoc key sum-lines))
(vfs-for-version (and module-data (assoc (car value) (cdr module-data)))))
(if vfs-for-version
(begin
(handle-vfs (force (cdr vfs-for-version)))
(set-cdr! value (force (cdr vfs-for-version)))
(set! found-valid #t))
(begin
(set! found-missing (cons (cons key (car value)) found-missing)))))))
keys values)
(cond
((and found-valid (not (eqv? found-missing '())))
(tick))
((and found-valid (eqv? found-missing '()))
(tick))
((and (not found-valid) (eqv? found-missing '()))
#f)
((and (not found-valid) (not (eqv? found-missing '())))
(for-each
(lambda (pair)
(fprintf (current-error-port) " (fetching go.sum from sumdb for ~S ~S)\n" (car pair) (cdr pair))
(let ((file (fetch-with-known-url "go.sum" (string-append "https://sum.golang.org/lookup/" (rewrite-module-name-for-url (car pair)) "@" (cdr pair)))))
(call-with-port (store-path-open file) (lambda (port) (read-line port) (parse-sumfile (vector (parse-go-sum-line (read-line port)) (parse-go-sum-line (read-line port))))))))
found-missing)
(tick))))
(set! root-path-name (handle-vfs vfs))
(set! collected-requires (mapping-set! collected-requires root-path-name (cons #f vfs)))
(tick)
(values root-path-name collected-requires))
;; Processes a mapping of module name to a pair of version and vfs, and returns a procedure that takes a package name and returns its go-package.
(define (collect-packages-from-requires collected-requires)
(define (process-package vfs last-part full-path pairs headers)
(define name (cdr (assoc "name" pairs)))
(define go-files (cdr (assoc "goFiles" pairs)))
(define s-files (if (and (assoc "sFiles" pairs) (list? (cdr (assoc "sFiles" pairs)))) (cdr (assoc "sFiles" pairs)) '()))
(define imports (cdr (assoc "imports" pairs)))
; format: ((pattern . (fname file dir)))
(define embed-vectors (cdr (assoc "embeds" pairs)))
(define embeds (if (vector? embed-vectors) (vector->list embed-vectors) '()))
(define embed-filenames '())
(define embed-patterns (map (lambda (pattern) (cons (car pattern) (if (list? (cdr pattern)) (map car (cdr pattern)) '()))) embeds))
(for-each
(lambda (pattern)
(when (list? pattern)
(for-each
(lambda (fname)
(define new-fname (cadr fname))
(if (string=? "//" new-fname) (set! new-fname "/"))
(define dir (vector-get-kv-value new-fname vfs))
(define file-obj (vector-get-kv-value (car (cddr fname)) dir))
(unless (assoc (car fname) embed-filenames) (set! embed-filenames (cons (cons (car fname) file-obj) embed-filenames))))
(cdr pattern))))
embeds)
(define vfsdir (vector-get-kv-value last-part vfs))
(let
((collected-files (map (lambda (name) (cons name (vector-get-kv-value name vfsdir))) go-files))
(collected-assembly-files (map (lambda (name) (cons name (vector-get-kv-value name vfsdir))) s-files))
(collected-assembly-includes (if (= (length s-files) 0) '() #~,(string-append #$(force headers) last-part)))
(collected-imports (map (lambda (name) (if (is-builtin name) (go-stdlib-ref name) (find-package name)))
(filter (lambda (name) (not (member name '("builtin" "unsafe")))) imports))))
(go-package-compile name full-path collected-imports collected-files collected-assembly-files collected-assembly-includes embed-filenames embed-patterns)))
(define packages (mapping (make-default-comparator)))
(define (process-packages-for-module root-path vfs)
(define (dir-has-valid-contents contents)
(vector-any
(lambda (entry)
(or
(eq? (car entry) "go.mod")
(string-suffix? ".go" (car entry))))
contents))
(define module-packages
(find-packages-inside-vfs
(vector-map
(lambda (pair)
(cons
(car pair)
(if (dir-has-valid-contents (cdr pair))
(cdr pair)
(vector-map (lambda (pair) (cons (car pair) "/dev/null")) (cdr pair)))))
vfs)))
(define headers (delay (vfs-to-store (filter-vfs vfs (lambda (dir fname) (string-suffix? ".h" fname))))))
(vector-for-each
(lambda (pair)
(define full-path (string-append root-path (car pair)))
(set! full-path (string-copy full-path 0 (- (string-length full-path) 1)))
(define pairs (vector->list (cdr pair)))
(set! packages (mapping-set! packages full-path (delay (process-package vfs (car pair) full-path pairs headers)))))
module-packages))
(define (find-longest-prefix name)
(define prefixes (mapping-entries (mapping-filter (lambda (key value) (string-prefix? key name)) collected-requires)))
(unless (eq? prefixes '())
(set! prefixes (list-sort! (lambda (left right) (> (string-length left) (string-length right))) prefixes)))
(if (eq? prefixes '())
#f
(car prefixes)))
(define (find-package full-path)
(define package (mapping-ref/default packages full-path #f))
(unless package
(let ((module-key (find-longest-prefix full-path)))
(when module-key
(process-packages-for-module module-key (cdr (mapping-ref/default collected-requires module-key #f)))
(set! package (mapping-ref/default packages full-path #f)))))
(unless package
(error (string-append "Could not find package " full-path)))
(force package))
(define (find-packages-for-module pkg)
(define modules (mapping-filter (lambda (k v) (string-prefix? pkg k)) packages))
(when (= (mapping-size modules) 0)
(let ((module-key (find-longest-prefix pkg)))
(when module-key
(process-packages-for-module module-key (cdr (mapping-ref/default collected-requires module-key #f)))))
(set! modules (mapping-filter (lambda (k v) (string-prefix? pkg k)) packages)))
(mapping-keys modules))
(values find-package find-packages-for-module))))

30
lang/go/src/package.sld Normal file
View file

@ -0,0 +1,30 @@
(define-library (zilch lang go package)
(import
(scheme base)
(zilch file) (zilch magic)
(zilch nixpkgs) (zilch zexpr)
json
(chicken foreign)
(zilch lang go core) (zilch lang go) (zilch lang go vfs) (zilch lang go stdlib))
(export find-packages-inside-vfs)
(begin
(foreign-declare "#include \"parser_source.h\"")
(define go-import-parser
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("encoding/json" "fmt" "go/build" "io" "io/fs" "os" "path" "path/filepath" "sort" "strings" "time"))
(list (cons "main.go" (zfile (foreign-value "parser_source" nonnull-c-string)))))))
(define (find-packages-inside-vfs vfs)
(define input
#~,(call-with-port
(open-output-bytevector)
(lambda (bv)
(json-write (vector (cons "GOARCH" (%goarch)) (cons "GOOS" "linux") (cons "files" #$(filter-vfs-for-package-reading vfs))) bv)
(get-output-bytevector bv))))
(define input-file (zfile input))
(define store-path (cdar (store-path-for-ca-drv* "find-packages" "x86_64-linux" #~(#$go-import-parser #$input-file) '() '("out"))))
(call-with-port (store-path-open store-path)
(lambda (p) (json-read p))))))

159
lang/go/src/stdlib.sld Normal file
View file

@ -0,0 +1,159 @@
(define-library (zilch lang go stdlib)
(import
(scheme base) (scheme file) (scheme write) (scheme process-context) (scheme lazy)
(chicken file) (chicken format)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken foreign)
(srfi-4)
(zilch lang go core)
(zilch lang go))
(export
go-stdlib-ref)
(begin
;; Helper to read JSON objects until EOF.
(define (read-all-objects port out)
(if (eof-object? (peek-char port))
out
(read-all-objects port (cons (json-read port) out))))
;; Runs `++go list++` (thru `++/bin/sh++`) and reads (IFD) the output to fetch the metadata of the Go standard library and commands.
(define stdlib-objects
(map vector->list
(call-with-port
(store-path-open
(cdar (store-path-for-ca-drv*
"stdenv"
"x86_64-linux"
#~("/bin/sh" "-c" ,(string-append "GOCACHE=$TMPDIR/go-cache " #$go-toolchain "/bin/go list -json -deps std cmd > $out"))
(env-for-goarch) '("out"))))
(lambda (port) (read-all-objects port '())))))
(define (assoc-or-empty name obj)
(define res (assoc name obj))
(if res (cdr res) '()))
;; Extract everything until the first space.
;; Space characters are illegal in Go package names, and `++go list -json std++`
;; uses it to disambiguate multiple versions of some internal packages.
(define (strip-space-bits name)
(do
((x 0 (+ 1 x)))
((or
(>= x (string-length name))
(char=? (string-ref name x) #\space))
(if (>= x (string-length name))
name
(substring name 0 x)))))
;; Tail-recursively remove any packages that, if ignoring the postfixed origin
;; (e.g. `++unsafe [cmd/compile]++`), match either `++unsafe++` or `++builtin++`;
;; these have no source code and are compiler-internal.
(define (remove-builtin-packages pkgs)
(if (eq? pkgs '())
'()
(let ((stripped (strip-space-bits (car pkgs))))
(if (or (string=? stripped "unsafe") (string=? stripped "builtin"))
(remove-builtin-packages (cdr pkgs))
(cons (car pkgs) (remove-builtin-packages (cdr pkgs)))))))
(define (starts-with left right)
(and
(>= (string-length right) (string-length left))
(string=? left (string-copy right 0 (string-length left)))))
(define (filter condition lst)
(if (eq? lst '())
'()
(if (condition (car lst))
(cons (car lst) (filter condition (cdr lst)))
(filter condition (cdr lst)))))
;; Helper that parses the JSON returned by `++go list -json -deps++` and builds a `++go-package++` record.
;; This is distinct from `go-package-compile` because of format differences,
(define (make-stdlib-inner meta)
(define files (assoc-or-empty "GoFiles" meta)) ; .go files
(define sfiles (assoc-or-empty "SFiles" meta)) ; .s files
(define imports (assoc-or-empty "Imports" meta)) ; imports (denormalised)
(define importmap (assoc-or-empty "ImportMap" meta)) ; import map
; Rewrite the import map to be normalised; we use the normalised import path later on.
(when (vector? importmap)
(set! importmap (map (lambda (v) (cons (car v) (strip-space-bits (cdr v)))) (vector->list importmap))))
(define import-path (cdr (assoc "ImportPath" meta)))
(define package-name (cdr (assoc "Name" meta)))
(define name (strip-space-bits import-path))
; Deal with commands properly. (Their package name is "main", but we track import path in other cases)
(when (string=? package-name "main")
(set! name package-name))
(define dir (cdr (assoc "Dir" meta)))
; Fetch dependencies from the rest of the stdlib data.
; We only need the `++api++` at this point.
(define resolved-imports (map (lambda (v) (cons (strip-space-bits v) (go-package-api (go-stdlib-ref v)))) (remove-builtin-packages imports)))
; The importcfg encodes the list of (direct) dependencies. Generate this from the "Imports" entry in the `go list -json` output.
; This uses a workaround for fetchurl behavior having been changed.
(define importcfg (zfile #~,(build-importcfg #$resolved-imports importmap)))
; If this package uses embeds, process them.
(define embed-patterns (assoc-or-empty "EmbedPatterns" meta))
(define embed-files (assoc-or-empty "EmbedFiles" meta))
; alist of (<embed pattern>. values)
(define embedprocessed (map (lambda (l) (cons (strip-space-bits l) (map strip-space-bits (filter (lambda (v) (starts-with l v)) embed-files)))) embed-patterns))
(define embeds #f)
(unless (eq? embed-files '())
(set! embeds
(zfile #~,(build-embedcfg embedprocessed (map (lambda (k) (cons k (string-append dir "/" k))) embed-files)))))
; When compiling assembly code, we first need to generate the symabi; then compile the Go code using that,
; and use the go_asm.h output from the Go compilation to compile the rest of the assembly.
(define symabis #f)
(unless (eq? sfiles '())
(set! symabis (go-generate-symabi name dir (map (lambda (f) (string-append dir "/" f)) sfiles))))
; Compile the go code. Currently done in one single go, rather than per-file; this is a TODO.
(define compiled-go (go-compile #t name importcfg symabis embeds (map (lambda (f) (cons f (string-append dir "/" f))) files)))
(define asmhdrs (cdr (assoc "asmhdr" compiled-go)))
; Move the asmhdr output to the right path for the assembly.
; TODO: use zfile logic, once this works again.
(define merged-asmhdr
(zdir "go_asm.h" (zsymlink asmhdrs)))
; Now compile every assembly file, in order.
(define compiled-assembly
(map
(lambda (f) (go-compile-assembly name dir merged-asmhdr (list (cons f (string-append dir "/" f)))))
sfiles))
; Assembly code doesn't have an API, so use the Go code's API only.
(define go-api (cdr (assoc "api" compiled-go)))
; Make a list of the "code" output from the Go with the compiled assembly files.
; NOTE: .go has to be compiled in one go; but .s is compiled one file at a time.
(define all-code (cons (cdr (assoc "code" compiled-go)) compiled-assembly))
; Use `go tool pack` to merge the code together.
(define merged-code
(cdar
(store-path-for-ca-drv*
(string-append "go-" (rewrite-package-name name) "-code") "x86_64-linux"
#~(,(string-append #$go-toolchain "/bin/go") "tool" "pack" "c" ,(make-placeholder "code") . #$all-code)
(env-for-goarch)
'("code"))))
(make-go-package name import-path go-api merged-code (map go-stdlib-ref (remove-builtin-packages imports))))
; Each entry is a list (name metadata (api code)).
; Use `++delay++` to resolve the DAG lazily on use.
(define stdlib-data (map (lambda (v) (list (cdr (assoc "ImportPath" v)) v (delay (make-stdlib-inner v)))) stdlib-objects))
;; Wrapper that forces evaluation of the promise fetching from a Go stdlib entry.
(define (go-stdlib-ref name)
(define entry (assoc name stdlib-data))
(unless entry (error (string-append "Could not find package " name " in stdlib")))
(force (list-ref entry 2)))))

60
lang/go/src/sum.sld Normal file
View file

@ -0,0 +1,60 @@
(define-library (zilch lang go sum)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 146) (srfi 207)
(chicken foreign))
(export
parse-go-sum-line parse-go-sum-file go-sum-line? go-sum-module go-sum-version go-sum-path go-sum-hash)
(begin
(define-record-type <go-sum-line>
(make-go-sum-line module version path hash)
go-sum-line?
(module go-sum-module)
(version go-sum-version)
(path go-sum-path)
(hash go-sum-hash))
(define-record-printer (<go-sum-line> sum out)
(fprintf out "#<go-sum ~A ~A~A h1:~A>"
(go-sum-module sum)
(go-sum-version sum)
(if (go-sum-path sum) (go-sum-path sum) "")
(bytevector->base64 (go-sum-hash sum))))
(define (string-find str index char)
(cond
((= index (string-length str)) #f)
((char=? (string-ref str index) char) index)
(else (string-find str (+ index 1) char))))
(define (parse-go-sum-line line)
(define version-space-index (string-find line 0 #\space))
(unless version-space-index (error "go.sum line contains no space characters"))
(define hash-space-index (string-find line (+ version-space-index 1) #\space))
(unless hash-space-index (error "go.sum line contains only one space character"))
(when (string-find line (+ hash-space-index 1) #\space) (error "go.sum line contains too many space characters"))
(define module-path (string-copy line 0 version-space-index))
(define version (string-copy line (+ version-space-index 1) hash-space-index))
(define hash (string-copy line (+ hash-space-index 1)))
(unless (string=? (string-copy hash 0 3) "h1:") (error "go.sum line has invalid algorithm for hash" hash))
(define path #f)
(define path-index (string-find version 0 #\/))
(when path-index
(set! path (string-copy version path-index))
(set! version (string-copy version 0 path-index)))
(make-go-sum-line module-path version path (base64->bytevector (string-copy hash 3))))
(define (parse-go-sum-file port)
(do ((parsed '())
(line "" (read-line port)))
((eof-object? line) (list->vector (reverse parsed)))
(unless (string=? line "") (set! parsed (cons (parse-go-sum-line line) parsed)))))))

46
lang/go/src/version.sld Normal file
View file

@ -0,0 +1,46 @@
(define-library (zilch lang go version)
(import
(scheme base) (srfi 152))
(export parse-version version<?)
(begin
(define (parse-version vstr)
(unless (char=? (string-ref vstr 0) #\v) (error "not a valid version" vstr))
(define first-period (string-index vstr (lambda (ch) (char=? ch #\.)) 1))
(define second-period (string-index vstr (lambda (ch) (char=? ch #\.)) (+ 1 first-period)))
(define prerelease-dash (string-index vstr (lambda (ch) (char=? ch #\-)) (+ 1 second-period)))
(define build-dash (string-index vstr (lambda (ch) (char=? ch #\+)) (+ 1 (or prerelease-dash second-period))))
(define major (string->number (string-copy vstr 1 first-period)))
(define minor (string->number (string-copy vstr (+ first-period 1) second-period)))
(define patch (string->number (string-copy vstr (+ second-period 1) (or prerelease-dash build-dash (string-length vstr)))))
(define prerelease (and prerelease-dash (string-copy vstr (+ prerelease-dash 1) (or build-dash (string-length vstr)))))
(define build (and build-dash (string-copy vstr (+ build-dash 1))))
(list major minor patch prerelease build))
(define (version<? left right)
(set! left (parse-version left))
(set! right (parse-version right))
(or
; left.major < right.major, or
(< (list-ref left 0) (list-ref right 0))
(and
; left.major = right.major, and
(= (list-ref left 0) (list-ref right 0))
(or
; left.minor < right.minor, or
(< (list-ref left 1) (list-ref right 1))
(and
; left.minor = right.minor, and
(= (list-ref left 1) (list-ref right 1))
(or
; left.patch < right.patch, or
(< (list-ref left 2) (list-ref right 2))
(and
; left.patch = right.patch, and
(= (list-ref left 2) (list-ref right 2))
(or
; left has prerelease, right doesn't
(and (list-ref left 3) (not (list-ref right 3)))
; or both have a prerelease and it's comparable
(and (list-ref left 3) (string<? (list-ref left 3) (list-ref right 3)))))))))))))

151
lang/go/src/vfs.sld Normal file
View file

@ -0,0 +1,151 @@
(define-library (zilch lang go vfs)
(import
(scheme base) (scheme write) (scheme read) (scheme file) (scheme process-context) (scheme lazy) (scheme case-lambda)
(chicken file)
(zilch magic) (zilch file) (zilch zexpr)
(zilch nix drv) (zilch nix path) (zilch nixpkgs)
(json)
(chicken base) (chicken format) (chicken foreign)
(scheme char)
(srfi 4) (srfi 128) (srfi 133) (srfi 146) (srfi 152) (srfi 207)
(zilch lang go) (zilch lang go core) (zilch lang go stdlib) (zilch lang go sum) (zilch lang go fetch)
(chicken foreign))
(export vfs-from-dirhash vfs-from-directory filter-vfs filter-vfs-for-package-reading vfs-to-store)
(begin
(define (read-full-file port)
(define buf (make-bytevector 2048 0))
(call-with-port (open-output-bytevector)
(lambda (outport)
(do ((read-bytes 0 (read-bytevector! buf port))) ((eof-object? read-bytes) (get-output-bytevector outport))
(unless (eof-object? read-bytes) (write-bytevector buf outport 0 read-bytes))))))
(foreign-declare "#include \"dirhash_source.h\"")
(define dirhash-generator
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("archive/zip" "crypto/sha256" "fmt" "io" "os" "sort"))
(list (cons "main.go" (zfile (foreign-value "dirhash_source" nonnull-c-string)))))))
(foreign-declare "#include \"unzip_one_source.h\"")
(define unpack-zip
(go-package-link
(go-package-compile "main"
(map go-stdlib-ref '("archive/zip" "io" "os"))
(list (cons "main.go" (zfile (foreign-value "unzip_one_source" nonnull-c-string)))))))
(define (rewrite-name name)
(define out "")
(string-for-each (lambda (ch)
(if (char-upper-case? ch) (set! out (string-append out (string #\! (char-downcase ch)))) (set! out (string-append out (string ch))))) name)
out)
(define (vfs-to-store vfs)
(define dirmap (mapping (make-default-comparator)))
(vector-for-each
(lambda (pair)
(define key (car pair))
(define separator (if (string=? key "/") 0 (string-index-right key (lambda (ch) (char=? ch #\/)) 0 (- (string-length key) 1))))
(unless (string=? key "/")
(let
((dirname (string-copy key 0 (+ 1 separator)))
(fname (string-copy key (+ 1 separator) (- (string-length key) 1))))
(set! dirmap (mapping-set! dirmap dirname (cons (cons fname key) (mapping-ref/default dirmap dirname '())))))))
vfs)
(define (translate-dir name)
(define files (vector-any (lambda (f) (and (string=? (car f) name) (cdr f))) vfs))
(define dirs (mapping-ref/default dirmap name '()))
(zdir (append
(map (lambda (kv) (cons (car kv) (zsymlink (cdr kv)))) (vector->list files))
(map (lambda (k) (cons (car k) (translate-dir (cdr k)))) dirs))))
(translate-dir "/"))
(define (fetch-dirhash-for-sum sum-line)
(when (go-sum-path sum-line) (error "go.sum line is invalid for fetch-dirhash-for-sum" sum-line))
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
(define known (fetch-with-known-url "module.zip" url))
(store-path-for-fod "module" "x86_64-linux" #~(#$dirhash-generator) #~(("src" . #$known)) "sha256" (go-sum-hash sum-line) #f))
(define (vfs-from-dirhash sum-line)
(define dirhash-file (fetch-dirhash-for-sum sum-line))
(define url (string-append "https://proxy.golang.org/" (rewrite-name (go-sum-module sum-line)) "/@v/" (go-sum-version sum-line) ".zip"))
(define zip (fetch-with-known-url "module.zip" url))
(define lines '())
(define prefix-length (string-length (string-append (go-sum-module sum-line) "@" (go-sum-version sum-line) "/")))
(call-with-port (store-path-open dirhash-file)
(lambda (port)
(do ((line "" (read-line port)) (hash #f) (file #f))
((eof-object? line) #f)
(unless (string=? "" line)
(set! hash (hex-string->bytevector (string-copy line 0 64)))
(set! file (string-copy line 66))
(set! lines (cons (cons file hash) lines))))))
(define dirs '())
(for-each
(lambda (pair)
(define fpath (string-copy (car pair) prefix-length))
(define slashindex (string-index-right fpath (lambda (c) (char=? c #\/))))
(define dirname "/")
(define filename fpath)
(when slashindex
(set! dirname (string-append "/" (string-copy fpath 0 slashindex) "/"))
(set! filename (string-copy fpath (+ slashindex 1))))
(define dir (assoc dirname dirs))
(define file (store-path-for-fod "file" "x86_64-linux" #~(#$unpack-zip #$zip ,(car pair)) '() "sha256" (cdr pair) #f))
(unless dir
(set! dirs (cons (list dirname) dirs))
(set! dir (car dirs)))
; Skip files we know for sure won't be used.
(unless (or (string-contains dirname "/_") (string-contains dirname "/.") (string-contains dirname "/testdata/") (char=? #\. (string-ref filename 0)) (char=? #\_ (string-ref filename 0)))
(set-cdr! dir (cons (cons filename file) (cdr dir)))))
lines)
(list->vector (map (lambda (pair) (cons (car pair) (list->vector (cdr pair)))) dirs)))
(define (vfs-from-directory osdir)
(define iter-dir #f)
(define output '())
(set! iter-dir
(lambda (dirpath)
(define reldir (string-append osdir "/" dirpath))
(define files '())
(define contents (directory (string-append osdir dirpath)))
(for-each
(lambda (name)
(unless (string=? (string-copy name 0 1) ".")
(if (directory-exists? (string-append reldir "/" name))
(iter-dir (string-append dirpath "/" name))
(set! files (cons (cons name (zfile #~,(call-with-input-file (string-append reldir "/" name) read-full-file))) files)))))
contents)
(set! output (cons (cons (string-append dirpath "/") (list->vector files)) output))))
(iter-dir "")
(list->vector output))
(define (filter-vfs vfs filter)
(vector-map
(lambda (dir)
(cons (car dir)
(vector-map
(lambda (pair)
(if (filter (car dir) (car pair))
(cons (car pair) (cdr pair))
(cons (car pair) "/dev/null")))
(cdr dir))))
vfs))
; List extracted from go src/go/build/build.go.
(define good-extensions '("go" "c" "cc" "cpp" "cxx" "m" "h" "hh" "hpp" "hxx" "f" "F" "for" "f90" "s" "S" "sx" "swig" "swigcxx" "syso"))
(define (extract-extension name i)
(cond ((char=? (string-ref name i) #\.) (string-copy name (+ i 1)))
((= i 0) #f)
(else (extract-extension name (- i 1)))))
(define (filter-vfs-for-package-reading vfs)
(filter-vfs vfs
(lambda (dir fname)
(define extension (extract-extension fname (- (string-length fname) 1)))
(member extension good-extensions))))))

3
lang/go/utils/dirhash/go.mod Normal file
View file

@ -0,0 +1,3 @@
module puck.moe/zilch/go/dirhash
go 1.22.5

52
lang/go/utils/dirhash/main.go Normal file
View file

@ -0,0 +1,52 @@
package main
import (
"archive/zip"
"crypto/sha256"
"fmt"
"io"
"os"
"sort"
)
func main() {
out, err := os.OpenFile(os.Getenv("out"), os.O_CREATE|os.O_RDWR, 0666)
if err != nil {
panic(err)
}
var files []string
f, err := zip.OpenReader(os.Getenv("src"))
if err != nil {
panic(err)
}
for _, file := range f.File {
if file.Mode().IsDir() {
continue
}
files = append(files, file.Name)
}
sort.Strings(files)
for _, rel := range files {
f, err := f.Open(rel)
if err != nil {
panic(err)
}
defer f.Close()
hash := sha256.New()
_, err = io.Copy(hash, f)
if err != nil {
panic(err)
}
fmt.Fprintf(out, "%x %s\n", hash.Sum(nil), rel)
}
out.Close()
f.Close()
}

5
lang/go/utils/parser/go.mod Normal file
View file

@ -0,0 +1,5 @@
module puck.moe/zilch/go/parser
go 1.22.5
require github.com/davecgh/go-spew v1.1.1

289
lang/go/utils/parser/main.go Normal file
View file

@ -0,0 +1,289 @@
package main
import (
"encoding/json"
"fmt"
"go/build"
"io"
"io/fs"
"os"
"path"
"path/filepath"
"sort"
"strings"
"time"
)
type WrappedStat struct {
fs.FileInfo
newName string // meow
}
func (s *WrappedStat) Name() string {
return s.newName
}
type DirStat struct {
name string
}
func (s *DirStat) Name() string {
return s.name
}
func (s *DirStat) Size() int64 {
return 1
}
func (s *DirStat) Mode() fs.FileMode {
return fs.FileMode(fs.ModeDir | 0777)
}
func (s *DirStat) ModTime() time.Time {
return time.Time{}
}
func (s *DirStat) IsDir() bool {
return true
}
func (s *DirStat) Sys() any {
return "zilch"
}
type Input struct {
// directory -> filename -> path
Files map[string]map[string]string `json:"files"`
GOARCH string `json:"GOARCH"`
GOOS string `json:"GOOS"`
}
type Output struct {
Name string `json:"name"`
GoFiles []string `json:"goFiles"`
SFiles []string `json:"sFiles"`
Imports []string `json:"imports"`
Embeds map[string][][]string `json:"embeds"`
}
func main() {
inputFile, err := os.Open(os.Args[1])
if err != nil {
panic(err)
}
var input Input
err = json.NewDecoder(inputFile).Decode(&input)
if err != nil {
panic(err)
}
ctx := build.Context{
GOARCH: input.GOARCH,
GOOS: input.GOOS,
Compiler: "gc",
ToolTags: build.Default.ToolTags,
ReleaseTags: build.Default.ReleaseTags,
ReadDir: func(dir string) ([]fs.FileInfo, error) {
fmt.Printf("ReadDir(%q)\n", dir)
if !strings.HasPrefix(dir, "/code") {
return nil, fs.ErrNotExist
}
dir = path.Clean(dir[5:])
if dir == "." {
dir = "/"
}
if !strings.HasSuffix(dir, "/") {
dir += "/"
}
dircontents, ok := input.Files[dir]
if !ok {
return nil, fs.ErrNotExist
}
infos := make([]fs.FileInfo, len(dircontents))
i := 0
for name, file := range dircontents {
stat, err := os.Stat(file)
if err != nil {
return nil, err
}
infos[i] = &WrappedStat{FileInfo: stat, newName: name}
i = i + 1
}
for key := range input.Files {
if path.Dir(key) == dir {
base := path.Base(key)
if strings.HasPrefix(base, ".") || strings.HasPrefix(base, "_") || base == "testdata" {
continue
}
infos = append(infos, &DirStat{base})
}
}
return infos, nil
},
OpenFile: func(pth string) (io.ReadCloser, error) {
opth := pth
fmt.Printf("OpenFile(%q)\n", pth)
if !strings.HasPrefix(pth, "/code") {
return nil, fs.ErrNotExist
}
pth = path.Clean(pth[5:])
dirname, fname := path.Split(pth)
if dirname == "." {
dirname = "/"
}
dir := input.Files[dirname]
data, err := os.Open(dir[fname])
if err != nil {
return data, fmt.Errorf("OpenFile(%q; %q[%q]; %q): %w", opth, dirname, fname, dir[fname], err)
}
return data, err
},
IsDir: func(dir string) bool {
fmt.Printf("IsDir(%q)\n", dir)
if !strings.HasPrefix(dir, "/code") {
return false
}
dir = path.Clean(dir[5:])
if dir == "." {
dir = "/"
}
if !strings.HasSuffix(dir, "/") {
dir += "/"
}
_, ok := input.Files[dir]
fmt.Printf("IsDir -> %q, %v\n", dir, ok)
return ok
},
HasSubdir: func(root, dir string) (rel string, ok bool) {
root = path.Clean(root)
dir = path.Clean(dir)
return strings.CutPrefix(dir, root)
},
}
var filenames []string
for dirname, files := range input.Files {
for filename := range files {
filenames = append(filenames, filepath.Join(dirname, filename))
}
}
files := make(map[string]Output)
for dir, filelist := range input.Files {
isGo := false
for file := range filelist {
if strings.HasSuffix(file, ".go") {
isGo = true
break
}
}
fmt.Printf("Checking %q..\n", dir)
if strings.Contains(dir, "/.") || strings.Contains(dir, "/_") || strings.Contains(dir, "/testdata/") {
fmt.Printf(" skipping; \n")
continue
}
base := path.Base(dir)
if !isGo || strings.HasPrefix(base, "_") || strings.HasPrefix(base, ".") || base == "testdata" {
fmt.Printf(" skipping (not go)\n")
continue
}
pkg, err := ctx.Import(".", path.Clean("/code"+dir), 0)
if err != nil {
if _, ok := err.(*build.NoGoError); ok {
continue
}
panic(err)
}
out := Output{
Name: pkg.Name,
Imports: pkg.Imports,
GoFiles: pkg.GoFiles,
SFiles: pkg.SFiles,
Embeds: make(map[string][][]string),
}
// _test only, or so
if len(pkg.GoFiles) == 0 {
continue
}
sort.Strings(out.Imports)
sort.Strings(out.GoFiles)
sort.Strings(out.SFiles)
sort.Strings(pkg.EmbedPatterns)
for _, pattern := range pkg.EmbedPatterns {
matchedFiles := []string{}
// TODO: proper matching
if strings.HasPrefix(pattern, "all:") {
pattern = pattern[4:]
}
fullPattern := filepath.Join(dir, pattern)
for _, file := range filenames {
if ok, _ := filepath.Match(fullPattern, file); ok {
matchedFiles = append(matchedFiles, file)
}
}
if len(matchedFiles) == 0 {
dirpattern := fullPattern + "/"
for _, file := range filenames {
if strings.HasPrefix(file, dirpattern) {
matchedFiles = append(matchedFiles, file)
}
if file == fullPattern {
matchedFiles = append(matchedFiles, file)
}
}
}
sort.Strings(matchedFiles)
var split [][]string
for _, match := range matchedFiles {
split = append(split, []string{match[len(dir):], filepath.Dir(match) + "/", filepath.Base(match)})
}
out.Embeds[pattern] = split
}
files[dir] = out
}
out, err := os.OpenFile(os.Getenv("out"), os.O_CREATE|os.O_RDWR, 0666)
if err != nil {
panic(err)
}
if err := json.NewEncoder(out).Encode(files); err != nil {
panic(err)
}
out.Close()
}

3
lang/go/utils/unzip-one/go.mod Normal file
View file

@ -0,0 +1,3 @@
module puck.moe/zilch/go/unzip-one
go 1.22.5

32
lang/go/utils/unzip-one/main.go Normal file
View file

@ -0,0 +1,32 @@
package main
import (
"archive/zip"
"io"
"os"
)
func main() {
f, err := zip.OpenReader(os.Args[1])
if err != nil {
panic(err)
}
in, err := f.Open(os.Args[2])
if err != nil {
panic(err)
}
out, err := os.OpenFile(os.Getenv("out"), os.O_CREATE|os.O_RDWR, 0666)
if err != nil {
panic(err)
}
if _, err := io.Copy(out, in); err != nil {
panic(err)
}
out.Close()
in.Close()
f.Close()
}

30
lang/go/zilch-lang-go.egg Normal file
View file

@ -0,0 +1,30 @@
((version "0.0.1")
(synopsis "Nix. Noppes. Nada.")
(author "puck")
(dependencies r7rs json zilch srfi-207)
(component-options
(csc-options "-X" "r7rs" "-X" "zilch.zexpr" "-R" "r7rs" "-optimize-level" "3"))
(components
(extension zilch.lang.go
(source "src/go.sld")
(component-dependencies zilch.lang.go.core))
(extension zilch.lang.go.stdlib
(source "src/stdlib.sld")
(component-dependencies zilch.lang.go.core zilch.lang.go))
(extension zilch.lang.go.mod
(source "src/mod.sld")
(component-dependencies zilch.lang.go.stdlib zilch.lang.go zilch.lang.go.vfs zilch.lang.go.sum zilch.lang.go.fetch zilch.lang.go.package zilch.lang.go.version))
(extension zilch.lang.go.package
(source "src/package.sld")
(component-dependencies zilch.lang.go.stdlib zilch.lang.go zilch.lang.go.vfs))
(extension zilch.lang.go.vfs
(source "src/vfs.sld")
(component-dependencies zilch.lang.go.stdlib zilch.lang.go zilch.lang.go.sum zilch.lang.go.fetch))
(extension zilch.lang.go.sum
(source "src/sum.sld"))
(extension zilch.lang.go.fetch
(source "src/fetch.sld"))
(extension zilch.lang.go.version
(source "src/version.sld"))
(extension zilch.lang.go.core
(source "src/core.sld"))))

20
lib/build-chicken-parallel/default.nix Normal file
View file

@ -0,0 +1,20 @@
{ callPackage, python3, stdenv, chickenPackages, ninja, pkg-config, libfaketime }: let
process = callPackage ./process.nix {};
in
{ name, src, buildInputs, buildAgainst ? [], overrides ? { } }: let
buildAgainstList = builtins.toString buildAgainst;
in stdenv.mkDerivation ({
inherit name src;
buildInputs = [ chickenPackages.chicken ninja pkg-config libfaketime ] ++ buildInputs;
propagatedBuildInputs = buildInputs;
enableParallelBuilding = true;
dontStrip = true;
configurePhase = ''
runHook preConfigure
${process}/bin/process ${name} ./ $out/lib/chicken/11 ${if buildAgainst == [] then ''"" ""'' else ''"$(pkg-config --cflags ${buildAgainstList})" "$(pkg-config --libs ${buildAgainstList})"''}
runHook postConfigure
'';
} // overrides)

9
lib/build-chicken-parallel/process.egg Normal file
View file

@ -0,0 +1,9 @@
((version "0.0.1")
(synopsis "process egg files")
(author "puck")
(dependencies r7rs)
(component-options
(csc-options "-X" "r7rs" "-R" "r7rs" "-optimize-level" "3"))
(components
(program process
(source "process.scm"))))

10
lib/build-chicken-parallel/process.nix Normal file
View file

@ -0,0 +1,10 @@
{ eggDerivation, chickenPackages }:
eggDerivation {
name = "process";
src = ./.;
buildInputs = with chickenPackages.chickenEggs; [
r7rs
];
}

139
lib/build-chicken-parallel/process.scm Normal file
View file

@ -0,0 +1,139 @@
(import (scheme base) (scheme read) (scheme write) (scheme process-context))
(define egg-name (cadr (command-line)))
(define srcdir (caddr (command-line)))
(define outdir (cadr (cddr (command-line))))
(define extra-cflags (cadr (cdr (cddr (command-line)))))
(define extra-ldflags (cadr (cddr (cddr (command-line)))))
(define shared-flags '())
(define link-flags '())
(define installed-files '())
(unless (string=? extra-cflags "") (set! shared-flags (list "-C" extra-cflags)))
(unless (string=? extra-ldflags "") (set! link-flags (list "-L" extra-ldflags)))
; TODO(puck): make this actually escaped
(define (make-escaped-string val) (string-append "'" val "'"))
(define (emit-build outputs implicit-outputs rulename deps implicit-deps flags)
(write-string "build ")
(for-each (lambda (output) (write-string " ") (write-string output)) outputs)
(unless (eq? implicit-outputs '()) (write-string " |"))
(for-each (lambda (implicit-output) (write-string implicit-output) (write-string " ")) implicit-outputs)
(write-string ": ")
(write-string rulename)
(for-each (lambda (dep) (write-string " ") (write-string dep)) deps)
(unless (eq? implicit-deps '()) (write-string " |"))
(for-each (lambda (implicit-dep) (write-string implicit-dep) (write-string " ")) implicit-deps)
(write-string "\n")
(for-each (lambda (flag) (write-string " ") (write-string (symbol->string (car flag))) (write-string " = ") (write-string (cdr flag)) (write-string "\n")) flags))
(define counter 1)
(define (inc-ctr)
(set! counter (+ counter 1))
(string-append "1980-01-01 00:00:" (number->string counter)))
(define (process-component component)
(define name (symbol->string (cadr component)))
(define source #f)
(define deps '())
(define csc-options shared-flags)
(for-each
(lambda (v)
(case (car v)
((source) (set! source (cadr v)))
((component-dependencies) (set! deps (cdr v)))
((csc-options) (set! csc-options (append csc-options (cdr v))))))
(cddr component))
(define flagobj (list (cons 'unit name)))
(define flagstr "")
(unless (eq? csc-options shared-flags)
(for-each (lambda (f) (set! flagstr (string-append flagstr " " (make-escaped-string f)))) csc-options)
(set! flagobj (cons (cons 'flags flagstr) flagobj)))
(emit-build
(list (string-append name ".so"))
(list (string-append name ".import.scm"))
"csc_shared" (list (string-append srcdir source))
(map (lambda (dep) (string-append (symbol->string dep) ".import.so")) deps)
(cons (cons 'rnd (inc-ctr)) flagobj))
(emit-build
(list (string-append name ".static.o"))
(list (string-append name ".link"))
"csc_static" (list (string-append srcdir source))
(map (lambda (dep) (string-append (symbol->string dep) ".import.so")) deps)
(cons (cons 'rnd (inc-ctr)) (cons (cons 'linkfile (string-append name ".link")) flagobj)))
(emit-build
(list (string-append name ".import.so"))
'()
"csc_shared_import" (list (string-append name ".import.scm"))
'()
(cons (cons 'rnd (inc-ctr)) flagobj))
(write-string (string-append "default " name ".so " name ".static.o " name ".import.so\n"))
(emit-build (list (string-append outdir "/" name ".import.so")) '() "install" (list (string-append name ".import.so")) '() '())
(emit-build (list (string-append outdir "/" name ".so")) '() "install" (list (string-append name ".so")) '() '())
(emit-build (list (string-append outdir "/" name ".o")) '() "install" (list (string-append name ".static.o")) '() '())
(emit-build (list (string-append outdir "/" name ".link")) '() "install" (list (string-append name ".link")) '() '())
(set! installed-files
(append installed-files
(list
(string-append outdir "/" name ".o")
(string-append outdir "/" name ".so")
(string-append outdir "/" name ".link")
(string-append outdir "/" name ".import.so")))))
(define egg (with-input-from-file (string-append egg-name ".egg") read))
(with-output-to-file "build.ninja"
(lambda ()
(display "rule csc_shared
command = faketime -f \"$rnd\" csc -host -D compiling-extension -regenerate-import-libraries -setup-mode $flags $linkflags -J -shared $in -o $out
description = CSC $unit (shared)
rule csc_shared_import
command = faketime -f \"$rnd\" csc -host -setup-mode $flags $linkflags -J -shared $in -o $out
description = CSC $unit (import)
rule csc_static
command = faketime -f \"$rnd\" csc -host -D compiling-extension -D compiling-static-extension -regenerate-import-libraries -setup-mode -profile $flags -emit-link-file $linkfile -c -unit $unit -M -static $in -o $out
description = CSC $unit (static)
rule install
command = mkdir -p $$(dirname $out) && cp $in $out
description = INST $in
")
(for-each
(lambda (val)
(when (eq? (car val) 'component-options)
(for-each
(lambda (v)
(when (eq? (car v) 'csc-options)
(set! shared-flags `(,@shared-flags ,@(cdr v)))
(write-string "flags =")
(for-each (lambda (l) (write-string (string-append " " (make-escaped-string l)))) shared-flags)
(write-string "\n"))
(when (eq? (car v) 'link-options)
(set! link-flags `(,@link-flags ,@(cdr v)))
(write-string "linkflags =")
(for-each (lambda (l) (write-string (string-append " " (make-escaped-string l)))) link-flags)
(write-string "\n"))) (cdr val)))
(when (eq? (car val) 'components)
(for-each process-component (cdr val))))
egg)
(emit-build (list (string-append outdir "/" egg-name ".egg-info")) '() "install" (list (string-append egg-name ".egg-info")) '() '())
(set! installed-files (cons (string-append outdir "/" egg-name ".egg-info") installed-files))
(emit-build '("install") '() "phony" installed-files '() '())))
(define egginfo `((installed-files ,@installed-files) ,@egg))
(with-output-to-file (string-append egg-name ".egg-info") (lambda () (write egginfo)))

33
shell.nix Normal file
View file

@ -0,0 +1,33 @@
{ nixpkgs ? <nixpkgs> }:
let
overlay = import ./aux/overlay.nix;
pkgs = import nixpkgs { overlays = [ overlay ]; };
in
pkgs.mkShell {
name = "zilch-shell";
buildInputs = [
(pkgs.callPackage ./core {})
(pkgs.callPackage ./lang/go {})
(pkgs.callPackage ./docs/docread {})
(pkgs.callPackage ./cli {})
pkgs.chickenPackages_5.chickenEggs.breadline
pkgs.chickenPackages_5.chickenEggs.trace
pkgs.chickenPackages_5.chickenEggs.expand-full
pkgs.chickenPackages_5.chickenEggs.json
pkgs.chicken
pkgs.gdb
pkgs.libsodium
pkgs.tcl
pkgs.tk
pkgs.inotify-tools
pkgs.nodejs
pkgs.bpftrace
pkgs.s6
pkgs.rlwrap
];
}