;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; 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 (test-syscalls)
  #:use-module (guix utils)
  #:use-module (guix build syscalls)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 popen) #:select (open-pipe*))
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module ((ice-9 regex) #:select (string-match match:substring))
  #:use-module (rnrs bytevectors)
  #:use-module (system foreign)
  #:use-module ((rnrs io ports) #:select (port-eof?)))

;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.

;; Is the first character of a string #\space?
(define-syntax-rule (first-char-is-space? string)
  (eq? #\space (string-ref string 0)))

;; In the output produced by ifconfig (8), is a line
;; one that starts a new interface description?
(define-syntax-rule (line-contains-iface-name? line)
    (not (or (string-null? line)
	     (first-char-is-space? line))))

(define (ifconfig-find-all-interfaces)
  "List all the network interfaces as identified
by ifconfig (8)."
  (let ((pipe (open-pipe* OPEN_READ "ifconfig")))
    (let lp ((line (read-line pipe))
	     (res '()))
      (cond ((port-eof? pipe) (reverse res))
	    ((line-contains-iface-name? line)
	     (let* ((trimmed-line (string-trim-both line))
		    (split-line (string-split trimmed-line #\space))
		    (iface-name (car split-line)))
	       (lp (read-line pipe)
		   (cons iface-name res))))
	    (else (lp (read-line pipe) res))))))

(define (extract-iface-name line)
  "Extract the name of the interface from a line in the output of
ifconfig (8) which is known to be the first line describing said
interface."
  (let ((str-ls (string->list line)))
    (let lp ((ls str-ls) (res '()))
      (if (eq? #\space (car ls))
          (apply string (reverse res))
          (lp (cdr ls) (cons (car ls) res))))))

(define (ifconfig-extract-addr-of iface-name type)
  "Call ifconfig (8) to find out the broadcast address of the
interface whose name is a prefix of the string IFACE-NAME. The
broadcast address is returned as a printable string."
  (let ((pipe (open-pipe* OPEN_READ "ifconfig")))
    (let lp ((line (read-line pipe)))
      (if (eof-object? line)
          #f
          (if (and (line-contains-iface-name? line)
                   (string-prefix? iface-name
                                   (extract-iface-name line)))
              (let* ((next-line (read-line pipe))
                     (search-string (cond ((eq? type 'broadcast) "Bcast:")
                                          ((eq? type 'netmask) "Mask:")
                                          (else "inet addr:")))
                     (str-byte "[0-9]([0-9][0-9])?")
                     (ipaddr-regex (string-append search-string
                                                   str-byte "\\."
                                                   str-byte "\\."
                                                   str-byte "\\."
                                                   str-byte))
                     (match (string-match ipaddr-regex next-line)))
                (if match
                    (string-drop (match:substring match) (cond ((eq? type 'broadcast) 6)
                                                               ((eq? type 'netmask) 5)
                                                               (else 10)))
                    (lp (read-line pipe))))
              (lp (read-line pipe)))))))

(define (prefix? ls1 ls2)
  "Is list LS1 a prefix of list LS2?. This procedure
assumes that (length ls1) <= (length ls2)."
  (or (null? ls1)
      (and (equal? (car ls1) (car ls2))
	   (prefix? (cdr ls1) (cdr ls2)))))

(define (remove-duplicates ls)
  "Remove consecutive duplicate elements from a list LS.
For example, (4 2 2 2 2 1 3 3) => (4 2 1 3)."
  (cond ((< (length ls) 2)
         ls)
        ((equal? (car ls) (cadr ls))
         (remove-duplicates (cdr ls)))
        (else
         (cons (car ls) (remove-duplicates (cdr ls))))))

(test-begin "syscalls")

(test-equal "mount, ENOENT"
  ENOENT
  (catch 'system-error
    (lambda ()
      (mount "/dev/null" "/does-not-exist" "ext2")
      #f)
    (compose system-error-errno list)))

(test-assert "umount, ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (umount "/does-not-exist")
      #f)
    (lambda args
      ;; Both return values have been encountered in the wild.
      (memv (system-error-errno args) (list EPERM ENOENT)))))

(test-assert "mount-points"
  ;; Reportedly "/" is not always listed as a mount point, so check a few
  ;; others (see <http://bugs.gnu.org/20261>.)
  (any (cute member <> (mount-points))
       '("/" "/proc" "/sys" "/dev")))

(test-assert "swapon, ENOENT/EPERM"
  (catch 'system-error
    (lambda ()
      (swapon "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM ENOENT)))))

(test-assert "swapoff, ENOENT/EINVAL/EPERM"
  (catch 'system-error
    (lambda ()
      (swapoff "/does-not-exist")
      #f)
    (lambda args
      (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))

(test-assert "mkdtemp!"
  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
         (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
    (and (file-exists? dir)
         (begin
           (rmdir dir)
           #t))))

(define (user-namespace pid)
  (string-append "/proc/" (number->string pid) "/ns/user"))

(unless (file-exists? (user-namespace (getpid)))
  (test-skip 1))
(test-assert "clone"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 42))
    (pid
     ;; Check if user namespaces are different.
     (and (not (equal? (readlink (user-namespace pid))
                       (readlink (user-namespace (getpid)))))
          (match (waitpid pid)
            ((_ . status)
             (= 42 (status:exit-val status))))))))

(unless (file-exists? (user-namespace (getpid)))
  (test-skip 1))
(test-assert "setns"
  (match (clone (logior CLONE_NEWUSER SIGCHLD))
    (0 (primitive-exit 0))
    (clone-pid
     (match (pipe)
       ((in . out)
        (match (primitive-fork)
          (0
           (close in)
           ;; Join the user namespace.
           (call-with-input-file (user-namespace clone-pid)
             (lambda (port)
               (setns (port->fdes port) 0)))
           (write 'done out)
           (close out)
           (primitive-exit 0))
          (fork-pid
           (close out)
           ;; Wait for the child process to join the namespace.
           (read in)
           (let ((result (and (equal? (readlink (user-namespace clone-pid))
                                      (readlink (user-namespace fork-pid))))))
             ;; Clean up.
             (waitpid clone-pid)
             (waitpid fork-pid)
             result))))))))

(unless (file-exists? (user-namespace (getpid)))
  (test-skip 1))
(test-assert "pivot-root"
  (match (pipe)
    ((in . out)
     (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
       (0
        (close in)
        (call-with-temporary-directory
         (lambda (root)
           (let ((put-old (string-append root "/real-root")))
             (mount "none" root "tmpfs")
             (mkdir put-old)
             (call-with-output-file (string-append root "/test")
               (lambda (port)
                 (display "testing\n" port)))
             (pivot-root root put-old)
             ;; The test file should now be located inside the root directory.
             (write (file-exists? "/test") out)
             (close out))))
        (primitive-exit 0))
       (pid
        (close out)
        (let ((result (read in)))
          (close in)
          (and (zero? (match (waitpid pid)
                        ((_ . status)
                         (status:exit-val status))))
               (eq? #t result))))))))

(test-assert "all-network-interfaces"
  (match (all-network-interfaces)
    (((? string? names) ..1)
     (member "lo" names))))

(test-assert "network-interfaces"
  (match (network-interfaces)
    (((? string? names) ..1)
     (lset<= string=? names (all-network-interfaces)))))

(test-assert "network-interface-flags"
  (let* ((sock  (socket AF_INET SOCK_STREAM 0))
         (flags (network-interface-flags sock "lo")))
    (close-port sock)
    (and (not (zero? (logand flags IFF_LOOPBACK)))
         (not (zero? (logand flags IFF_UP))))))

(test-equal "loopback-network-interface?"
  ENODEV
  (and (loopback-network-interface? "lo")
       (catch 'system-error
         (lambda ()
           (loopback-network-interface? "nonexistent")
           #f)
         (lambda args
           (system-error-errno args)))))

(test-skip (if (zero? (getuid)) 1 0))
(test-assert "set-network-interface-flags"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-flags sock "lo" IFF_UP))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-equal "network-interface-address lo"
  (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
  (let* ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (network-interface-address sock "lo")))
    (close-port sock)
    addr))

(test-assert "set-network-interface-address"
  (let ((sock (socket AF_INET SOCK_STREAM 0)))
    (catch 'system-error
      (lambda ()
        (set-network-interface-address sock "nonexistent"
                                       (make-socket-address
                                        AF_INET
                                        (inet-pton AF_INET "127.12.14.15")
                                        0)))
      (lambda args
        (close-port sock)
        ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
        (memv (system-error-errno args) (list EPERM EACCES))))))

(test-assert "getifaddrs"
             (let* ((ifaddrs (getifaddrs))
                    (names (map interface-address-name ifaddrs)))
               (member "lo" names)))

(test-assert "ifconfig-result-is-subset-of-getifaddrs-result"
             (let* ((ifaddrs (getifaddrs))
                    (names (map interface-address-name ifaddrs))
                    (sorted-names (sort names string<?))
                    (unique-names (remove-duplicates sorted-names))
                    (ifconfig (ifconfig-find-all-interfaces)))
               (prefix?
                (sort (ifconfig-find-all-interfaces) string<?)
                unique-names)))

(test-assert "getifaddrs-address"
             (let* ((is-eth-iface? (lambda (i)
                                     (string-prefix? "eth"
                                                     (interface-address-name i))))
                    (ifaddrs (remove-if-netmask-null (getifaddrs)))
                    (eth-ifaces (filter is-eth-iface? ifaddrs))
                    (getifaddrs-result (map interface-address-address eth-ifaces))
                    (ifconfig-result (ifconfig-extract-addr-of "eth" 'address)))
               (member ifconfig-result getifaddrs-result)))

(test-assert "getifaddrs-broadcast-address"
             (let* ((is-eth-iface? (lambda (i)
                                     (string-prefix? "eth"
                                                     (interface-address-name i))))
                    (ifaddrs (remove-if-netmask-null (getifaddrs)))
                    (eth-ifaces (filter is-eth-iface? ifaddrs))
                    (getifaddrs-result (map interface-address-broadcast-addr eth-ifaces))
                    (ifconfig-result (ifconfig-extract-addr-of "eth" 'broadcast)))
               (member ifconfig-result getifaddrs-result)))

(test-assert "getifaddrs-netmask-address"
             (let* ((is-eth-iface? (lambda (i)
                                     (string-prefix? "eth"
                                                     (interface-address-name i))))
                    (ifaddrs (remove-if-netmask-null (getifaddrs)))
                    (eth-ifaces (filter is-eth-iface? ifaddrs))
                    (getifaddrs-result (map interface-address-netmask-addr eth-ifaces))
                    (ifconfig-result (ifconfig-extract-addr-of "eth" 'netmask)))
               (member ifconfig-result getifaddrs-result)))

(test-end)

\f
(exit (= (test-runner-fail-count (test-runner-current)) 0))