208 lines
7.0 KiB
Scheme
208 lines
7.0 KiB
Scheme
(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))
|