zilch/cli/zilch-ninja.scm

(import (scheme base) (scheme write) (zilch statusbar) (zilch nix daemon) (zilch magic) (zilch lib getopt) (scheme process-context) (chicken process-context) (srfi 146) (chicken port) (chicken foreign) (chicken condition))
(foreign-declare "#include <sched.h>")

(define get-cpu-count
  (foreign-lambda* int ()
    "cpu_set_t set; sched_getaffinity(0, sizeof(set), &set); C_return(CPU_COUNT(&set));"))

(foreign-declare "#include \"man_ninja.h\"")
(define man-page (foreign-value "man_ninja" nonnull-c-string))

(define (print-help msg)
  (when msg
    (write-string (string-append msg "\n\n") (current-error-port)))
  (write-string man-page (current-error-port))
  (exit (or (not msg) 1)))

(define-values (options args)
 (getopt
  '((help #f #\h)
    (config-file #t #\f)
    (max-jobs #t #\j)
    (verbose #f #\v)
    (source #t #\s)
    (project #t #\p)
    (trust-all #f #\T)
    (print-build-logs #f #\L))
  (list->vector (cdr (command-line)))
  print-help))

(when (assoc 'help options) (print-help #f))

;; Set up the logger.
(define (set-print-logs val) #f)
(let ((prev-error-handler (current-exception-handler))) (current-exception-handler (lambda data (set-print-logs #t) (apply prev-error-handler data))))
(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)))

(when (null? args)
  (set-print-logs #t)
  (print-help "No subcommand"))

;; Flags passed to the nix daemon:
(define max-jobs (if (assoc 'max-jobs options) (string->number (cdr (assoc 'max-jobs options))) (get-cpu-count)))
(define verbosity 3)
(for-each (lambda (val) (when (eq? (car val) 'verbose) (set! verbosity (+ 1 verbosity)))) options)
(write-string (string-append "Connected to Nix daemon, version " (daemon-link-daemon-version (*daemon*)) "\n") (current-error-port))

(daemon-wop-set-options (*daemon*) verbosity max-jobs #t)
(ca-thread-count max-jobs)

(import
  (scheme base) (scheme file) (scheme read)
  (chicken format) (chicken process) (chicken file)
  (zilch lang ninja) (zilch lang ninja build)
  (zilch lang ninja nixpkgs)
  (zilch lang ninja config)
  (zilch magic) (zilch nixpkgs) (zilch vfs)
  (zilch nix drv)
  (zilch zexpr)
  (srfi 128) (srfi 146) (srfi 152))

(when (assoc 'trust-all options) (nixpkgs-eval-allow-all))

(define source (and (assoc 'source options) (cdr (assoc 'source options))))
(when source (nixpkgs-eval-allow-path source))

(define config-path (if (assoc 'config-file options) (cdr (assoc 'config-file options)) "zilch.scm"))
; This is fine, canonicalisation is done without influence of the FS.
(nixpkgs-eval-allow-path (string-append config-path "/.."))

(define (allow-source-paths config)
  (when (ninja-build-config-override-source-path config)
    (nixpkgs-eval-allow-path (ninja-build-config-override-source-path)))
  (for-each
   (lambda (rewrite)
    (allow-source-paths (cdr rewrite)))
   (ninja-build-config-rewrites config)))

(define config (parse-ninja-config config-path (string=? (car args) "build")`(override-source: ,(and source (vfs-from-directory source)) ,@(call-with-input-file config-path read))))
(allow-source-paths config)

(when (and (ninja-build-config-depfile-path config) (file-exists? (ninja-build-config-depfile-path config)))
  (set-ninja-build-config-depfile! config (alist->mapping (make-default-comparator) (call-with-input-file (ninja-build-config-depfile-path config) read))))

(define (export-depfiles finalized-drv)
 (define config (finalized-drv-config finalized-drv))
 (when (ninja-build-config-depfile-path config)
  (call-with-output-file (ninja-build-config-depfile-path config) (lambda (p) (write (mapping->alist (finalized-drv-depfile finalized-drv)) p))))
 (for-each (lambda (v) (export-depfiles (force (drv-rewrite-finalized-drv v)))) (finalized-drv-rewritten-drvs finalized-drv)))

(for-each
 (lambda (c)
  (when (eq? (car c) 'project)
   (let loop ((rewrites (ninja-build-config-rewrites config)))
    (cond
     ((null? rewrites) (set-print-logs #t) (error "Subproject not found" (cdr c)))
     ((string=? (caar rewrites) (cdr c)) (set! config (cdar rewrites)))
     (else (loop (cdr rewrites)))))))
 options)

(define (do-diff config source-override is-root)
  (define-values (_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
  (define path (or source-override (ninja-build-config-override-source-path config) (and is-root "src")))
  (define exit-status 0)
  (when path
    (let*-values
      (((pid) (process-run "git"
               (list "diff" "--no-index" "--"
                (string-append (store-path-realised configured-drv) "/src")
                path)))
       ((pid normal-exit new-exit-status) (process-wait pid)))
      (unless normal-exit (exit #f))
      (set! exit-status (max exit-status new-exit-status))))
  (for-each
   (lambda (v)
    (set! exit-status
     (max exit-status
      (do-diff (cdr v) #f #f))))
   (ninja-build-config-rewrites config))
  exit-status)

(define (do-source config source-override is-root)
  (define-values (_ configured-drv _ _ _ _ _) (setup-ninja-environment config '()))
  (define path (or source-override (ninja-build-config-override-source-path config) (and is-root "src")))
  (when path
   (system* (string-append "cp -rf --no-preserve=ownership -T " (store-path-realised configured-drv) "/src " (qs path)))
   (system* (string-append "chmod -R u+rw " (qs path))))
  (for-each
   (lambda (v)
    (do-source (cdr v) #f #f))
   (ninja-build-config-rewrites config)))

(cond
 ((string=? (car args) "source")
  (do-source config (and (pair? (cdr args)) (cadr args)) #t))
 ((string=? (car args) "diff")
  (exit (= (do-diff config source #t) 0)))
 ((string=? (car args) "build")
  (if (null? (cdr args))
   (let ((output (build-nixpkgs-drv-reproducibly config)))
    (for-each
     (lambda (output-and-path)
      (store-path-realised (cdr output-and-path))
      (printf "~A\t-> ~S\n" (car output-and-path) (cdr output-and-path)))
     (finalized-drv-output-store-paths output))
    (export-depfiles output))
   (let-values (((_ _ _ edge-ref defaults _) (setup-ninja-environment config)))
    (for-each
     (lambda (target)
      (define built-target (edge-ref target))
      (printf "~A\t-> ~S\n" target (store-path-realised (force (built-edge-out-drv (cdr built-target))))))
     (cdr args)))))
 (else
  (print-help (string-append "Unknown subcommand " (car args)))))