Add FreeBSD Guile verification harness
This commit is contained in:
25
tests/guile/modules/phase1/sample.scm
Normal file
25
tests/guile/modules/phase1/sample.scm
Normal file
@@ -0,0 +1,25 @@
|
||||
(define-module (phase1 sample)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-13)
|
||||
#:export (sample-message deterministic-payload))
|
||||
|
||||
(define (sample-message)
|
||||
"sample-module-ok")
|
||||
|
||||
(define (deterministic-payload)
|
||||
(let* ((pairs '((gamma . 3) (alpha . 1) (beta . 2)))
|
||||
(sorted (sort pairs (lambda (a b)
|
||||
(string<? (symbol->string (car a))
|
||||
(symbol->string (car b))))))
|
||||
(sum (apply + (map (lambda (pair)
|
||||
(* (cdr pair) (cdr pair)))
|
||||
sorted))))
|
||||
(string-append
|
||||
(string-join
|
||||
(map (lambda (pair)
|
||||
(string-append (symbol->string (car pair))
|
||||
"="
|
||||
(number->string (cdr pair))))
|
||||
sorted)
|
||||
";")
|
||||
";sum=" (number->string sum))))
|
||||
30
tests/guile/run-phase1-verification.sh
Executable file
30
tests/guile/run-phase1-verification.sh
Executable file
@@ -0,0 +1,30 @@
|
||||
#!/bin/sh
|
||||
set -eu
|
||||
|
||||
script_dir=$(CDPATH= cd -- "$(dirname "$0")" && pwd)
|
||||
repo_root=$(CDPATH= cd -- "$script_dir/../.." && pwd)
|
||||
guix_source_dir=${GUIX_SOURCE_DIR:-"$HOME/repos/guix"}
|
||||
|
||||
if [ ! -d "$guix_source_dir/guix" ]; then
|
||||
echo "Guix source tree not found at $guix_source_dir" >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
if command -v guile3 >/dev/null 2>&1; then
|
||||
guile_bin=$(command -v guile3)
|
||||
elif command -v guile-3.0 >/dev/null 2>&1; then
|
||||
guile_bin=$(command -v guile-3.0)
|
||||
else
|
||||
echo "Unable to find guile3 or guile-3.0 in PATH" >&2
|
||||
exit 1
|
||||
fi
|
||||
|
||||
export GUIX_SOURCE_DIR="$guix_source_dir"
|
||||
export GUILE_AUTO_COMPILE=${GUILE_AUTO_COMPILE:-0}
|
||||
if [ -n "${GUILE_LOAD_PATH:-}" ]; then
|
||||
export GUILE_LOAD_PATH="$repo_root/tests/guile/modules:$guix_source_dir:$GUILE_LOAD_PATH"
|
||||
else
|
||||
export GUILE_LOAD_PATH="$repo_root/tests/guile/modules:$guix_source_dir"
|
||||
fi
|
||||
|
||||
exec "$guile_bin" -s "$repo_root/tests/guile/verify-phase1.scm" "$@"
|
||||
207
tests/guile/verify-phase1.scm
Normal file
207
tests/guile/verify-phase1.scm
Normal file
@@ -0,0 +1,207 @@
|
||||
(use-modules (ice-9 format)
|
||||
(ice-9 rdelim)
|
||||
(ice-9 textual-ports)
|
||||
(ice-9 threads)
|
||||
(system foreign)
|
||||
(phase1 sample)
|
||||
(guix build make-bootstrap))
|
||||
|
||||
(setvbuf (current-output-port) 'line)
|
||||
|
||||
(define %bootstrap-linux-headers
|
||||
'("atalk.h"
|
||||
"errno.h"
|
||||
"falloc.h"
|
||||
"if_addr.h"
|
||||
"if_ether.h"
|
||||
"if_link.h"
|
||||
"ioctl.h"
|
||||
"kernel.h"
|
||||
"limits.h"
|
||||
"neighbour.h"
|
||||
"netlink.h"
|
||||
"param.h"
|
||||
"prctl.h"
|
||||
"posix_types.h"
|
||||
"rtnetlink.h"
|
||||
"socket.h"
|
||||
"stddef.h"
|
||||
"swab.h"
|
||||
"sysctl.h"
|
||||
"sysinfo.h"
|
||||
"types.h"
|
||||
"version.h"))
|
||||
|
||||
(define %failures 0)
|
||||
|
||||
(define (check name thunk)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(thunk)
|
||||
(format #t "PASS ~a~%" name))
|
||||
(lambda (key . args)
|
||||
(set! %failures (+ %failures 1))
|
||||
(format #t "FAIL ~a~%" name)
|
||||
(format #t " key: ~s~%" key)
|
||||
(format #t " args: ~s~%" args))))
|
||||
|
||||
(define (ensure condition message . args)
|
||||
(unless condition
|
||||
(apply error message args)))
|
||||
|
||||
(define (read-file path)
|
||||
(call-with-input-file path get-string-all))
|
||||
|
||||
(define (write-file path content)
|
||||
(call-with-output-file path
|
||||
(lambda (port)
|
||||
(display content port))))
|
||||
|
||||
(define (make-tempdir prefix)
|
||||
(mkdtemp (string-copy (string-append "/tmp/" prefix "-XXXXXX"))))
|
||||
|
||||
(define (mkdir-p path)
|
||||
(let loop ((parts (string-split path #\/))
|
||||
(current ""))
|
||||
(when (pair? parts)
|
||||
(let* ((part (car parts))
|
||||
(next (cond
|
||||
((string-null? part)
|
||||
"/")
|
||||
((or (string=? current "")
|
||||
(string=? current "/"))
|
||||
(string-append current part))
|
||||
(else
|
||||
(string-append current "/" part)))))
|
||||
(unless (or (string-null? part)
|
||||
(file-exists? next))
|
||||
(mkdir next))
|
||||
(loop (cdr parts) next)))))
|
||||
|
||||
(define (touch path content)
|
||||
(let ((slash (string-rindex path #\/)))
|
||||
(when slash
|
||||
(mkdir-p (substring path 0 slash)))
|
||||
(write-file path content)))
|
||||
|
||||
(define (test-module-system)
|
||||
(ensure (string=? (sample-message) "sample-module-ok")
|
||||
"unexpected module message: ~s"
|
||||
(sample-message)))
|
||||
|
||||
(define (test-deterministic-output)
|
||||
(ensure (string=? (deterministic-payload)
|
||||
"alpha=1;beta=2;gamma=3;sum=14")
|
||||
"unexpected deterministic payload: ~s"
|
||||
(deterministic-payload)))
|
||||
|
||||
(define (test-file-io)
|
||||
(let* ((dir (make-tempdir "fruix-guile-fileio"))
|
||||
(path (string-append dir "/payload.txt"))
|
||||
(payload "freebsd-guile-file-io-ok\nline-2\n"))
|
||||
(write-file path payload)
|
||||
(ensure (string=? (read-file path) payload)
|
||||
"file payload mismatch for ~a"
|
||||
path)))
|
||||
|
||||
(define (test-processes)
|
||||
(let* ((dir (make-tempdir "fruix-guile-process"))
|
||||
(path (string-append dir "/child.txt")))
|
||||
(force-output (current-output-port))
|
||||
(let ((pid (primitive-fork)))
|
||||
(if (zero? pid)
|
||||
(begin
|
||||
(write-file path "child-process-ok\n")
|
||||
(primitive-exit 0))
|
||||
(let ((status (cdr (waitpid pid))))
|
||||
(ensure (= 0 (status:exit-val status))
|
||||
"child exited with status ~a"
|
||||
(status:exit-val status))
|
||||
(ensure (string=? (read-file path) "child-process-ok\n")
|
||||
"child file payload mismatch"))))))
|
||||
|
||||
(define (test-sockets)
|
||||
(let* ((server (socket AF_INET SOCK_STREAM 0)))
|
||||
(setsockopt server SOL_SOCKET SO_REUSEADDR 1)
|
||||
(bind server AF_INET INADDR_LOOPBACK 0)
|
||||
(listen server 1)
|
||||
(let* ((port (sockaddr:port (getsockname server)))
|
||||
(thread (call-with-new-thread
|
||||
(lambda ()
|
||||
(let* ((accepted (accept server))
|
||||
(conn (car accepted))
|
||||
(line (read-line conn)))
|
||||
(display line conn)
|
||||
(newline conn)
|
||||
(force-output conn)
|
||||
(close-port conn)
|
||||
(close-port server))))))
|
||||
(let ((client (socket AF_INET SOCK_STREAM 0)))
|
||||
(connect client AF_INET INADDR_LOOPBACK port)
|
||||
(display "socket-roundtrip-ok" client)
|
||||
(newline client)
|
||||
(force-output client)
|
||||
(ensure (string=? (read-line client) "socket-roundtrip-ok")
|
||||
"socket roundtrip mismatch")
|
||||
(close-port client)
|
||||
(join-thread thread)))))
|
||||
|
||||
(define (test-ffi)
|
||||
(let* ((libc (dynamic-link))
|
||||
(ffi-getpid (pointer->procedure int
|
||||
(dynamic-func "getpid" libc)
|
||||
'())))
|
||||
(ensure (= (getpid) (ffi-getpid))
|
||||
"FFI getpid mismatch: Guile=~a FFI=~a"
|
||||
(getpid)
|
||||
(ffi-getpid))))
|
||||
|
||||
(define (test-guix-bootstrap)
|
||||
(let* ((dir (make-tempdir "fruix-guix-bootstrap"))
|
||||
(kernel-headers (string-append dir "/kernel-headers"))
|
||||
(output (string-append dir "/output")))
|
||||
(mkdir-p (string-append kernel-headers "/include/linux/byteorder"))
|
||||
(mkdir-p (string-append kernel-headers "/include/asm"))
|
||||
(mkdir-p (string-append kernel-headers "/include/asm-generic"))
|
||||
(for-each (lambda (header)
|
||||
(touch (string-append kernel-headers "/include/linux/" header)
|
||||
(string-append "/* " header " */\n")))
|
||||
%bootstrap-linux-headers)
|
||||
(touch (string-append kernel-headers "/include/asm/signal.h") "/* asm */\n")
|
||||
(touch (string-append kernel-headers "/include/asm-generic/errno-base.h") "/* asm-generic */\n")
|
||||
(touch (string-append kernel-headers "/include/linux/byteorder/little_endian.h")
|
||||
"/* byteorder */\n")
|
||||
(let ((sink (open-output-string)))
|
||||
(parameterize ((current-output-port sink)
|
||||
(current-error-port sink))
|
||||
(ensure (copy-linux-headers output kernel-headers)
|
||||
"copy-linux-headers returned false")))
|
||||
(ensure (file-exists? (string-append output "/include/linux/errno.h"))
|
||||
"missing copied linux header")
|
||||
(ensure (file-exists? (string-append output "/include/asm/signal.h"))
|
||||
"missing copied asm header")
|
||||
(ensure (file-exists? (string-append output "/include/linux/byteorder/little_endian.h"))
|
||||
"missing copied byteorder header")))
|
||||
|
||||
(define (run-suite)
|
||||
(format #t "Environment:~%")
|
||||
(format #t " GUIX_SOURCE_DIR=~a~%" (or (getenv "GUIX_SOURCE_DIR") "<unset>"))
|
||||
(format #t " GUILE_LOAD_PATH=~a~%" (or (getenv "GUILE_LOAD_PATH") "<unset>"))
|
||||
(check "module-system" test-module-system)
|
||||
(check "deterministic-output" test-deterministic-output)
|
||||
(check "file-io" test-file-io)
|
||||
(check "process-fork/wait" test-processes)
|
||||
(check "loopback-socket" test-sockets)
|
||||
(check "ffi-getpid" test-ffi)
|
||||
(check "guix-build-make-bootstrap/copy-linux-headers" test-guix-bootstrap)
|
||||
(format #t "Summary: ~a failure(s)~%" %failures)
|
||||
(exit %failures))
|
||||
|
||||
(define (main args)
|
||||
(if (member "--deterministic-payload" (cdr args))
|
||||
(begin
|
||||
(display (deterministic-payload))
|
||||
(newline))
|
||||
(run-suite)))
|
||||
|
||||
(main (command-line))
|
||||
Reference in New Issue
Block a user