#!/bin/sh exec guile --no-auto-compile -e main -s "$0" "$@" !# ;;;; test-driver.scm - Guile test driver for Automake testsuite harness (define script-version "2021-02-02.05") ;UTC ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This program 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. ;;; ;;; This program 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 this program. If not, see . ;;;; Commentary: ;;; ;;; This script provides a Guile test driver using the SRFI-64 Scheme API for ;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9. ;;; ;;;; Code: (use-modules (ice-9 format) (ice-9 getopt-long) (ice-9 pretty-print) (ice-9 regex) (srfi srfi-1) (srfi srfi-19) (srfi srfi-26) (srfi srfi-64)) (define (show-help) (display "Usage: test-driver --test-name=NAME --log-file=PATH --trs-file=PATH [--expect-failure={yes|no}] [--color-tests={yes|no}] [--select=REGEXP] [--exclude=REGEXP] [--errors-only={yes|no}] [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--show-duration={yes|no}] [--] TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS] The '--test-name' option is mandatory. The '--select' and '--exclude' options allow selecting or excluding individual test cases via a regexp, respectively. T
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu bootloader depthcharge)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu bootloader)
  #:use-module (gnu packages bootloaders)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (ice-9 match)
  #:export (depthcharge-bootloader))

(define (signed-kernel kernel kernel-arguments initrd)
  (define builder
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 binary-ports)
                       (rnrs bytevectors))
          (set-path-environment-variable "PATH" '("bin") (list #$dtc))

          ;; TODO: These files have to be writable, so we copy them.
          ;; This can probably be fixed by using a ".its" file, just
          ;; be careful not to break initrd loading.
          (copy-file #$kernel "zImage")
          (chmod "zImage" #o755)
          (copy-file (string-append (dirname #$kernel) "/lib/dtbs/"
                                    "rk3288-veyron-speedy.dtb")
                     "rk3288-veyron-speedy.dtb")
          (chmod "rk3288-veyron-speedy.dtb" #o644)
          (copy-file #$initrd "initrd")
          (chmod "initrd" #o644)

          (invoke (string-append #$u-boot-tools "/bin/mkimage")
                  "-D" "-I dts -O dtb -p 2048"
		  "-f" "auto"
                  "-A" "arm"
                  "-O" "linux"
                  "-T" "kernel"
                  "-C" "None"
                  "-d" "zImage"
                  "-a" "0"
                  "-b" "rk3288-veyron-speedy.dtb"
                  "-i" "initrd"
	          "image.itb")
          (call-with-output-file "bootloader.bin"
            (lambda (port)
              (put-bytevector port (make-bytevector 512 0))))
          (with-output-to-file "kernel-arguments"
	    (lambda ()
	      (display (string-join (list #$@kernel-arguments)))))
          (invoke (string-append #$vboot-utils "/bin/vbutil_kernel")
                  "--pack" #$output
                  "--version" "1"
                  "--vmlinuz" "image.itb"
		  "--arch" "arm"
		  "--keyblock" (string-append #$vboot-utils
                                              "/share/vboot-utils/devkeys/"
                                              "kernel.keyblock")
		  "--signprivate" (string-append #$vboot-utils
                                                 "/share/vboot-utils/devkeys/"
                                                 "kernel_data_key.vbprivk")
                  "--config" "kernel-arguments"
                  "--bootloader" "bootloader.bin"))))
  (computed-file "vmlinux.kpart" builder))

(define* (depthcharge-configuration-file config entries
                                         #:key
                                         (system (%current-system))
                                         (old-entries '())
                                         #:allow-other-keys)
  (match entries
    ((entry)
     (let ((kernel (menu-entry-linux entry))
           (kernel-arguments (menu-entry-linux-arguments entry))
           (initrd (menu-entry-initrd entry)))
       ;; XXX: Make this a symlink.
       (signed-kernel kernel kernel-arguments initrd)))
    (_ (error "Too many bootloader menu entries!"))))

(define install-depthcharge
  #~(lambda (bootloader device mount-point)
      (let ((kpart (string-append mount-point
                                  "/boot/depthcharge/vmlinux.kpart")))
        (write-file-on-device kpart (stat:size (stat kpart)) device 0))))

(define depthcharge-bootloader
  (bootloader
   (name 'depthcharge)
   (package #f)
   (installer install-depthcharge)
   (configuration-file "/boot/depthcharge/vmlinux.kpart")
   (configuration-file-generator depthcharge-configuration-file)))
generated by cgit
esult->string (result 'result-kind))) (newline)) (format trs-port ":test-result: ~A ~A [~,3fs]~%" (result->string (test-result-kind runner)) (test-runner-test-name runner) time-elapsed-seconds))) (define (test-on-group-end-gnu runner) ;; Procedure called by a 'test-end', including at the end of a test-group. (let ((fail (or (positive? (test-runner-fail-count runner)) (positive? (test-runner-xpass-count runner)))) (skip (or (positive? (test-runner-skip-count runner)) (positive? (test-runner-xfail-count runner))))) ;; XXX: The global results need some refinements for XPASS. (format trs-port ":global-test-result: ~A~%" (if fail "FAIL" (if skip "SKIP" "PASS"))) (format trs-port ":recheck: ~A~%" (if fail "yes" "no")) (format trs-port ":copy-in-global-log: ~A~%" (if (or fail skip) "yes" "no")) (when brief? ;; Display the global test group result on the console. (format out-port "~A: ~A~%" (result->string (if fail 'fail (if skip 'skip 'pass)) #:colorize? color?) test-name)) #f)) (let ((runner (test-runner-null))) (test-runner-on-test-begin! runner test-on-test-begin-gnu) (test-runner-on-test-end! runner test-on-test-end-gnu) (test-runner-on-group-end! runner test-on-group-end-gnu) (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) runner)) ;;; ;;; SRFI 64 test specifiers. ;;; (define (test-match-name* regexp) "Return a test specifier that matches a test name against REGEXP." (lambda (runner) (string-match regexp (test-runner-test-name runner)))) (define (test-match-name*/negated regexp) "Return a negated test specifier version of test-match-name*." (lambda (runner) (not (string-match regexp (test-runner-test-name runner))))) ;;; XXX: test-match-all is a syntax, which isn't convenient to use with a list ;;; of test specifiers computed at run time. Copy this SRFI 64 internal ;;; definition here, which is the procedural equivalent of 'test-match-all'. (define (%test-match-all . pred-list) (lambda (runner) (let ((result #t)) (let loop ((l pred-list)) (if (null? l) result (begin (if (not ((car l) runner)) (set! result #f)) (loop (cdr l)))))))) ;;; ;;; Entry point. ;;; (define (main . args) (let* ((opts (getopt-long (command-line) %options)) (option (cut option-ref opts <> <>))) (cond ((option 'help #f) (show-help)) ((option 'version #f) (format #t "test-driver.scm ~A~%" script-version)) (else (let* ((log (and=> (option 'log-file #f) (cut open-file <> "w0"))) (trs (and=> (option 'trs-file #f) (cut open-file <> "wl"))) (out (duplicate-port (current-output-port) "wl")) (test-name (option 'test-name #f)) (select (option 'select #f)) (exclude (option 'exclude #f)) (test-specifiers (filter-map identity (list (and=> select test-match-name*) (and=> exclude test-match-name*/negated)))) (test-specifier (apply %test-match-all test-specifiers)) (color-tests (if (assoc 'color-tests opts) (option->boolean opts 'color-tests) #t))) (when log (redirect-port log (current-output-port)) (redirect-port log (current-warning-port)) (redirect-port log (current-error-port))) (test-with-runner (test-runner-gnu test-name #:color? color-tests #:brief? (option->boolean opts 'brief) #:errors-only? (option->boolean opts 'errors-only) #:show-duration? (option->boolean opts 'show-duration) #:out-port out #:trs-port trs) (test-apply test-specifier (lambda _ (load-from-path test-name)))) (and=> log close-port) (and=> trs close-port) (close-port out)))) (exit 0))) ;;; Local Variables: ;;; eval: (add-hook 'write-file-functions 'time-stamp) ;;; time-stamp-start: "(define script-version \"" ;;; time-stamp-format: "%:y-%02m-%02d.%02H" ;;; time-stamp-time-zone: "UTC" ;;; time-stamp-end: "\") ;UTC" ;;; End: ;;;; test-driver.scm ends here.