From 80235450666f25602d039250b36ab0f2782483cc Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 Sep 2017 20:32:31 +0100 Subject: WIP --- examples/cuirass-jobs | 150 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 150 insertions(+) create mode 100755 examples/cuirass-jobs diff --git a/examples/cuirass-jobs b/examples/cuirass-jobs new file mode 100755 index 0000000..34ec892 --- /dev/null +++ b/examples/cuirass-jobs @@ -0,0 +1,150 @@ +#!/usr/bin/guile --no-auto-compile +-*- scheme -*- +!# + +;;;; gnu-system.scm - build jobs for Guix +;;; +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Mathieu Lirzin +;;; +;;; 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 . + +;; 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 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 '()))) -- cgit v1.2.3