(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))