1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
#!/usr/bin/guile --no-auto-compile
-*- scheme -*-
!#
;;;; gnu-system.scm - build jobs for Guix
;;;
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of Cuirass.
;;;
;;; Cuirass 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.
;;;
;;; Cuirass 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 Cuirass. If not, see <http://www.gnu.org/licenses/>.
;; Attempt to use Guix modules from git repository.
(eval-when (compile load eval)
;; Ignore any available .go, and force recompilation. This is because our
;; checkout in the store has mtime set to the epoch, and thus .go files look
;; newer, even though they may not correspond.
(set! %fresh-auto-compile #t))
(use-modules (guix config)
(guix store)
(ice-9 pretty-print)
(srfi srfi-19)
(srfi srfi-34)
(srfi srfi-35)
(guix grafts)
(guix packages)
(guix derivations)
(guix discovery)
(guix monads)
((guix licenses)
#:select (gpl3+ license-name license-uri license-comment))
((guix utils) #:select (%current-system))
((guix scripts system) #:select (read-operating-system))
(gnu packages)
(gnu packages commencement)
(gnu packages guile)
(gnu packages make-bootstrap)
(gnu system)
(gnu system vm)
(gnu system install)
(srfi srfi-1)
(ice-9 match))
(define (license->alist lcs)
"Return LCS <license> object as an alist."
;; Sometimes 'license' field is a list of licenses.
(if (list? lcs)
(map license->alist lcs)
`((name . ,(license-name lcs))
(uri . ,(license-uri lcs))
(comment . ,(license-comment lcs)))))
(define (package-metadata package)
"Convert PACKAGE to an alist suitable for Hydra."
`((#:description . ,(package-synopsis package))
(#:long-description . ,(package-description package))
;; (#:license . ,(and=> (package-license package)
;; license->alist))
(#:home-page . ,(package-home-page package))
(#:maintainers . ("govuk-developers"))
(#:max-silent-time . ,(or (assoc-ref (package-properties package)
'max-silent-time)
3600)) ;1 hour by default
(#:timeout . ,(or (assoc-ref (package-properties package) 'timeout)
72000)))) ;20 hours by default
(define (package-job store job-name package system)
"Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
(lambda ()
`((#:job-name . ,(string-append (symbol->string job-name) "." system))
(#:derivation . ,(derivation-file-name
(parameterize ((%graft? #f))
(package-derivation store package system
#:graft? #f))))
,@(package-metadata package))))
(define %job-name
;; Return the name of a package's job.
(compose string->symbol package-full-name))
(define (package->job store package system)
(package-job store (%job-name package) package system))
(define (fold-packages-in-modules modules proc init)
"Call (PROC PACKAGE RESULT) for each available package within any of the
modules in MODULES, using INIT as the initial value of RESULT. It is
guaranteed to never traverse the same package twice."
(fold-module-public-variables (lambda (object result)
(if (and (package? object)
(not (hidden-package? object)))
(proc object result)
result))
init
modules))
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
(let* ((start (current-time time-monotonic))
(result (call-with-values thunk list))
(end (current-time time-monotonic)))
(apply kont (time-difference end start) result)))
(define (call-with-time-display thunk)
"Call THUNK and write to the current output port its duration."
(call-with-time thunk
(lambda (time result)
(let ((duration (+ (time-second time)
(/ (time-nanosecond time) 1e9))))
(format (current-error-port) "evaluate '~A': ~,3f seconds~%"
(assq-ref result #:job-name)
duration)
(acons #:duration duration result)))))
(define (gov.uk-jobs store arguments)
(parameterize ((%graft? #f))
(let ((pkgs (fold-packages-in-modules
(all-modules (list
(string-append
(getcwd)
"/.guix-package-path")))
cons
'())))
(filter-map (lambda (pkg)
(package->job store pkg "x86_64-linux"))
pkgs))))
(define (output-jobs thunks)
(pretty-print
(map (lambda (thunk)
(call-with-time-display thunk))
thunks)
(current-output-port)))
(with-store store
(output-jobs
(gov.uk-jobs store '())))
|