;; 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-path derivation-output-hash derivation-output-algo derivation-output-recursive derivation-output-placeholder? derivation-output-path-length write-quoted-string 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 modulo-hash-drv-contents) (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 (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 ( drvout out) (fprintf out "#" (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 (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 ( drv out) (fprintf out "#" (derivation-cached-data-path drv) (derivation-cached-data-modulo-hash drv) (derivation-cached-data-is-deferred drv) (not (not (derivation-cached-data-serialized drv))))) ;; An entire derivation. ;; `outputs` is stored as an alist of output name to `` object. ;; `input-drvs` is stored as an alist of `` 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 (make-derivation name outputs input-drvs input-src system builder args env cached-data) derivation? (name derivation-name) ; '(id . ) (outputs derivation-outputs) ; '( . (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 is-printing-drv (make-parameter #f)) (define-record-printer ( drv out) (define was-printing-drv (is-printing-drv)) (parameterize ((is-printing-drv #t)) (fprintf out "#" (derivation-name drv) (derivation-outputs drv) (if was-printing-drv (map derivation-name (derivation-input-drvs 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 ``, 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 `` 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) (stringutf8 (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 stringutf8 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)))) ;; Reads a `` 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))) ;; 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) (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 (derivation-input-drvs drv)) (set-derivation-cached-data-serialized! (derivation-cached-data drv) (get-output-bytevector nport)) (write-bytevector (get-output-bytevector nport) port))))) ((drv port masked) (derivation-serialize-internal drv port masked))))))