;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 machine)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu bootloader)
  #:use-module (gnu build marionette)
  #:use-module (gnu build vm)
  #:use-module (gnu machine)
  #:use-module (gnu machine ssh)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages virtualization)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (gnu services ssh)
  #:use-module (gnu services)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system vm)
  #:use-module (gnu system)
  #:use-module (gnu tests)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix pki)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 textual-ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64)
  #:use-module (ssh auth)
  #:use-module (ssh channel)
  #:use-module (ssh key)
  #:use-module (ssh session))

\f
;;;
;;; Virtual machine scaffolding.
;;;

(define marionette-pid (@@ (gnu build marionette) marionette-pid))

(define (call-with-marionette path command proc)
  "Invoke PROC with a marionette running COMMAND in PATH."
  (let* ((marionette (make-marionette command #:socket-directory path))
         (pid (marionette-pid marionette)))
    (dynamic-wind
      (lambda ()
        (unless marionette
          (error "could not start marionette")))
      (lambda () (proc marionette))
      (lambda ()
        (kill pid SIGTERM)))))

(define (dir-join . components)
  "Join COMPONENTS with `file-name-separator-string'."
  (string-join components file-name-separator-string))

(define (call-with-machine-test-directory proc)
  "Run PROC with the path to a temporary directory that will be cleaned up
when PROC returns. Only files that can be passed to 'delete-file' should be
created within the temporary directory; cleanup will not recurse into
subdirectories."
  (let ((path (tmpnam)))
    (dynamic-wind
      (lambda ()
        (unless (mkdir path)
          (error (format #f "could not create directory '~a'" path))))
      (lambda () (proc path))
      (lambda ()
        (let ((children (map first (cddr (file-system-tree path)))))
          (for-each (lambda (child)
                      (false-if-exception
                       (delete-file (dir-join path child))))
                    children)
          (rmdir path))))))

(define (os-for-test os)
  "Return an <operating-system> record derived from OS that is appropriate for
use with 'qemu-image'."
  (define file-systems-to-keep
    ;; Keep only file systems other than root and not normally bound to real
    ;; devices.
    (remove (lambda (fs)
              (let ((target (file-system-mount-point fs))
                    (source (file-system-device fs)))
                (or (string=? target "/")
                    (string-prefix? "/dev/" source))))
            (operating-system-file-systems os)))

  (define root-uuid
    ;; UUID of the root file system.
    ((@@ (gnu system vm) operating-system-uuid) os 'dce))


  (operating-system
    (inherit os)
    ;; Assume we have an initrd with the whole QEMU shebang.

    ;; Force our own root file system.  Refer to it by UUID so that
    ;; it works regardless of how the image is used ("qemu -hda",
    ;; Xen, etc.).
    (file-systems (cons (file-system
                          (mount-point "/")
                          (device root-uuid)
                          (type "ext4"))
                        file-systems-to-keep))))

(define (qemu-image-for-test os)
  "Return a derivation producing a QEMU disk image running OS. This procedure
is similar to 'system-qemu-image' in (gnu system vm), but makes use of
'os-for-test' so that callers may obtain the same system derivation that will
be booted by the image."
  (define root-uuid ((@@ (gnu system vm) operating-system-uuid) os 'dce))
  (let* ((os (os-for-test os))
         (bootcfg (operating-system-bootcfg os)))
    (qemu-image #:os os
                #:bootcfg-drv bootcfg
                #:bootloader (bootloader-configuration-bootloader
                              (operating-system-bootloader os))
                #:disk-image-size (* 9000 (expt 2 20))
                #:file-system-type "ext4"
                #:file-system-uuid root-uuid
                #:inputs `(("system" ,os)
                           ("bootcfg" ,bootcfg))
                #:copy-inputs? #t)))

(define (make-writable-image image)
  "Return a derivation producing a script to create a writable disk image
overlay of IMAGE, writing the overlay to the the path given as a command-line
argument to the script."
  (define qemu-img-exec
    #~(list (string-append #$qemu-minimal "/bin/qemu-img")
            "create" "-f" "qcow2"
            "-o" (string-append "backing_file=" #$image)))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (format port "#!~a~% exec ~a \"$@\"~%"
                  #$(file-append bash "/bin/sh")
                  (string-join #$qemu-img-exec " "))
          (chmod port #o555))))

  (gexp->derivation "make-writable-image.sh" builder))

(define (run-os-for-test os)
  "Return a derivation producing a script to run OS as a qemu guest, whose
first argument is the path to a writable disk image. Additional arguments are
passed as-is to qemu."
  (define kernel-arguments
    #~(list "console=ttyS0"
            #+@(operating-system-kernel-arguments os "/dev/sda1")))

  (define qemu-exec
    #~(begin
        (list (string-append #$qemu-minimal "/bin/" #$(qemu-command (%current-system)))
              "-kernel" #$(operating-system-kernel-file os)
              "-initrd" #$(file-append os "/initrd")
              (format #f "-append ~s"
                      (string-join #$kernel-arguments " "))
              #$@(if (file-exists? "/dev/kvm")
                     '("-enable-kvm")
                     '())
              "-no-reboot"
              "-net nic,model=virtio"
              "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng"
              "-device" "virtio-rng-pci,rng=guixsd-vm-rng"
              "-vga" "std"
              "-m" "256"
              "-net" "user,hostfwd=tcp::2222-:22")))

  (define builder
    #~(call-with-output-file #$output
        (lambda (port)
          (format port "#!~a~% exec ~a -drive \"file=$@\"~%"
                  #$(file-append bash "/bin/sh")
                  (string-join #$qemu-exec " "))
          (chmod port #o555))))

  (gexp->derivation "run-vm.sh" builder))

(define (scripts-for-test os)
  "Build and return a list containing the paths of:

- A script to make a writable disk image overlay of OS.
- A script to run that disk image overlay as a qemu guest."
  (let ((virtualized-os (os-for-test os)))
    (mlet* %store-monad ((osdrv (operating-system-derivation virtualized-os))
                         (imgdrv (qemu-image-for-test os))

                         ;; Ungexping 'imgdrv' or 'osdrv' will result in an
                         ;; error if the derivations don't exist in the store,
                         ;; so we ensure they're built prior to invoking
                         ;; 'run-vm' or 'make-image'.
                         (_ ((store-lift build-derivations) (list imgdrv)))

                         (run-vm (run-os-for-test virtualized-os))
                         (make-image
                          (make-writable-image (derivation->output-path imgdrv))))
      (mbegin %store-monad
        ((store-lift build-derivations) (list imgdrv make-image run-vm))
        (return (list (derivation->output-path make-image)
                      (derivation->output-path run-vm)))))))

(define (call-with-marionette-and-session os proc)
  "Construct a marionette backed by OS in a temporary test environment and
invoke PROC with two arguments: the marionette object, and an SSH session
connected to the marionette."
  (call-with-machine-test-directory
   (lambda (path)
     (match (with-store store
              (run-with-store store
                (scripts-for-test %system)))
       ((make-image run-vm)
        (let ((image (dir-join path "image")))
          ;; Create the writable image overlay.
          (system (string-join (list make-image image) " "))
          (call-with-marionette
           path
           (list run-vm image)
           (lambda (marionette)
             ;; XXX: The guest clearly has (gcrypt pk-crypto) since this
             ;; works, but trying to import it from 'marionette-eval' fails as
             ;; the Marionette REPL does not have 'guile-gcrypt' in its
             ;; %load-path.
             (marionette-eval
              `(begin
                 (use-modules (ice-9 popen))
                 (let ((port (open-pipe* OPEN_WRITE "guix" "archive" "--authorize")))
                   (put-string port ,%signing-key)
                   (close port)))
              marionette)
             ;; XXX: This is an absolute hack to work around potential quirks
             ;; in the operating system. For one, we invoke 'herd' from the
             ;; command-line to ensure that the Shepherd socket file
             ;; exists. Second, we enable 'ssh-daemon', as there's a chance
             ;; the service will be disabled upon booting the image.
             (marionette-eval
              `(system "herd enable ssh-daemon")
              marionette)
             (marionette-eval
              '(begin
                 (use-modules (gnu services herd))
                 (start-service 'ssh-daemon))
              marionette)
             (call-with-connected-session/auth
              (lambda (session)
                (proc marionette session)))))))))))

\f
;;;
;;; SSH session management. These are borrowed from (gnu tests ssh).
;;;

(define (make-session-for-test)
  "Make a session with predefined parameters for a test."
  (make-session #:user "root"
                #:port 2222
                #:host "localhost"))

(define (call-with-connected-session proc)
  "Call the one-argument procedure PROC with a freshly created and
connected SSH session object, return the result of the procedure call.  The
session is disconnected when the PROC is finished."
  (let ((session (make-session-for-test)))
    (dynamic-wind
      (lambda ()
        (let ((result (connect! session)))
          (unless (equal? result 'ok)
            (error "Could not connect to a server"
                   session result))))
      (lambda () (proc session))
      (lambda () (disconnect! session)))))

(define (call-with-connected-session/auth proc)
  "Make an authenticated session.  We should be able to connect as
root with an empty password."
  (call-with-connected-session
   (lambda (session)
     ;; Try the simple authentication methods.  Dropbear requires
     ;; 'none' when there are no passwords, whereas OpenSSH accepts
     ;; 'password' with an empty password.
     (let loop ((methods (list (cut userauth-password! <> "")
                               (cut userauth-none! <>))))
       (match methods
         (()
          (error "all the authentication methods failed"))
         ((auth rest ...)
          (match (pk 'auth (auth session))
            ('success
             (proc session))
            ('denied
             (loop rest)))))))))

\f
;;;
;;; Virtual machines for use in the test suite.
;;;

(define %system
  ;; A "bare bones" operating system running both an OpenSSH daemon and the
  ;; "marionette" service.
  (marionette-operating-system
   (operating-system
     (host-name "gnu")
     (timezone "Etc/UTC")
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
                  (target "/dev/sda")
                  (terminal-outputs '(console))))
     (file-systems (cons (file-system
                           (mount-point "/")
                           (device "/dev/vda1")
                           (type "ext4"))
                         %base-file-systems))
     (services
      (append (list (service dhcp-client-service-type)
                    (service openssh-service-type
                             (openssh-configuration
                              (permit-root-login #t)
                              (allow-empty-passwords? #t))))
              %base-services)))
   #:imported-modules '((gnu services herd)
                        (guix combinators))))

(define %signing-key
  ;; The host's signing key, encoded as a string. The "marionette" will reject
  ;; any files signed by an unauthorized host, so we'll need to send this key
  ;; over and authorize it.
  (call-with-input-file %public-key-file
    (lambda (port)
      (get-string-all port))))

\f
(test-begin "machine")

(define (system-generations marionette)
  (marionette-eval
   '(begin
      (use-modules (ice-9 ftw)
                   (srfi srfi-1))
      (let* ((profile-dir "/var/guix/profiles/")
             (entries (map first (cddr (file-system-tree profile-dir)))))
        (remove (lambda (entry)
                  (member entry '("per-user" "system")))
                entries)))
   marionette))

(define (running-services marionette)
  (marionette-eval
   '(begin
      (use-modules (gnu services herd)
                   (srfi srfi-1))
      (map (compose first live-service-provision)
           (filter live-service-running (current-services))))
   marionette))

(define (count-grub-cfg-entries marionette)
  (marionette-eval
   '(begin
      (define grub-cfg
        (call-with-input-file "/boot/grub/grub.cfg"
          (lambda (port)
            (get-string-all port))))

        (let loop ((n 0)
                   (start 0))
          (let ((index (string-contains grub-cfg "menuentry" start)))
            (if index
                (loop (1+ n) (1+ index))
                n))))
   marionette))

(define %target-system
  (marionette-operating-system
   (operating-system
     (host-name "gnu-deployed")
     (timezone "Etc/UTC")
     (bootloader (bootloader-configuration
                  (bootloader grub-bootloader)
                  (target "/dev/sda")
                  (terminal-outputs '(console))))
     (file-systems (cons (file-system
                           (mount-point "/")
                           (device "/dev/vda1")
                           (type "ext4"))
                         %base-file-systems))
     (services
      (append (list (service tor-service-type)
                    (service dhcp-client-service-type)
                    (service openssh-service-type
                             (openssh-configuration
                              (permit-root-login #t)
                              (allow-empty-passwords? #t))))
              %base-services)))
   #:imported-modules '((gnu services herd)
                        (guix combinators))))

(call-with-marionette-and-session
 (os-for-test %system)
 (lambda (marionette session)
   (let ((generations-prior (system-generations marionette))
         (services-prior (running-services marionette))
         (grub-entry-count-prior (count-grub-cfg-entries marionette))
         (machine (machine
                   (system %target-system)
                   (environment 'managed-host)
                   (configuration (machine-ssh-configuration
                                   (host-name "localhost")
                                   (session session))))))
     (with-store store
       (run-with-store store
         (build-machine machine))
       (run-with-store store
         (deploy-machine machine)))
     (test-equal "deployment created new generation"
       (length (system-generations marionette))
       (1+ (length generations-prior)))
     (test-assert "deployment started new service"
       (and (not (memq 'tor services-prior))
            (memq 'tor (running-services marionette))))
     (test-equal "deployment created new menu entry"
       (count-grub-cfg-entries marionette)
       ;; A Grub configuration that contains a single menu entry does not have
       ;; an "old configurations" submenu. Deployment, then, would result in
       ;; this submenu being created, meaning an additional two 'menuentry'
       ;; fields rather than just one.
       (if (= grub-entry-count-prior 1)
           (+ 2 grub-entry-count-prior)
           (1+ grub-entry-count-prior))))))

(test-end "machine")