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

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