Commit | Line | Data |
---|---|---|
89cbec89 | 1 | ;;; GNU Guix --- Functional package management for GNU |
66a198c8 | 2 | ;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> |
454caca8 | 3 | ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> |
89cbec89 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; This program replicates the behavior of Hydra's 'hydra-eval-guile-job'. | |
21 | ;;; It evaluates the Hydra job defined by the program passed as its first | |
22 | ;;; arguments and outputs an sexp of the jobs on standard output. | |
23 | ||
24 | (use-modules (guix store) | |
65ff85dc LC |
25 | (guix git-download) |
26 | ((guix build utils) #:select (with-directory-excursion)) | |
66a198c8 | 27 | ((guix ui) #:select (build-notifier)) |
89cbec89 LC |
28 | (srfi srfi-19) |
29 | (ice-9 match) | |
30 | (ice-9 pretty-print) | |
31 | (ice-9 format)) | |
32 | ||
49961951 LC |
33 | (define %top-srcdir |
34 | (and=> (assq-ref (current-source-location) 'filename) | |
35 | (lambda (file) | |
36 | (canonicalize-path | |
37 | (string-append (dirname file) "/../.."))))) | |
38 | ||
89cbec89 LC |
39 | (define %user-module |
40 | ;; Hydra user module. | |
41 | (let ((m (make-module))) | |
42 | (beautify-user-module! m) | |
43 | m)) | |
44 | ||
45 | (define (call-with-time thunk kont) | |
46 | "Call THUNK and pass KONT the elapsed time followed by THUNK's return | |
47 | values." | |
48 | (let* ((start (current-time time-monotonic)) | |
49 | (result (call-with-values thunk list)) | |
50 | (end (current-time time-monotonic))) | |
51 | (apply kont (time-difference end start) result))) | |
52 | ||
53 | (define (call-with-time-display thunk) | |
54 | "Call THUNK and write to the current output port its duration." | |
55 | (call-with-time thunk | |
56 | (lambda (time . results) | |
57 | (format #t "~,3f seconds~%" | |
58 | (+ (time-second time) | |
59 | (/ (time-nanosecond time) 1e9))) | |
60 | (apply values results)))) | |
61 | ||
4c9243b6 LC |
62 | (define (assert-valid-job job thing) |
63 | "Raise an error if THING is not an alist with a valid 'derivation' entry. | |
64 | Otherwise return THING." | |
65 | (unless (and (list? thing) | |
66 | (and=> (assoc-ref thing 'derivation) | |
67 | (lambda (value) | |
68 | (and (string? value) | |
69 | (string-suffix? ".drv" value))))) | |
70 | (error "job did not produce a valid alist" job thing)) | |
71 | thing) | |
72 | ||
89cbec89 LC |
73 | \f |
74 | ;; Without further ado... | |
75 | (match (command-line) | |
454caca8 | 76 | ((command file cuirass? ...) |
89cbec89 | 77 | ;; Load FILE, a Scheme file that defines Hydra jobs. |
9fe95946 LC |
78 | (let ((port (current-output-port)) |
79 | (real-build-things build-things)) | |
89cbec89 LC |
80 | (with-store store |
81 | ;; Make sure we don't resort to substitutes. | |
82 | (set-build-options store | |
83 | #:use-substitutes? #f | |
84 | #:substitute-urls '()) | |
85 | ||
66a198c8 LC |
86 | ;; The evaluation of Guix itself requires building a "trampoline" |
87 | ;; program, and possibly everything it depends on. Thus, allow builds | |
88 | ;; but print a notification. | |
89 | (with-build-handler (build-notifier #:use-substitutes? #f) | |
89cbec89 | 90 | |
66a198c8 LC |
91 | ;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work |
92 | ;; from a clean checkout | |
93 | (let ((source (add-to-store store "guix-source" #t | |
94 | "sha256" %top-srcdir | |
95 | #:select? (git-predicate %top-srcdir)))) | |
96 | (with-directory-excursion source | |
97 | (save-module-excursion | |
98 | (lambda () | |
99 | (set-current-module %user-module) | |
100 | (format (current-error-port) | |
101 | "loading '~a' relative to '~a'...~%" | |
102 | file source) | |
103 | (primitive-load file)))) | |
65ff85dc | 104 | |
66a198c8 LC |
105 | ;; Call the entry point of FILE and print the resulting job sexp. |
106 | (pretty-print | |
107 | (match ((module-ref %user-module | |
108 | (if (equal? cuirass? "cuirass") | |
109 | 'cuirass-jobs | |
110 | 'hydra-jobs)) | |
111 | store `((guix | |
112 | . ((file-name . ,source))))) | |
113 | (((names . thunks) ...) | |
114 | (map (lambda (job thunk) | |
115 | (format (current-error-port) "evaluating '~a'... " job) | |
116 | (force-output (current-error-port)) | |
117 | (cons job | |
118 | (assert-valid-job job | |
119 | (call-with-time-display thunk)))) | |
120 | names thunks))) | |
121 | port)))))) | |
89cbec89 | 122 | ((command _ ...) |
454caca8 JN |
123 | (format (current-error-port) "Usage: ~a FILE [cuirass] |
124 | Evaluate the Hydra or Cuirass jobs defined in FILE.~%" | |
89cbec89 LC |
125 | command) |
126 | (exit 1))) | |
127 | ||
128 | ;;; Local Variables: | |
129 | ;;; eval: (put 'call-with-time 'scheme-indent-function 1) | |
130 | ;;; End: | |
131 |