Initial.

A  .guix-authorizations
A  .guix-channel
A  COPYING
A  README
A  whispers/packages/dict.scm
A  whispers/packages/doc.scm
A  whispers/packages/pdf.scm
A  whispers/packages/sh.scm
A  whispers/packages/whispers.scm
A  whispers/services/console.scm
A  whispers/services/dict.scm
A  whispers/services/finance.scm
A  whispers/services/gps.scm
A  whispers/services/proton.scm
A  whispers/services/ssh-agent.scm
A  whispers/services/ssh-tunneler.scm
A  whispers/services/whispers.scm
A  whispers/services/whispers/finance.scm
A  whispers/services/whispers/gps.scm
A  whispers/services/whispers/mail.scm
A  whispers/services/whispers/ssh.scm
A  whispers/services/whispers/vpn.scm
A  whispers/services/whispers/xdg.scm
A  whispers/tests/ssh-tunneler.scm

1 files changed, 107 insertions, 0 deletions

diff --git a/whispers/tests/ssh-tunneler.scm b/whispers/tests/ssh-tunneler.scm
new file mode 100644
index 0000000..7accb50
--- /dev/null
+++ b/whispers/tests/ssh-tunneler.scm
@@ -0,0 +1,107 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Runciter <runciter@whispers-vpn.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 (whispers tests ssh-tunneler)
+  #:use-module (gnu packages rsync)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services ssh)
+  #:use-module (whispers services ssh-tunneler)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:export (%test-ssh-tunneler))
+
+(define* (run-ssh-tunneler-test ssh-tunneler-os)
+  "Run tests in SSH-TUNNELER-OS, which has a sshd running."
+  (define os
+    (marionette-operating-system
+     ssh-tunneler-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "ssh-tunneler")
+
+          ;; Wait for the forwarding to be established
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+
+                (start-service
+                  'ssh-forwards@reverse-port,6283:127.0.0.1:22))
+             marionette))
+
+          ;; (test-equal "Test file not copied to read-only share"
+          ;;   1                                  ;see "EXIT VALUES" in rsync(1)
+          ;;   (marionette-eval
+          ;;    '(status:exit-val
+          ;;      (system* "rsync" "/tmp/input"
+          ;;               (string-append "rsync://localhost:"
+          ;;                              (number->string #$rsync-port)
+          ;;                              "/read-only/input")))
+          ;;    marionette))
+
+          (test-end))))
+
+  (gexp->derivation "ssh-tunneler-test" test))
+
+(define* %ssh-tunneler-os
+  ;; Return operating system under test.
+  (let ((base-os
+         (simple-operating-system
+          (service openssh-service-type
+                   (openssh-configuration
+                    (permit-root-login #t)
+                    (allow-empty-passwords? #t)))
+          (service persistent-ssh-service-type
+                   (ssh-connection-configuration
+                    (extra-requires '(ssh-daemon))
+                    (require-networking? #f)
+                    (forwards
+                     (list (reverse-port-forward-configuration))))))))
+    (operating-system
+      (inherit base-os)
+      (packages (operating-system-packages base-os)))))
+
+(define %test-ssh-tunneler
+  (system-test
+   (name "ssh-tunneler")
+   (description "Test a VM running ssh forwarding services.")
+   (value (run-ssh-tunneler-test %ssh-tunneler-os))))