mirror of
https://github.com/NixOS/hydra.git
synced 2024-10-18 17:02:28 -04:00
250 lines
10 KiB
Scheme
250 lines
10 KiB
Scheme
#!/bin/sh
|
||
# Aside from this initial boilerplate, this is actually -*- scheme -*- code.
|
||
main="(module-ref (resolve-interface '(hydra-eval-guile-jobs)) 'eval-guile-jobs)"
|
||
|
||
# Keep the host's GUILE_LOAD_PATH unchanged to allow the installed Guix to
|
||
# be used. This moves Guix modules possibly out of control, but solves
|
||
# bootstrapping issues.
|
||
#
|
||
# Use `--fresh-auto-compile' to ignore any available .go, and force
|
||
# recompilation. This is because checkouts in the store has mtime set to
|
||
# the epoch, and thus .go files look newer, even though they may not
|
||
# correspond.
|
||
|
||
exec ${GUILE:-@GUILE@} --no-auto-compile --fresh-auto-compile \
|
||
-l "$0" -c "(apply $main (cdr (command-line)))" "$@"
|
||
!#
|
||
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
|
||
;;;
|
||
;;; This file is part of Hydra.
|
||
;;;
|
||
;;; Hydra is free software: you can redistribute it and/or modify
|
||
;;; it under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation, either version 3 of the License, or
|
||
;;; (at your option) any later version.
|
||
;;;
|
||
;;; Hydra is distributed in the hope that it will be useful,
|
||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with Hydra. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (hydra-eval-guile-jobs)
|
||
#:use-module (sxml simple)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-11)
|
||
#:export (job-evaluations->xml
|
||
eval-guile-jobs))
|
||
|
||
(define (guix-variable module name)
|
||
"Dynamically link variable NAME under Guix module MODULE and return it.
|
||
Note: this is used instead of `@', because when using `@' in an uncompiled
|
||
file, Guile tries to load the module directly as it reads the source, which
|
||
fails in our case, leading to the creation of empty (guix ...) modules."
|
||
;; TODO: fail with an XML error description
|
||
(let ((m (resolve-interface `(guix ,module))))
|
||
(module-ref m name)))
|
||
|
||
(define (%derivation-system drv)
|
||
;; XXX: Awful hack to workaround the fact that `derivation-system', which
|
||
;; is a macro, cannot be referred to dynamically.
|
||
(struct-ref drv 3))
|
||
|
||
(define strip-store-path
|
||
(let* ((store (or (getenv "NIX_STORE_DIR") "/nix/store"))
|
||
(store-path-rx
|
||
(make-regexp (string-append "^.*" (regexp-quote store)
|
||
"/[^-]+-(.+)$"))))
|
||
(lambda (path)
|
||
(or (and=> (regexp-exec store-path-rx path)
|
||
(lambda (match)
|
||
(let ((path (match:substring match 1)))
|
||
path)))
|
||
path))))
|
||
|
||
(define (derivation-path->name drv)
|
||
"Return the base name of DRV, sans hash and `.drv' extension."
|
||
(let ((d (strip-store-path drv)))
|
||
(if (string-suffix? ".drv" d)
|
||
(string-drop-right d 4)
|
||
d)))
|
||
|
||
(define (register-gc-root drv roots-dir)
|
||
"Register a permanent garbage collector root under ROOTS-DIR for DRV."
|
||
(let ((root (string-append roots-dir "/" (basename drv))))
|
||
(unless (file-exists? root)
|
||
(symlink drv root))))
|
||
|
||
(define* (job-evaluations->sxml jobs
|
||
#:key gc-roots-dir)
|
||
"Return the hydra-eval-jobs SXML form for the result of JOBS, a list of
|
||
symbol/thunk pairs."
|
||
`(*TOP*
|
||
(*PI* xml "version='1.0' encoding='utf-8'")
|
||
"\n"
|
||
(jobs "\n"
|
||
,@(map (match-lambda
|
||
(((? symbol? name) . (? thunk? thunk))
|
||
(let* ((result (save-module-excursion
|
||
(lambda ()
|
||
(set-current-module %user-module)
|
||
(with-output-to-port (%make-void-port "w")
|
||
thunk))))
|
||
(drv (assoc-ref result 'derivation)))
|
||
(define (opt-attr xml-name name)
|
||
(match (assoc name result)
|
||
((_ . value)
|
||
`((,xml-name ,value)))
|
||
(_
|
||
'())))
|
||
|
||
(when gc-roots-dir
|
||
;; Register DRV as a GC root so that it's not collected by
|
||
;; the time 'hydra-build' attempts to build it.
|
||
(register-gc-root drv gc-roots-dir))
|
||
|
||
;; XXX: Add <arg ...> tags?
|
||
`(job (@ (jobName ,name)
|
||
(drvPath ,drv)
|
||
,@(opt-attr 'homepage 'home-page)
|
||
(license
|
||
,(let loop ((license (assoc-ref result 'license)))
|
||
(match license
|
||
((? struct?)
|
||
(struct-ref license 0))
|
||
((l ...)
|
||
(string-join (map loop l)))
|
||
(_ ""))))
|
||
,@(opt-attr 'description 'description)
|
||
(maintainers
|
||
,(string-join (or (assoc-ref result 'maintainers)
|
||
'())
|
||
", "))
|
||
(maxSilent
|
||
,(number->string (or (assoc-ref result
|
||
'max-silent-time)
|
||
3600)))
|
||
(timeout
|
||
,(number->string (or (assoc-ref result 'timeout)
|
||
72000)))
|
||
(nixName ,(derivation-path->name drv))
|
||
(schedulingPriority
|
||
,(number->string (or (assoc-ref result
|
||
'scheduling-priority)
|
||
10)))
|
||
(system
|
||
,(call-with-input-file drv
|
||
(compose %derivation-system
|
||
(guix-variable 'derivations
|
||
'read-derivation)))))
|
||
;; Resolve Guix modules lazily.
|
||
,(map (match-lambda
|
||
((name . path)
|
||
`(output (@ (name ,name) (path ,path)))))
|
||
((guix-variable 'derivations
|
||
'derivation-path->output-paths)
|
||
drv))
|
||
|
||
"\n"))))
|
||
jobs))))
|
||
|
||
(define* (job-evaluations->xml jobs port
|
||
#:key gc-roots-dir)
|
||
(set-port-encoding! port "UTF-8")
|
||
(sxml->xml (job-evaluations->sxml jobs #:gc-roots-dir gc-roots-dir)
|
||
port))
|
||
|
||
|
||
;;;
|
||
;;; Command-line entry point.
|
||
;;;
|
||
|
||
(define (parse-arguments args)
|
||
"Traverse ARGS, a list of command-line arguments compatible with
|
||
`hydra-eval-jobs', and return the name of the file that defines the jobs, an
|
||
expression that returns the entry point in that file (a unary procedure), the
|
||
list of name/value pairs passed to that entry point, as well as a GC root
|
||
directory or #f."
|
||
(define (module-directory dir)
|
||
(let ((d (string-append dir "/share/guile/site/2.0")))
|
||
(if (file-exists? d)
|
||
d
|
||
dir)))
|
||
|
||
(let loop ((args args)
|
||
(result '())
|
||
(file #f)
|
||
(entry 'hydra-jobs)
|
||
(roots-dir #f))
|
||
(match args
|
||
(()
|
||
(if (not file)
|
||
(error "hydra-eval-guile-jobs: no expression file given")
|
||
(values file entry (reverse result) roots-dir)))
|
||
(("-I" name=dir rest ...)
|
||
(let* ((dir (match (string-tokenize name=dir
|
||
(char-set-complement (char-set
|
||
#\=)))
|
||
((_ dir) dir)
|
||
((dir) dir)))
|
||
(dir* (module-directory dir)))
|
||
(format (current-error-port) "adding `~a' to the load path~%" dir*)
|
||
(set! %load-path (cons dir* %load-path))
|
||
(set! %load-compiled-path (cons dir* %load-compiled-path)))
|
||
(loop rest result file entry roots-dir))
|
||
(("--argstr" name value rest ...)
|
||
(loop rest (alist-cons (string->symbol name) value result)
|
||
file entry roots-dir))
|
||
(("--arg" name expr rest ...)
|
||
(let ((value (eval (call-with-input-string expr read)
|
||
(current-module))))
|
||
(loop rest (alist-cons (string->symbol name) value result)
|
||
file entry roots-dir)))
|
||
(("--gc-roots-dir" dir rest ...)
|
||
(loop rest result file entry dir))
|
||
(("-j" _ rest ...) ; XXX: what's this?
|
||
(loop rest result file entry roots-dir))
|
||
(("--entry" expr rest ...) ; entry point, like `guile -e'
|
||
(let ((expr (call-with-input-string expr read)))
|
||
(loop rest result file expr roots-dir)))
|
||
((file rest ...) ; source file that defines the jobs
|
||
(loop rest result file entry roots-dir))
|
||
(_
|
||
(error "hydra-eval-guile-jobs: invalid arguments" args)))))
|
||
|
||
(define %user-module
|
||
;; Hydra user module.
|
||
;; TODO: Make it a sandbox.
|
||
(let ((m (make-module)))
|
||
(beautify-user-module! m)
|
||
m))
|
||
|
||
(define (eval-guile-jobs . args)
|
||
(setlocale LC_ALL "")
|
||
|
||
(let-values (((file entry args gc-roots-dir)
|
||
(parse-arguments args)))
|
||
|
||
(save-module-excursion
|
||
(lambda ()
|
||
(set-current-module %user-module)
|
||
|
||
;; The standard output must contain only XML.
|
||
(with-output-to-port (%make-void-port "w")
|
||
(lambda ()
|
||
(primitive-load file)))))
|
||
|
||
(let* ((entry (eval entry %user-module))
|
||
(store ((guix-variable 'store 'open-connection)))
|
||
(jobs (entry store args)))
|
||
(unless (string? gc-roots-dir)
|
||
(format (current-error-port)
|
||
"warning: --gc-roots-dir not specified~%"))
|
||
|
||
(job-evaluations->xml jobs (current-output-port)
|
||
#:gc-roots-dir gc-roots-dir))))
|