;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.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 (gnu tests base)
  #:use-module (gnu tests)
  #:use-module (gnu system)
  #:use-module (gnu system shadow)
  #:use-module (gnu system nss)
  #:use-module (gnu system vm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services dbus)
  #:use-module (gnu services avahi)
  #:use-module (gnu services mcron)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services networking)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages imagemagick)
  #:use-module (gnu packages ocr)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages tmux)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (run-basic-test
            %test-basic-os
            %test-halt
            %test-cleanup
            %test-mcron
            %test-nss-mdns))

(define %simple-os
  (simple-operating-system))


(define* (run-basic-test os command #:optional (name "basic")
                         #:key
                         initialization
                         root-password
                         desktop?)
  "Return a derivation called NAME that tests basic features of the OS started
using COMMAND, a gexp that evaluates to a list of strings.  Compare some
properties of running system to what's declared in OS, an <operating-system>.

When INITIALIZATION is true, it must be a one-argument procedure that is
passed a gexp denoting the marionette, and it must return gexp that is
inserted before the first test.  This is used to introduce an extra
initialization step, such as entering a LUKS passphrase.

When ROOT-PASSWORD is true, enter it as the root password when logging in.
Otherwise assume that there is no password for root."
  (define special-files
    (service-value
     (fold-services (operating-system-services os)
                    #:target-type special-files-service-type)))

  (define guix&co
    (match (package-transitive-propagated-inputs guix)
      (((labels packages) ...)
       (cons guix packages))))

  (define test
    (with-imported-modules '((gnu build marionette)
                             (guix build syscalls))
      #~(begin
          (use-modules (gnu build marionette)
                       (guix build syscalls)
                       (srfi srfi-1)
                       (srfi srfi-19)
                       (srfi srfi-26)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette #$command))

          (test-runner-current (system-test-runner #$output))
          (test-begin "basic")

          #$(and initialization
                 (initialization #~marionette))

          (test-assert "uname"
            (match (marionette-eval '(uname) marionette)
              (#("Linux" host-name version _ architecture)
               (and (string=? host-name
                              #$(operating-system-host-name os))
                    (string-prefix? #$(package-version
                                       (operating-system-kernel os))
                                    version)
                    (string-prefix? architecture %host-type)))))

          ;; Shepherd reads the config file *before* binding its control
          ;; socket, so /var/run/shepherd/socket might not exist yet when the
          ;; 'marionette' service is started.
          (test-assert "shepherd socket ready"
            (marionette-eval
             `(begin
                (use-modules (gnu services herd))
                (let loop ((i 10))
                  (cond ((file-exists? (%shepherd-socket-file))
                         #t)
                        ((> i 0)
                         (sleep 1)
                         (loop (- i 1)))
                        (else
                         #f))))
             marionette))

          (test-eq "stdin is /dev/null"
            'eof
            ;; Make sure services can no longer read from stdin once the
            ;; system has booted.
            (marionette-eval
             `(begin
                (use-modules (gnu services herd))
                (start 'user-processe<tr class='logheader'><td><span title='2018-07-01 14:34:42 +0800'>2018-07-01</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=5ffc17d4aa36c40a4d5ebe558edbc734b45ca1dc'>fix corner case in `unused`</a></td><td>alexlamsl</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2018-03-15 15:46:45 +0800'>2018-03-15</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=b29d435bb5bc4d883a23efaabd76e95092352b6c'>refactor brackets to braces (#3005)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2018-02-12 23:28:28 +0800'>2018-02-12</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=0809699bdc7b1c249c7bbe02924a4a861aff8bea'>simplify `do-while` into `for` (#2907)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
fixes #2904

</td></tr>
<tr class='logheader'><td><span title='2018-01-08 14:30:18 +0800'>2018-01-08</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=ce27bcd69a0a66bf145ee2f14927a3cfec9b0202'>compress loops with immediate `break` (#2746)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
fixes #2740

</td></tr>
<tr class='logheader'><td><span title='2017-12-02 15:46:05 +0800'>2017-12-02</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=77332a03153285f5e521c99c3b5d796bf5698ef7'>fix `dead_code` on `for` (#2552)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2017-12-01 12:53:59 +0800'>2017-12-01</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=f6610baaa8c5c6acf8f4a52babf68d0439aead1f'>improve `AST_For.init` &amp; `AST_Switch.expression` compression (#2546)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2017-12-01 05:52:33 +0800'>2017-12-01</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=b762f2d6f4e81dcbd49ffb4db4b1933953942999'>improve compression of loop conditions (#2543)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2017-07-03 04:17:37 +0800'>2017-07-03</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=af0262b7e5fd3dbf83619cdb375ab18c41def3e7'>improve parenthesis emission (#2196)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- eliminate `throw` usages
- suppress extraneous parenthesis
  - `new function() {foo.bar()}.baz`
  - `for (function() { "foo" in bar; };;);`

</td></tr>
<tr class='logheader'><td><span title='2017-05-12 14:57:41 +0800'>2017-05-12</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=c391576d52852322a7fcfbaeabc9d5626e628c8b'>remove support for `const` (#1910)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
As this is not part of ES5.

</td></tr>
<tr class='logheader'><td><span title='2017-04-15 23:50:50 +0800'>2017-04-15</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=ec443e422c220619fe671166e467d3d8838b0cab'>unify CLI &amp; API under `minify()` (#1811)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- rename `screw_ie8` to `ie8`
- rename `mangle.except` to `mangle.reserved`
- rename `mangle.properties.ignore_quoted` to `mangle.properties.keep_quoted` 
- compact `sourceMap` options
- more stringent verification on input `options`
- toplevel shorthands
  - `ie8`
  - `keep_fnames`
  - `toplevel`
  - `warnings`
- support arrays and unquoted string values on CLI
- drop `fromString` from `minify()`
  - `minify()` no longer handles any `fs` operations
- unify order of operations for `mangle_properties()` on CLI &amp; API
  - `bin/uglifyjs` used to `mangle_properties()` before even `Compressor`
  - `minify()` used to `mangle_properties()` after `Compressor` but before `mangle_names()`
  - both will now do `Compressor`, `mangle_names()` then `mangle_properties()`
- `options.parse` / `--parse` for parser options beyond `bare_returns`
- add `mangle.properties.builtins` to disable built-in reserved list
  - disable with `--mangle-props builtins` on CLI
- `warnings` now off by default
- add `--warn` and `--verbose` on CLI
- drop `--enclose`
- drop `--export-all`
- drop `--reserved-file`
  - use `--mangle reserved` instead
- drop `--reserve-domprops`
  - enabled by default, disable with `--mangle-props domprops`
- drop `--prefix`
  - use `--source-map base` instead
- drop `--lint`
- remove `bin/extract-props.js`
- limit exposure of internal APIs
- update documentations

closes #96
closes #102
closes #136
closes #166
closes #243
closes #254
closes #261
closes #311
closes #700
closes #748
closes #912
closes #1072
closes #1366
fixes #101
fixes #123
fixes #124
fixes #263
fixes #379
fixes #419
fixes #423
fixes #461
fixes #465
fixes #576
fixes #737
fixes #772
fixes #958
fixes #1036
fixes #1142
fixes #1175
fixes #1220
fixes #1223
fixes #1280
fixes #1359
fixes #1368

</td></tr>
<tr class='logheader'><td><span title='2017-04-04 23:48:22 +0800'>2017-04-04</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=9b6bc67c3393507d0621eb3debbe8845b0eff52d'>optimise `do{...}while(false)` (#1785)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- better heuristics to avoid issues like #1532
- fix `TreeWalker.loopcontrol_target()`
  - `continue` cannot refer to `switch` blocks

</td></tr>
<tr class='logheader'><td><span title='2017-03-24 19:31:17 +0800'>2017-03-24</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=ac51d4c5a079dccbc9a6cf69d06f757432c69694'>fix corner case in `AST_For.init` (#1652)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
Enforce `null` as value for empty initialisation blocks.

fixes #1648

</td></tr>
<tr class='logheader'><td><span title='2017-03-19 12:00:32 +0800'>2017-03-19</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=a3cc3a9b8740eb1bb03c7e4cf008c38ef5c4a60c'>make `expect_stdout` work on Node.js 0.12 (#1623)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
That particular version of Node.js has messed up error messages, so provide a version-specific workaround.

Also fixed an formatting issue which would cause `expect_stdout` to fail if error message contains excerpts of input.

Apply `expect_stdout` to more applicable tests.

</td></tr>
<tr class='logheader'><td><span title='2017-03-10 11:27:30 +0800'>2017-03-10</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=be80f7e706cd6eb1c5f06e433804fda589a8968a'>support multi-line string in tests (#1590)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
`expect_exact` sometimes have multiple lines and `\n` are hard to read.

Use array of strings to emulate line breaks and improve readability.

</td></tr>
<tr class='logheader'><td><span title='2017-03-08 05:07:05 +0800'>2017-03-08</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=dedbeeff15b53a8ab79f9d477ac414e9a6c1ef16'>plan B for IE8 do-while semi-colon fix (#1572)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- omitting trailing semi-colon in do-while breaks non-browser parser, e.g. uglify-js 1.x
- trailing semi-colon only breaks IE8 if followed by `else` or `while`
- always use braces in do-while body to workaround 2nd case with no size loss in compression

fixes #1568

</td></tr>
<tr class='logheader'><td><span title='2017-03-06 17:31:35 +0800'>2017-03-06</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=a9fc9ddc3371a2ba051bca849db3c4b73983f24d'>suppress semicolons after do/while (#1556)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- unless both `beautify` &amp; `screw-ie8` are enabled
- deprecate workaround for if-do-while-else

fixes #186

</td></tr>
<tr class='logheader'><td><span title='2017-03-03 00:54:41 +0800'>2017-03-03</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=b49e142a26094ccb0a6e9f597e7363ba02280eb4'>disable do{...}while(false) optimisation (#1534)</a></td><td>Alex Lam S.L</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- fails to handle `break` in body

fixes #1532

</td></tr>
<tr class='logheader'><td><span title='2017-02-21 13:29:57 +0800'>2017-02-21</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=ae4db00991c6155fde42bd00c30614d922a4219a'>tweak do-while loops</a></td><td>alexlamsl</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- `do{...}while(false)` =&gt; `{...}`
- clean up `AST_While` logic

closes #1452


</td></tr>
<tr class='logheader'><td><span title='2016-07-15 13:20:52 +0200'>2016-07-15</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=7eb52d2837c9d77a389457ae84bfddd28f86cf27'>Keep const in own scope while compressing</a></td><td>Anthony Van de Gejuchte</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
- Fixes #1205
- Fix provided by @kzc


</td></tr>
<tr class='logheader'><td><span title='2015-12-18 19:20:56 +0100'>2015-12-18</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=0cabedc52617cef9623627b390703c011ab6c0b6'>Disable loop optimization for parse-only tests</a></td><td>Anthony Van de Gejuchte</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2015-12-18 14:39:48 +0100'>2015-12-18</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=5cd26c005b3b171f4da8b6732de224089e55ae8a'>Add tests</a></td><td>Anthony Van de Gejuchte</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
</td></tr>
<tr class='logheader'><td><span title='2012-11-08 11:43:14 +0200'>2012-11-08</span></td><td class='logsubject'><a href='/tracifyjs/commit/test/compress/loops.js?id=1a5fd3e05294a74900c6265f364f233e3f05eba0'>optimization for if/break as first statement in a loop body</a></td><td>Mihai Bazon</td></tr>
<tr class='nohover-highlight'><td/><td colspan='3' class='logmsg'>
for(...; x; ...) if (y) break; → for(...; x&amp;&amp;!y; ...);

similarly for `while` and some combinations (i.e. the `break` appears in the
`else` clause, etc.)


</td></tr>
</table><ul class='pager'></ul></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
-utmpx port) result)))))))
                    marionette)
              (((users lines hosts types) ..1)
               (every (lambda (type)
                        (eqv? type (login-type LOGIN_PROCESS)))
                      types))))

          (test-assert "host name resolution"
            (match (marionette-eval
                    '(begin
                       ;; Wait for nscd or our requests go through it.
                       (use-modules (gnu services herd))
                       (start-service 'nscd)

                       (list (getaddrinfo "localhost")
                             (getaddrinfo #$(operating-system-host-name os))))
                    marionette)
              ((((? vector?) ..1) ((? vector?) ..1))
               #t)
              (x
               (pk 'failure x #f))))

          (test-equal "nscd invalidate action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
                                                    result
                                                    result)
                             marionette))

          ;; FIXME: The 'invalidate' action can't reliably obtain the exit
          ;; code of 'nscd' so skip this test.
          (test-skip 1)
          (test-equal "nscd invalidate action, wrong table"
            '(#f)                                 ;one value, #f
            (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
                                                    result
                                                    result)
                             marionette))

          (test-equal "host not found"
            #f
            (marionette-eval
             '(false-if-exception (getaddrinfo "does-not-exist"))
             marionette))

          (test-equal "locale"
            "en_US.utf8"
            (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
                                (setlocale LC_ALL before))
                             marionette))

          (test-eq "/run/current-system is a GC root"
            'success!
            (marionette-eval '(begin
                                ;; Make sure the (guix …) modules are found.
                                (eval-when (expand load eval)
                                  (set! %load-path
                                    (append (map (lambda (package)
                                                   (string-append package
                                                                  "/share/guile/site/"
                                                                  (effective-version)))
                                                 '#$guix&co)
                                            %load-path)))

                                (use-modules (srfi srfi-34) (guix store))

                                (let ((system (readlink "/run/current-system")))
                                  (guard (c ((store-protocol-error? c)
                                             (and (file-exists? system)
                                                  'success!)))
                                    (with-store store
                                      (delete-paths store (list system))
                                      #f))))
                             marionette))

          ;; This symlink is currently unused, but better have it point to the
          ;; right place.  See
          ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>.
          (test-equal "/var/guix/gcroots/profiles is a valid symlink"
            "/var/guix/profiles"
            (marionette-eval '(readlink "/var/guix/gcroots/profiles")
                             marionette))

          (test-equal "guix-daemon set-http-proxy action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'guix-daemon
                                  ('set-http-proxy "http://localhost:8118")
                                  result
                                result)
                             marionette))

          (test-equal "guix-daemon set-http-proxy action, clear"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'guix-daemon
                                  ('set-http-proxy)
                                  result
                                result)
                             marionette))

          (test-assert "screendump"
            (begin
              (let ((capture
                     (string-append #$output "/tty1.ppm")))
                (marionette-control
                 (string-append "screendump " capture) marionette)
                (file-exists? capture))))

          (test-assert "screen text"
            (let ((text (marionette-screen-text marionette
                                                #:ocrad
                                                #$(file-append ocrad
                                                               "/bin/ocrad"))))
              ;; Check whether the welcome message and shell prompt are
              ;; displayed.  Note: OCR confuses "y" and "V" for instance, so
              ;; we cannot reliably match the whole text.
              (and (string-contains text "This is the GNU")
                   (string-contains text
                                    (string-append
                                     "root@"
                                     #$(operating-system-host-name os))))))

          (test-end))))

  (gexp->derivation name test))

(define %test-basic-os
  (system-test
   (name "basic")
   (description
    "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
functionality tests.")
   (value
    (let* ((os  (marionette-operating-system
                 %simple-os
                 #:imported-modules '((gnu services herd)
                                      (guix combinators))))
           (vm  (virtual-machine os)))
      ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
      ;; set of services as the OS produced by
      ;; 'system-qemu-image/shared-store-script'.
      (run-basic-test (virtualized-operating-system os '())
                      #~(list #$vm))))))


;;;
;;; Halt.
;;;

(define (run-halt-test vm)
  ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously
  ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the
  ;; tmux server process as a zombie that remains in the list of processes.
  ;; This test reproduces this scenario.
  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette))

          (define marionette
            (make-marionette '(#$vm)))

          (define ocrad
            #$(file-append ocrad "/bin/ocrad"))

          ;; Wait for tty1 and log in.
          (marionette-eval '(begin
                              (use-modules (gnu services herd))
                              (start-service 'term-tty1))
                           marionette)
          (marionette-type "root\n" marionette)

          ;; Start tmux and wait for it to be ready.
          (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n"
                           marionette)
          (wait-for-file "/ready" marionette)

          ;; Make sure to stop the test after a while.
          (sigaction SIGALRM (lambda _
                               (format (current-error-port)
                                       "FAIL: Time is up, but VM still running.\n")
                               (primitive-exit 1)))
          (alarm 10)

          ;; Get debugging info.
          (marionette-eval '(current-output-port
                             (open-file "/dev/console" "w0"))
                           marionette)
          (marionette-eval '(system* #$(file-append procps "/bin/ps")
                                     "-eo" "pid,ppid,stat,comm")
                           marionette)

          ;; See if 'halt' actually works.
          (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
                           marionette)

          ;; If we reach this line, that means the VM was properly stopped in
          ;; a timely fashion.
          (alarm 0)
          (call-with-output-file #$output
            (lambda (port)
              (display "success!" port))))))

  (gexp->derivation "halt" test))

(define %test-halt
  (system-test
   (name "halt")
   (description
    "Use the 'halt' command and make sure it succeeds and does not get stuck
in a loop.  See <http://bugs.gnu.org/26931>.")
   (value
    (let ((os (marionette-operating-system
               (operating-system
                 (inherit %simple-os)
                 (packages (cons tmux %base-packages)))
               #:imported-modules '((gnu services herd)
                                    (guix combinators)))))
      (run-halt-test (virtual-machine os))))))


;;;
;;; Cleanup of /tmp, /var/run, etc.
;;;

(define %cleanup-os
  (simple-operating-system
   (simple-service 'dirty-things
                   boot-service-type
                   (let ((script (plain-file
                                  "create-utf8-file.sh"
                                  (string-append
                                   "echo $0: dirtying /tmp...\n"
                                   "set -e; set -x\n"
                                   "touch /witness\n"
                                   "exec touch /tmp/λαμβδα"))))
                     (with-imported-modules '((guix build utils))
                       #~(begin
                           (setenv "PATH"
                                   #$(file-append coreutils "/bin"))
                           (invoke #$(file-append bash "/bin/sh")
                                   #$script)))))))

(define (run-cleanup-test name)
  (define os
    (marionette-operating-system %cleanup-os
                                 #:imported-modules '((gnu services herd)
                                                      (guix combinators))))
  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (test-runner-current (system-test-runner #$output))
          (test-begin "cleanup")

          (test-assert "dirty service worked"
            (marionette-eval '(file-exists? "/witness") marionette))

          (test-equal "/tmp cleaned up"
            '("." "..")
            (marionette-eval '(begin
                                (use-modules (ice-9 ftw))
                                (scandir "/tmp"))
                             marionette))

          (test-end))))

  (gexp->derivation "cleanup" test))

(define %test-cleanup
  ;; See <https://bugs.gnu.org/26353>.
  (system-test
   (name "cleanup")
   (description "Make sure the 'cleanup' service can remove files with
non-ASCII names from /tmp.")
   (value (run-cleanup-test name))))


;;;
;;; Mcron.
;;;

(define %mcron-os
  ;; System with an mcron service, with one mcron job for "root" and one mcron
  ;; job for an unprivileged user.
  (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55))
                     (lambda ()
                       (unless (file-exists? "witness")
                        (call-with-output-file "witness"
                          (lambda (port)
                            (display (list (getuid) (getgid)) port)))))))
        (job2 #~(job next-second-from
                     (lambda ()
                       (call-with-output-file "witness"
                         (lambda (port)
                           (display (list (getuid) (getgid)) port))))
                     #:user "alice"))
        (job3 #~(job next-second-from             ;to test $PATH
                     "touch witness-touch")))
    (simple-operating-system
     (service mcron-service-type
              (mcron-configuration (jobs (list job1 job2 job3)))))))

(define (run-mcron-test name)
  (define os
    (marionette-operating-system
     %mcron-os
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (test-runner-current (system-test-runner #$output))
          (test-begin "mcron")

          (test-assert "service running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'mcron))
             marionette))

          ;; Make sure root's mcron job runs, has its cwd set to "/root", and
          ;; runs with the right UID/GID.
          (test-equal "root's job"
            '(0 0)
            (wait-for-file "/root/witness" marionette))

          ;; Likewise for Alice's job.  We cannot know what its GID is since
          ;; it's chosen by 'groupadd', but it's strictly positive.
          (test-assert "alice's job"
            (match (wait-for-file "/home/alice/witness" marionette)
              ((1000 gid)
               (>= gid 100))))

          ;; Last, the job that uses a command; allows us to test whether
          ;; $PATH is sane.
          (test-equal "root's job with command"
            ""
            (wait-for-file "/root/witness-touch" marionette
                           #:read '(@ (ice-9 rdelim) read-string)))

          ;; Make sure the 'schedule' action is accepted.
          (test-equal "schedule action"
            '(#t)                                 ;one value, #t
            (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
                                result)
                             marionette))

          (test-end))))

  (gexp->derivation name test))

(define %test-mcron
  (system-test
   (name "mcron")
   (description "Make sure the mcron service works as advertised.")
   (value (run-mcron-test name))))


;;;
;;; Avahi and NSS-mDNS.
;;;

(define %avahi-os
  (operating-system
    (inherit %simple-os)
    (name-service-switch %mdns-host-lookup-nss)
    (services (cons* (service avahi-service-type
                              (avahi-configuration (debug? #t)))
                     (dbus-service)
                     (service dhcp-client-service-type) ;needed for multicast

                     ;; Enable heavyweight debugging output.
                     (modify-services (operating-system-user-services
                                       %simple-os)
                       (nscd-service-type config
                                          => (nscd-configuration
                                              (inherit config)
                                              (debug-level 3)
                                              (log-file "/dev/console")))
                       (syslog-service-type config
                                            =>
                                            (syslog-configuration
                                             (inherit config)
                                             (config-file
                                              (plain-file
                                               "syslog.conf"
                                               "*.* /dev/console\n")))))))))

(define (run-nss-mdns-test)
  ;; Test resolution of '.local' names via libc.  Start the marionette service
  ;; *after* nscd.  Failing to do that, libc will try to connect to nscd,
  ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
  ;; leading to '.local' resolution failures.
  (define os
    (marionette-operating-system
     %avahi-os
     #:requirements '(nscd)
     #:imported-modules '((gnu services herd)
                          (guix combinators))))

  (define mdns-host-name
    (string-append (operating-system-host-name os)
                   ".local"))

  (define test
    (with-imported-modules '((gnu build marionette))
      #~(begin
          (use-modules (gnu build marionette)
                       (srfi srfi-1)
                       (srfi srfi-64)
                       (ice-9 match))

          (define marionette
            (make-marionette (list #$(virtual-machine os))))

          (mkdir #$output)
          (chdir #$output)

          (test-runner-current (system-test-runner))
          (test-begin "avahi")

          (test-assert "nscd PID file is created"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'nscd))
             marionette))

          (test-assert "nscd is listening on its socket"
            (marionette-eval
             ;; XXX: Work around a race condition in nscd: nscd creates its
             ;; PID file before it is listening on its socket.
             '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
                (let try ()
                  (catch 'system-error
                    (lambda ()
                      (connect sock AF_UNIX "/var/run/nscd/socket")
                      (close-port sock)
                      (format #t "nscd is ready~%")
                      #t)
                    (lambda args
                      (format #t "waiting for nscd...~%")
                      (usleep 500000)
                      (try)))))
             marionette))

          (test-assert "avahi is running"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'avahi-daemon))
             marionette))

          (test-assert "network is up"
            (marionette-eval
             '(begin
                (use-modules (gnu services herd))
                (start-service 'networking))
             marionette))

          (test-equal "avahi-resolve-host-name"
            0
            (marionette-eval
             '(system*
               "/run/current-system/profile/bin/avahi-resolve-host-name"
               "-v" #$mdns-host-name)
             marionette))

          (test-equal "avahi-browse"
            0
            (marionette-eval
             '(system* "/run/current-system/profile/bin/avahi-browse" "-avt")
             marionette))

          (test-assert "getaddrinfo .local"
            ;; Wait for the 'avahi-daemon' service and perform a resolution.
            (match (marionette-eval
                    '(getaddrinfo #$mdns-host-name)
                    marionette)
              (((? vector? addrinfos) ..1)
               (pk 'getaddrinfo addrinfos)
               (and (any (lambda (ai)
                           (= AF_INET (addrinfo:fam ai)))
                         addrinfos)
                    (any (lambda (ai)
                           (= AF_INET6 (addrinfo:fam ai)))
                         addrinfos)))))

          (test-assert "gethostbyname .local"
            (match (pk 'gethostbyname
                       (marionette-eval '(gethostbyname #$mdns-host-name)
                                        marionette))
              ((? vector? result)
               (and (string=? (hostent:name result) #$mdns-host-name)
                    (= (hostent:addrtype result) AF_INET)))))


          (test-end))))

  (gexp->derivation "nss-mdns" test))

(define %test-nss-mdns
  (system-test
   (name "nss-mdns")
   (description
    "Test Avahi's multicast-DNS implementation, and in particular, test its
glibc name service switch (NSS) module.")
   (value (run-nss-mdns-test))))